December 2003 - cells-cvs@common-lisp.net

[cells-cvs] CVS update: Module imported: opengl-bindings
by Kenny Tilton 16 Dec '03

16 Dec '03

Update of /project/cells/cvsroot/opengl-bindings In directory common-lisp.net:/tmp/cvs-serv8891 Log Message: Rough, incomplete OpenGL bindings using the ffi-extender utiltities Status: Vendor Tag: Tilton-Technology Release Tags: v1 N opengl-bindings/build.lisp N opengl-bindings/gl-constants.lisp N opengl-bindings/gl-def.lisp N opengl-bindings/gl-functions.lisp N opengl-bindings/glbind.asd N opengl-bindings/glbind.lpr N opengl-bindings/glu-functions.lisp N opengl-bindings/glut-def.lisp N opengl-bindings/glut-extras.lisp N opengl-bindings/glut-functions.lisp N opengl-bindings/load-uffi.lisp N opengl-bindings/nehe-14.lisp No conflicts created by this import Date: Tue Dec 16 12:53:13 2003 Author: ktilton New module opengl-bindings added

1 0

[cells-cvs] CVS update: Module imported: ffi-extender
by Kenny Tilton 16 Dec '03

16 Dec '03

Update of /project/cells/cvsroot/ffi-extender In directory common-lisp.net:/tmp/cvs-serv27478 Log Message: FFI extensions, replacing ffx Status: Vendor Tag: Tilton-Technology Release Tags: v1 N ffi-extender/arrays.lisp N ffi-extender/build.lisp N ffi-extender/callbacks.lisp N ffi-extender/definers.lisp N ffi-extender/ffx.asd No conflicts created by this import Date: Tue Dec 16 12:33:42 2003 Author: ktilton New module ffi-extender added

1 0

[cells-cvs] CVS update: Module imported: cello/glbind/ffx
by Kenny Tilton 16 Dec '03

16 Dec '03

Update of /project/cells/cvsroot/cello/glbind/ffx In directory common-lisp.net:/tmp/cvs-serv19050 Log Message: Initial release of FFI Extensions used for glbind Status: Vendor Tag: TiltonTechnology Release Tags: v0 N cello/glbind/ffx/arrays.lisp N cello/glbind/ffx/build.lisp N cello/glbind/ffx/callbacks.lisp N cello/glbind/ffx/definers.lisp N cello/glbind/ffx/ffx.asd No conflicts created by this import Date: Tue Dec 16 10:24:01 2003 Author: ktilton New module cello/glbind/ffx added

1 0

[cells-cvs] CVS update: cells/doc/use-cases/uc-ring-net.html cells/doc/use-cases/uc-ring-net.lisp cells/doc/use-cases/uc-ring-net.pdf cells/doc/use-cases/uc-ring-net.rtf
by Kenny Tilton 16 Dec '03

16 Dec '03

Update of /project/cells/cvsroot/cells/doc/use-cases In directory common-lisp.net:/tmp/cvs-serv6620/doc/use-cases Added Files: uc-ring-net.html uc-ring-net.lisp uc-ring-net.pdf uc-ring-net.rtf Log Message: Preparing for first CVS of Cello Date: Tue Dec 16 10:03:04 2003 Author: ktilton

1 0

16 Dec '03

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

1 0

[cells-cvs] CVS update: cells/doc/cells-read-me.txt cells/doc/hw.lisp cells/doc/01-Cell-basics.lisp
by Kenny Tilton 16 Dec '03

16 Dec '03

Update of /project/cells/cvsroot/cells/doc In directory common-lisp.net:/tmp/cvs-serv6620/doc Modified Files: 01-Cell-basics.lisp Added Files: cells-read-me.txt hw.lisp Log Message: Preparing for first CVS of Cello Date: Tue Dec 16 10:03:04 2003 Author: ktilton Index: cells/doc/01-Cell-basics.lisp diff -u cells/doc/01-Cell-basics.lisp:1.1.1.1 cells/doc/01-Cell-basics.lisp:1.2 --- cells/doc/01-Cell-basics.lisp:1.1.1.1 Sat Nov 8 18:45:24 2003 +++ cells/doc/01-Cell-basics.lisp Tue Dec 16 10:03:04 2003 @@ -1,420 +1,420 @@ -;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cello; -*- -;;______________________________________________________________ -;; -;; -;; -;; Cell Basics -;; -;; Copyright © 1996,2003 by Kenny Tilton. All rights reserved. -;; - -(in-package :cells) - -#| - -Here is a minimal primer on Cells, just enough for you to -keep up with the next tutorial. That will be a substantial project -in which we develop a CLOS object inspector. - -The Inspector project will give you a feel for what it is like to -program with Cells and Cello /after/ you are fluent in the -technology. The intent is not to teach you Cello, rather to -motivate your learning it. - -So why the primer on Cells? If things like C? and CV and DEF-C-ECHO -do not mean anything to you, the Hunh? Factor will be overwhelming. - - -Cells ------ -Think of a CLOS slot as a cell in a paper spreadsheet, a financial -modeling tool popular enough to make VisiCalc the first business -killer app for microcomputers. - -As a child I watched my father toil at home for hours over paper -spreadsheets with pencil and slide rule. After he changed one value, -he had to propagate that change to other cells by first remembering -which other ones included the changed cell in their computation. -Then he had to do the calculations for those, erase, enter... -and then repeating that process to propagate those changes in a -cascade across the paper. - -VisiCalc let my father take the formula he had in mind and -put it in (declare it to) the electronic spreadsheet. Then VisiCalc -could do the tedious work: recalculating, knowing what to recalculate, -and knowing in what order to recalculate. - -Cells do for programmers what electronic spreadsheets did for my father. -Without Cells, CLOS slots are like cells of a paper spreadsheet. -A single key-down event can cause a cascade of change throughout an -application. The programmer has to arrange for it all to happen, -all in the right order: delete any selected text, insert -the new character, re-wrap the text, update the undo mechanism, revisit -the menu statuses ("Cut" is no longer enabled), update the scroll bars, -possibly scroll the window, flag the file as unsaved... - -With Cells, the programmer looks at program state differently. One -asks, "How could I compute, at any point of runtime, a value for -a given slot of an arbitrary instance, based only on other runtime state -(other slots of other instances)." Great fun, by the way, as well as -enforcing good programming practices like encapsulation. - -An example will help. Consider indeed the state of the "Cut" menu item. -In some applications, programmers have a dozen places in their code -where they tend to the status of the Cut menu item. One might be: - -(defun do-clear (edit-structure) - (when (selected-range edit-structure) - <set up undo> - <toss selected text> - <etc><etc> - (menu-item-enable *edit-cut* nil) - (menu-item-enable *edit-copy* nil) - (menu-item-enable *edit-clear* nil))) - -Other programmers wait until the user clicks on the Edit menu, -then decide just-in-time from program state whether the Cut item -should be enabled: - -(defmethod prep-for-display ((m edit-menu)) - <lotsa other stuff> - (when (typep (focus *app*) 'text-edit-widget) - (menu-item-enable (find :cut (items m) :key #'item-name) - (not (null (selected-range (focus *app*))))))) - -This latter programmer is ready for Cells, because they -have already shifted from imperative to declarative thinking; -they have learned to write code that works based not on what -has happened lately, but instead only on the current program -state (however it got that way). - -The Cell programmer writes: - -(make-instance 'menu-item - :name :cut - :label "Cut" - :cmd-key +control-x+ - :actor #'do-cut - :enabled (c? (when (typep (focus *app*) 'text-edit-widget) - (not (null (selected-range (focus *app*))))))) - -...and now they can forget the menu item exists as they work -on the rest of the application. The menu-item enabled status -will stay current (correct) as the selected-range changes -and as the focus itself changes as the user moves from field -to field. - -That covers the spirit of Cells. Now let's look at the syntax -and mechanics, with examples you can execute once you have -loaded the Cells package. See the read-me.txt file in the -root directory into which the Cello software was unzipped. - -We'll model a falling stone, where the distance fallen is half -the product of the acceleration (due to gravity) and the -square of the time falling. - -|# - -(in-package :cells) - -(defmodel stone () - ((accel :cell t :initarg :accel :initform 0 :accessor accel) - (time-elapsed :cell t :initarg :time-elapsed - :initform (cv 0) - :accessor time-elapsed) - (distance :cell t :initarg :distance :initform 0 :accessor distance)) - (:default-initargs - :distance (c? (/ (* (accel self) - (expt (time-elapsed self) 2)) - 2)))) - -(def-c-echo accel ((self stone) new old old-bound-p) - (trc "ECHO accel" :new new :old old :oldp old-bound-p)) ;; TRC provides print diagnostics - -(def-c-echo time-elapsed ((self stone)) ;; short form (I'm lazy) - (trc "ECHO time-elapsed" :new new-value :old old-value :oldp old-value-boundp)) - -(def-c-echo distance ((self stone)) - (format t "~&ECHO distance fallen: ~d feet" new-value)) - - -#| -Let's look at non-standard syntax found in the forms above, -in the order in which they appear: - - (defmodel ... - -defmodel is just a defclass wrapper which also sets up plumbing for Cells. - - ... :cell t ... - -Without this option, a model instance slot cannot be powered -by a cell (and cell slot access overhead is avoided). - -With this option, one can specify what kind of Cell -is to be defined: ephemeral, delta or t (normal). We'll leave -those esoteric cell slot types for another tutorial and just -specify t to get normal cells (the ones used 99% of the time). - - time-elapsed ... :initform (cv 0)... - -(CV <value>) allows the cellular slot (or "cell", for short) -to be setf'ed. These are inputs to the dataflow, -which usually flows from C? to C? but has to start somewhere. -Since modern interactve applications are event-driven, in -real-world Cello apps most CV dataflow inputs are slots closely -corresponding to some system value, such as the position slots -of a cell-powered Mouse class. Moving on... - -A naked value such as the 32 supplied for accel cannot be changed; a -runtime error results from any such attempt. This makes Cells faster, -because some plumbing can be skipped: no dependency gets recorded between -the distance traveled and the acceleration. On the other hand, a more -elaborate model might have the acceleration varying according to the distance -between the stone and Earth (in which case we get into an advance -topic for another day, namely how to handle circularity.) - -Next: (:default-initargs - :distance (c? (/ (* (accel self) - (expt (time-elapsed self) 2)) - 2) - -C? associates a rule with a cellular slot (or "cell", for short). Any -read operation on another cell (directly or during a function call) -establishes a dependency of distance on that cell -- unless that cell -can never change. Why would a Cell not be able to change? - -Cell internals enforce a rule that a Cell with a naked value (ie, not wrapped -in CV or C?) cannot be changed by client code (ok, (setf slot-value) is a backdoor). -Cell internals enforce this, simply to make possible the optimization -of leaving off the overhead of recording a pointless dependency. - -Next: (def-c-echo... - -Here is the signature for the DEF-C-ECHO macro: - - (defmacro def-c-echo (slotname (&optional (selfarg 'self) - (newvarg 'new-value) - (oldvarg 'old-value) - (oldvargboundp 'old-value-boundp)) - &body echobody) ....) - -def-c-echo defines a generic method one can specialize on any of the four -parameters. The method gets called when the slot value changes, and during -initial processing by: - - (to-be....) - -TO-BE brings a new model instance to life, including calling -any echos defined for cellular slots. - -Why not just do this in initialize-instance? We build complex -models in the form of a tree of many model instances, any of -which may depend on some other model instance to calculate -some part of its state. Models find the one they are curious -about by searching the tree. - -This means we cannot just bring a model instance to life at -make-instance time; some cell rule may go looking for another -model instance. We must wait until the instance is -embedded in the larger model tree, then we can kick off to-be. - -Likewise, when we yank an instance from the larger model we -will call NOT-TO-BE on it. - -The good news is that unless I am doing little tutorial examples -I never think about calling TO-BE. Trees are implemented in part -by a "kids" (short for "children") cell. The echo on that cell -calls TO-BE on new kids and NOT-TO-BE on kids no longer in the list. - -Now evaluate the following: - -|# - -(defparameter *s2* (to-be (make-instance 'stone - :accel 32 ;; (constant) feet per second per second - :time-elapsed (cv 0)))) - -#| - -...and observe: -0> ECHO accel :NEW 32 :OLD NIL :OLDP NIL -0> ECHO time-elapsed :NEW 0 :OLD NIL :OLDP NIL -ECHO distance fallen: 0 feet - - -Getting back to the output shown above, why echo output on a new instance? - -When we call TO-BE we want the instance to come to life. That means -evaluating every rule so the dependencies get established, and -propagating cell values outside the model (by calling the echo -methods) to make sure the model and outside world (if only the -system display) are consistent. - -;----------------------------------------------------------- -Now let's get moving: - -|# - -(setf (time-elapsed *s2*) 1) - -#| -...and observe: -0> ECHO time-elapsed :NEW 1 :OLD 0 :OLDP T -ECHO distance fallen: 16 feet - -behind the scenes: -- the slot value time-elapsed got changed from 0 to 1 -- the time-elapsed echo was called -- dependents on time-elapsed (here just distance) were recalculated -- go to the first step, this time for the distance slot - -;----------------------------------------------------------- -To see some optimizations at work, set the cell time-elapsed to -the same value it already has: -|# - -(setf (time-elapsed *s2*) 1) - -#| observe: -nothing, since the slot-value did not in fact change. - -;----------------------------------------------------------- -To test the enforcement of the Cell stricture against -modifying cells holding naked values: -|# - -(handler-case - (setf (accel *s2*) 10) - (t (error) (trc "error is" error) - error)) - -#| Observe: -c-setting-debug > constant ACCEL in STONE may not be altered..init to (cv nil) -0> error is #<SIMPLE-ERROR @ #x210925f2> - -;----------------------------------------------------------- -Nor may ruled cells be modified arbitrarily: -|# - -(handler-case - (setf (distance *s2*) 42) - (t (error) (trc "error is" error) - error)) - -#| observe: -c-setting-debug > ruled DISTANCE in STONE may not be setf'ed -0> error is #<SIMPLE-ERROR @ #x2123e392> - -;----------------------------------------------------------- -Aside from C?, CV, and DEF-C-ECHO, another thing you will see -in Cello code is how complex views are constructed using -the Family class and its slot KIDS. Every model-object has a -parent slot, which gets used along with a Family's kids slot to -form simple trees navigable up and down. - -Model-objects also have slots for mdName and mdValue (don't -worry camelcase-haters, that is a declining feature of my code). -mdName lets the Family trees we build be treated as namespaces. -mdValue just turns out to be very handy for a lot of things. For -example, a check-box instance needs some place to indicate its -boolean state. - -Now let's see Family in action, using code from the Handbook of -Silly Examples. All I want to get across is that a lot happens -when one changes the kids slot. It happens automatically, and -it happens transparently, following the dataflow implicit in the -rules we write, and the side-effects we specify via echo functions. - -The Silly Example below just shows the Summer (that which sums) getting -a new mdValue as the kids change, along with some echo output. In real-world -applications, where kids represent GUI elements often dependent on -each other, vastly more can transpire before a simple push into a kids -slot has run its course. - -Evaluate: -|# - -(defmodel Summer (Family) - () - (:default-initargs - :kids (cv nil) ;; or we cannot add any addend kids later - :mdValue (c? (reduce #'+ (kids self) - :initial-value 0 - :key #'mdValue)))) - -(def-c-echo .mdValue ((self Summer)) - (trc "The sum of the values of the kids is" new-value)) - -(def-c-echo .kids ((self Summer)) - (trc "The values of the kids are" (mapcar #'mdValue new-value))) - -;----------------------------------------------------------- -; now just evaluate each of the following forms one by one, -; checking results after each to see what is going on -; -(defparameter *f1* (to-be (make-instance 'Summer))) - -#| -observe: -0> The sum of the values of the kids is 0 -0> The values of the kids are NIL - -;----------------------------------------------------------|# - -(push (make-instance 'model :mdValue 1) (kids *f1*)) - -#| observe: -0> The values of the kids are (1) -0> The sum of the values of the kids is 1 - -;----------------------------------------------------------|# - -(push (make-instance 'model :mdValue 2) (kids *f1*)) - -#| observe: -0> The values of the kids are (2 1) -0> The sum of the values of the kids is 3 - -;----------------------------------------------------------|# - -(setf (kids *f1*) nil) - -#| observe: -0> The values of the kids are NIL -0> The sum of the values of the kids is 0 - -Now before closing, it occurs to me you'll need a little -introduction to the semantics of ^SLOT-X macros generated -by the DEFMODEL macro. Here is another way to define our stone: - -|# - -(setq *s2* (to-be (make-instance 'stone - :accel 2 - :time-elapsed (cv 3) - :distance (c? (+ (^accel) (^time-elapsed)))))) - -#| In the olden days of Cells, when they were called -Semaphors, the only way to establish a dependency -was to use some form like: - - (^some-slot some-thing) - -That is no longer necessary. Now any dynamic access: - -(1) during evaluation of a form wrapped in (c?...) -(2) to a cell, direct or inside some function -(3) using accessors named in the defmodel form (not SLOT-VALUE) - -...establishes a dependency. So why still have the ^slot macros? - -One neat thing about the ^slot macros is that the default -argument is SELF, an anaphor set up by C? and its ilk, so -one can make many rules a little easier to follow by simply -coding (^slot). Another is convenient specification of -Synapses on dependencies, a more advanced topic we can -ignore a while. - - -|# +;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cello; -*- +;;______________________________________________________________ +;; +;; +;; +;; Cell Basics +;; +;; Copyright (c) 1996,2003 by Kenny Tilton. All rights reserved. +;; + +(in-package :cells) + +#| + +Here is a minimal primer on Cells, just enough for you to +keep up with the next tutorial. That will be a substantial project +in which we develop a CLOS object inspector. + +The Inspector project will give you a feel for what it is like to +program with Cells and Cello /after/ you are fluent in the +technology. The intent is not to teach you Cello, rather to +motivate your learning it. + +So why the primer on Cells? If things like C? and CV and DEF-C-ECHO +do not mean anything to you, the Hunh? Factor will be overwhelming. + + +Cells +----- +Think of a CLOS slot as a cell in a paper spreadsheet, a financial +modeling tool popular enough to make VisiCalc the first business +killer app for microcomputers. + +As a child I watched my father toil at home for hours over paper +spreadsheets with pencil and slide rule. After he changed one value, +he had to propagate that change to other cells by first remembering +which other ones included the changed cell in their computation. +Then he had to do the calculations for those, erase, enter... +and then repeating that process to propagate those changes in a +cascade across the paper. + +VisiCalc let my father take the formula he had in mind and +put it in (declare it to) the electronic spreadsheet. Then VisiCalc +could do the tedious work: recalculating, knowing what to recalculate, +and knowing in what order to recalculate. + +Cells do for programmers what electronic spreadsheets did for my father. +Without Cells, CLOS slots are like cells of a paper spreadsheet. +A single key-down event can cause a cascade of change throughout an +application. The programmer has to arrange for it all to happen, +all in the right order: delete any selected text, insert +the new character, re-wrap the text, update the undo mechanism, revisit +the menu statuses ("Cut" is no longer enabled), update the scroll bars, +possibly scroll the window, flag the file as unsaved... + +With Cells, the programmer looks at program state differently. One +asks, "How could I compute, at any point of runtime, a value for +a given slot of an arbitrary instance, based only on other runtime state +(other slots of other instances)." Great fun, by the way, as well as +enforcing good programming practices like encapsulation. + +An example will help. Consider indeed the state of the "Cut" menu item. +In some applications, programmers have a dozen places in their code +where they tend to the status of the Cut menu item. One might be: + +(defun do-clear (edit-structure) + (when (selected-range edit-structure) + <set up undo> + <toss selected text> + <etc><etc> + (menu-item-enable *edit-cut* nil) + (menu-item-enable *edit-copy* nil) + (menu-item-enable *edit-clear* nil))) + +Other programmers wait until the user clicks on the Edit menu, +then decide just-in-time from program state whether the Cut item +should be enabled: + +(defmethod prep-for-display ((m edit-menu)) + <lotsa other stuff> + (when (typep (focus *app*) 'text-edit-widget) + (menu-item-enable (find :cut (items m) :key #'item-name) + (not (null (selected-range (focus *app*))))))) + +This latter programmer is ready for Cells, because they +have already shifted from imperative to declarative thinking; +they have learned to write code that works based not on what +has happened lately, but instead only on the current program +state (however it got that way). + +The Cell programmer writes: + +(make-instance 'menu-item + :name :cut + :label "Cut" + :cmd-key +control-x+ + :actor #'do-cut + :enabled (c? (when (typep (focus *app*) 'text-edit-widget) + (not (null (selected-range (focus *app*))))))) + +...and now they can forget the menu item exists as they work +on the rest of the application. The menu-item enabled status +will stay current (correct) as the selected-range changes +and as the focus itself changes as the user moves from field +to field. + +That covers the spirit of Cells. Now let's look at the syntax +and mechanics, with examples you can execute once you have +loaded the Cells package. See the read-me.txt file in the +root directory into which the Cello software was unzipped. + +We'll model a falling stone, where the distance fallen is half +the product of the acceleration (due to gravity) and the +square of the time falling. + +|# + +(in-package :cells) + +(defmodel stone () + ((accel :cell t :initarg :accel :initform 0 :accessor accel) + (time-elapsed :cell t :initarg :time-elapsed + :initform (cv 0) + :accessor time-elapsed) + (distance :cell t :initarg :distance :initform 0 :accessor distance)) + (:default-initargs + :distance (c? (/ (* (accel self) + (expt (time-elapsed self) 2)) + 2)))) + +(def-c-echo accel ((self stone) new old old-bound-p) + (trc "ECHO accel" :new new :old old :oldp old-bound-p)) ;; TRC provides print diagnostics + +(def-c-echo time-elapsed ((self stone)) ;; short form (I'm lazy) + (trc "ECHO time-elapsed" :new new-value :old old-value :oldp old-value-boundp)) + +(def-c-echo distance ((self stone)) + (format t "~&ECHO distance fallen: ~d feet" new-value)) + + +#| +Let's look at non-standard syntax found in the forms above, +in the order in which they appear: + + (defmodel ... + +defmodel is just a defclass wrapper which also sets up plumbing for Cells. + + ... :cell t ... + +Without this option, a model instance slot cannot be powered +by a cell (and cell slot access overhead is avoided). + +With this option, one can specify what kind of Cell +is to be defined: ephemeral, delta or t (normal). We'll leave +those esoteric cell slot types for another tutorial and just +specify t to get normal cells (the ones used 99% of the time). + + time-elapsed ... :initform (cv 0)... + +(CV <value>) allows the cellular slot (or "cell", for short) +to be setf'ed. These are inputs to the dataflow, +which usually flows from C? to C? but has to start somewhere. +Since modern interactve applications are event-driven, in +real-world Cello apps most CV dataflow inputs are slots closely +corresponding to some system value, such as the position slots +of a cell-powered Mouse class. Moving on... + +A naked value such as the 32 supplied for accel cannot be changed; a +runtime error results from any such attempt. This makes Cells faster, +because some plumbing can be skipped: no dependency gets recorded between +the distance traveled and the acceleration. On the other hand, a more +elaborate model might have the acceleration varying according to the distance +between the stone and Earth (in which case we get into an advance +topic for another day, namely how to handle circularity.) + +Next: (:default-initargs + :distance (c? (/ (* (accel self) + (expt (time-elapsed self) 2)) + 2) + +C? associates a rule with a cellular slot (or "cell", for short). Any +read operation on another cell (directly or during a function call) +establishes a dependency of distance on that cell -- unless that cell +can never change. Why would a Cell not be able to change? + +Cell internals enforce a rule that a Cell with a naked value (ie, not wrapped +in CV or C?) cannot be changed by client code (ok, (setf slot-value) is a backdoor). +Cell internals enforce this, simply to make possible the optimization +of leaving off the overhead of recording a pointless dependency. + +Next: (def-c-echo... + +Here is the signature for the DEF-C-ECHO macro: + + (defmacro def-c-echo (slotname (&optional (selfarg 'self) + (newvarg 'new-value) + (oldvarg 'old-value) + (oldvargboundp 'old-value-boundp)) + &body echobody) ....) + +def-c-echo defines a generic method one can specialize on any of the four +parameters. The method gets called when the slot value changes, and during +initial processing by: + + (to-be....) + +TO-BE brings a new model instance to life, including calling +any echos defined for cellular slots. + +Why not just do this in initialize-instance? We build complex +models in the form of a tree of many model instances, any of +which may depend on some other model instance to calculate +some part of its state. Models find the one they are curious +about by searching the tree. + +This means we cannot just bring a model instance to life at +make-instance time; some cell rule may go looking for another +model instance. We must wait until the instance is +embedded in the larger model tree, then we can kick off to-be. + +Likewise, when we yank an instance from the larger model we +will call NOT-TO-BE on it. + +The good news is that unless I am doing little tutorial examples +I never think about calling TO-BE. Trees are implemented in part +by a "kids" (short for "children") cell. The echo on that cell +calls TO-BE on new kids and NOT-TO-BE on kids no longer in the list. + +Now evaluate the following: + +|# + +(defparameter *s2* (to-be (make-instance 'stone + :accel 32 ;; (constant) feet per second per second + :time-elapsed (cv 0)))) + +#| + +...and observe: +0> ECHO accel :NEW 32 :OLD NIL :OLDP NIL +0> ECHO time-elapsed :NEW 0 :OLD NIL :OLDP NIL +ECHO distance fallen: 0 feet + + +Getting back to the output shown above, why echo output on a new instance? + +When we call TO-BE we want the instance to come to life. That means +evaluating every rule so the dependencies get established, and +propagating cell values outside the model (by calling the echo +methods) to make sure the model and outside world (if only the +system display) are consistent. + +;----------------------------------------------------------- +Now let's get moving: + +|# + +(setf (time-elapsed *s2*) 1) + +#| +...and observe: +0> ECHO time-elapsed :NEW 1 :OLD 0 :OLDP T +ECHO distance fallen: 16 feet + +behind the scenes: +- the slot value time-elapsed got changed from 0 to 1 +- the time-elapsed echo was called +- dependents on time-elapsed (here just distance) were recalculated +- go to the first step, this time for the distance slot + +;----------------------------------------------------------- +To see some optimizations at work, set the cell time-elapsed to +the same value it already has: +|# + +(setf (time-elapsed *s2*) 1) + +#| observe: +nothing, since the slot-value did not in fact change. + +;----------------------------------------------------------- +To test the enforcement of the Cell stricture against +modifying cells holding naked values: +|# + +(handler-case + (setf (accel *s2*) 10) + (t (error) (trc "error is" error) + error)) + +#| Observe: +c-setting-debug > constant ACCEL in STONE may not be altered..init to (cv nil) +0> error is #<SIMPLE-ERROR @ #x210925f2> + +;----------------------------------------------------------- +Nor may ruled cells be modified arbitrarily: +|# + +(handler-case + (setf (distance *s2*) 42) + (t (error) (trc "error is" error) + error)) + +#| observe: +c-setting-debug > ruled DISTANCE in STONE may not be setf'ed +0> error is #<SIMPLE-ERROR @ #x2123e392> + +;----------------------------------------------------------- +Aside from C?, CV, and DEF-C-ECHO, another thing you will see +in Cello code is how complex views are constructed using +the Family class and its slot KIDS. Every model-object has a +parent slot, which gets used along with a Family's kids slot to +form simple trees navigable up and down. + +Model-objects also have slots for md-name and md-value (don't +worry camelcase-haters, that is a declining feature of my code). +md-name lets the Family trees we build be treated as namespaces. +md-value just turns out to be very handy for a lot of things. For +example, a check-box instance needs some place to indicate its +boolean state. + +Now let's see Family in action, using code from the Handbook of +Silly Examples. All I want to get across is that a lot happens +when one changes the kids slot. It happens automatically, and +it happens transparently, following the dataflow implicit in the +rules we write, and the side-effects we specify via echo functions. + +The Silly Example below just shows the Summer (that which sums) getting +a new md-value as the kids change, along with some echo output. In real-world +applications, where kids represent GUI elements often dependent on +each other, vastly more can transpire before a simple push into a kids +slot has run its course. + +Evaluate: +|# + +(defmodel Summer (Family) + () + (:default-initargs + :kids (cv nil) ;; or we cannot add any addend kids later + :md-value (c? (reduce #'+ (kids self) + :initial-value 0 + :key #'md-value)))) + +(def-c-echo .md-value ((self Summer)) + (trc "The sum of the values of the kids is" new-value)) + +(def-c-echo .kids ((self Summer)) + (trc "The values of the kids are" (mapcar #'md-value new-value))) + +;----------------------------------------------------------- +; now just evaluate each of the following forms one by one, +; checking results after each to see what is going on +; +(defparameter *f1* (to-be (make-instance 'Summer))) + +#| +observe: +0> The sum of the values of the kids is 0 +0> The values of the kids are NIL + +;----------------------------------------------------------|# + +(push (make-instance 'model :md-value 1) (kids *f1*)) + +#| observe: +0> The values of the kids are (1) +0> The sum of the values of the kids is 1 + +;----------------------------------------------------------|# + +(push (make-instance 'model :md-value 2) (kids *f1*)) + +#| observe: +0> The values of the kids are (2 1) +0> The sum of the values of the kids is 3 + +;----------------------------------------------------------|# + +(setf (kids *f1*) nil) + +#| observe: +0> The values of the kids are NIL +0> The sum of the values of the kids is 0 + +Now before closing, it occurs to me you'll need a little +introduction to the semantics of ^SLOT-X macros generated +by the DEFMODEL macro. Here is another way to define our stone: + +|# + +(setq *s2* (to-be (make-instance 'stone + :accel 2 + :time-elapsed (cv 3) + :distance (c? (+ (^accel) (^time-elapsed)))))) + +#| In the olden days of Cells, when they were called +Semaphors, the only way to establish a dependency +was to use some form like: + + (^some-slot some-thing) + +That is no longer necessary. Now any dynamic access: + +(1) during evaluation of a form wrapped in (c?...) +(2) to a cell, direct or inside some function +(3) using accessors named in the defmodel form (not SLOT-VALUE) + +...establishes a dependency. So why still have the ^slot macros? + +One neat thing about the ^slot macros is that the default +argument is SELF, an anaphor set up by C? and its ilk, so +one can make many rules a little easier to follow by simply +coding (^slot). Another is convenient specification of +Synapses on dependencies, a more advanced topic we can +ignore a while. + + +|#

1 0

[cells-cvs] CVS update: cells/build-sys.lisp cells/build.lisp cells/calc-n-set.lisp cells/cell-types.lisp cells/cells.asd cells/cells.lisp cells/dataflow-management.lisp cells/debug.lisp cells/defmodel.lisp cells/detritus.lisp cells/family-values.lisp cells/family.lisp cells/flow-control.lisp cells/fm-utilities.lisp cells/initialize.lisp cells/link.lisp cells/md-slot-value.lisp cells/md-utilities.lisp cells/model-object.lisp cells/optimization.lisp cells/propagate.lisp cells/qells.lisp cells/qrock.lisp cell
by Kenny Tilton 16 Dec '03

16 Dec '03

Update of /project/cells/cvsroot/cells In directory common-lisp.net:/tmp/cvs-serv6620 Modified Files: build.lisp calc-n-set.lisp cell-types.lisp cells.asd cells.lisp dataflow-management.lisp debug.lisp defmodel.lisp detritus.lisp family-values.lisp family.lisp flow-control.lisp fm-utilities.lisp initialize.lisp link.lisp md-slot-value.lisp md-utilities.lisp model-object.lisp optimization.lisp propagate.lisp qells.lisp qrock.lisp slot-utilities.lisp strings.lisp strudel-object.lisp synapse.lisp Added Files: build-sys.lisp Removed Files: buildold.lisp cells-read-me.txt datetime.lisp Log Message: Preparing for first CVS of Cello Date: Tue Dec 16 10:02:59 2003 Author: ktilton Index: cells/build.lisp diff -u cells/build.lisp:1.1.1.1 cells/build.lisp:1.2 --- cells/build.lisp:1.1.1.1 Sat Nov 8 18:43:38 2003 +++ cells/build.lisp Tue Dec 16 10:02:58 2003 @@ -1,102 +1,71 @@ -;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cl-user; -*- -;;; -;;; 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. - -(defpackage #:cells-build-package - (:use #:cl)) -(in-package :cl-user) ;;#:cells-build-package) - -;;; *********************************************************************** -;;; Begin configuration section -;;; -;;; Step 1 -;;; ------ -;;; Edit the definition of *CELLS-SOURCE-DIRECTORY* so the build script -;;; knows where to find its source. For example: -;;; -;;; Unix: -;;; (defvar *cells-source-directory* #p"/usr/local/src/cells/") -;;; -;;; Windows: -;;; -;;;(defparameter *cells-source-directory* -;;; (make-pathname #+lispworks :host #-lispworks :device "C" -;;; :directory "/dev/cells")) - -;;; Validation of *cells-source-directory* -;;; -(unless (boundp '*cells-source-directory*) - (error "*CELLS-SOURCE-DIRECTORY* not supplied, please edit build.lisp to specify the location of the source.")) - -(unless (probe-file (merge-pathnames "cells.asd" *cells-source-directory*)) - (error "cells.asd not found in:~& *CELLS-SOURCE-DIRECTORY* => ~a" - *cells-source-directory*)) - -;;; Step 2 -;;; ------ -;;; Help the build script find ASDF if not already loaded -#-asdf -(load (merge-pathnames (make-pathname :name "asdf" :type "lisp") - *cells-source-directory*)) - -;;; Step 3 -;;; ------ -;;; Decide if you want to run the Cells regression test suite [optional] -(defparameter *test-cells* t) - -;;; Yer done -;;; -;;; End configuration section -;;; *********************************************************************** - - -(defparameter *cells-test-directory* - (merge-pathnames (make-pathname :directory '(:relative "cells-test")) - *cells-source-directory*)) - -;;; -;;; Implementation-specific weirdness goes here -;;; - -(let (;; Let's assume this is fixed in CMUCL 19a, and fix it later if need be. - #+cmu18 - (ext:*derive-function-types* nil) - - #+lispworks - (hcl::*handle-existing-defpackage* (list :add)) - ) - -;;; -;;; Now, build the system -;;; - - (push *cells-source-directory* asdf:*central-registry*) - (asdf:operate 'asdf:load-op :cells) - - (when *test-cells* - (push *cells-test-directory* asdf:*central-registry*) - (asdf:operate 'asdf:load-op :cells-test) - (format t "~&~%Warning on refined c-echo-slot-name is expected because") - (format t "~&cells-test is loaded. To run the test suite, evaluate:") - (format t "~&~% (cells::cv-test)") - (format t "~&~%and simply confirm it runs to completion."))) - -(delete-package '#:cells-build-package) \ No newline at end of file +;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cl-user; -*- + +(in-package :cl-user) + +;;; *********************************************************************** +;;; Begin configuration section +;;; +;;; Before building Cells, review and customize the following settings: +;;; +(let ( + ;; Step 1 + ;; ------ + ;; The path to ASDF. This is only necessary if it's not already loaded. + ;; + ;; Examples: + ;; Unix: (asdf-path (pathname "/usr/local/src/asdf.lisp")) + ;; Windows: (asdf-path (pathname "C:\\dev\\asdf.lisp")) + ;; Windows: (asdf-path (make-pathname :directory '(:absolute "dev") + ;; :name "asdf" :type "lisp")) + (asdf-path nil) + + ;; Step 2 + ;; ------ + ;; The path to the Cells source directory. + ;; + ;; Examples: + ;; Unix: (cells-path (pathname "/usr/local/src/cells/")) + ;; Windows: (cells-path (pathname "C:\\dev\\cells\\")) + ;; Windows: (cells-path (make-pathname + ;; :directory '(:absolute "dev" "cells") + ;; #+lispworks :host #-lispworks :device + ;; "C")) + (cells-path nil) + + ;; Step 3 + ;; ------ + ;; Decide if you want to load and run the regression test suite. + ;; If you want to validate the system or explore the test suite, + ;; some of which is heavily annotated, set TESTP to T + (testp t) + ) + +;;; Yer done +;;; +;;; End configuration section +;;; *********************************************************************** + + + ;; Ensure ASDF is loaded + #-asdf + (progn (assert (not (null asdf-path)) + (asdf-path) + "ASDF is not loaded, and ASDF-PATH was not supplied. Please edit build.lisp") + (load asdf-path)) + + ;; Build Cells. + (load (merge-pathnames "build-sys.lisp" cells-path)) + (funcall (intern "BUILD-SYS" "CELLS-BUILD-PACKAGE") + :force t :source-directory cells-path) + + ;; Load and run the test suite, if requested. + (when testp + (funcall (intern "BUILD-SYS" "CELLS-BUILD-PACKAGE") + :force t + :source-directory (merge-pathnames + (make-pathname :directory '(:wild "cells-test")) + cells-path)) + (funcall (intern "CV-TEST" "CELLS"))) + + ;; Remove build package + (delete-package "CELLS-BUILD-PACKAGE")) Index: cells/calc-n-set.lisp diff -u cells/calc-n-set.lisp:1.1.1.1 cells/calc-n-set.lisp:1.2 --- cells/calc-n-set.lisp:1.1.1.1 Sat Nov 8 18:43:48 2003 +++ cells/calc-n-set.lisp Tue Dec 16 10:02:58 2003 @@ -1,108 +1,103 @@ -;; -*- 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) - -;____________________________ cell calculate and set ___________________ -; - -(defun c-calculate-and-set (c) - (when *stop* - (princ #\.) - (return-from c-calculate-and-set)) - - (assert (not (cmdead c))) - - (when (find c *c-calculators*) ;; circularity - (if (unst-cyclic-p c) - (progn - (trc "md-slot-value cyclic defaulting" c (unst-cyclic-value c)) - (return-from c-calculate-and-set (unst-cyclic-value c))) - (progn - (setf *stop* t) - (trc "md-slot-value breaking on circularity" c *c-calculators*) - (break ;; problem when testing cells on some CLs - "cell ~a midst askers: ~a" c *c-calculators*)))) - - (count-it :c-calculate-and-set ) - ;;; (count-it :c-calculate-and-set (type-of (c-model c))) ;; (c-slot-name c)) - - ;;(with-metrics (nil nil () "calc n set" (c-slot-name c) (c-model c)) - (progn ;; wtrc (0 200 "calc n set" (c-slot-name c) (c-model c)) - (cd-usage-clear-all c) - - (let ((mycalc (incf (cr-rethinking c) 1)) - (newvalue (let ((*c-calculators* (cons c *c-calculators*)) - *synapse-factory* ;; clear, then if desired each access to potential other cell must estab. *synapse-factory* - ) - (assert (c-model c)) - #+not (when (plusp *trcdepth*) - (format t "ccalcnset> calcing ~a calcers ~a" c *c-calculators*)) - (funcall (cr-rule c) c)))) - - #+notso (assert (not (typep newvalue 'cell)) () - "new value for cell ~s is itself a cell: ~s. probably nested (c? ... (c? ))" - c newvalue) - (when (and *c-debug* (typep newvalue 'cell)) - (trc "new value for cell ~s is itself a cell: ~s. probably nested (c? ... (c? ))" - c newvalue)) - (when (< mycalc (cr-rethinking c)) - ;; - ;; means we re-entered rule and managed to compute without re-entering under new circumstances - ;; of later entry. use later calculation result.. - (trc nil "calc-n-set > breaking off, not lg" c) - ;; - (assert (c-validp c)) - (return-from c-calculate-and-set (c-value c))) - - (c-unlink-unused c) - - (md-slot-value-assume (c-model c) - (c-slot-spec c) - (c-absorb-value c newvalue))))) - -#+test -(loop for useds on '(1 2 3 4 5) - for used = (car useds) - for mapn upfrom 5 - when (oddp used) - do (print (list useds mapn))(print used)) - -(defun c-unlink-unused (c &aux (usage (cd-usage c))) - (loop for useds on (cd-useds c) - for used = (car useds) - for mapn upfrom (- *cd-usagect* (length (cd-useds c))) - when (zerop (sbit usage mapn)) - do - (assert (not (minusp mapn))) - (assert (< mapn *cd-usagect*)) - (if (typep used 'synapse) - (progn - (setf (syn-relevant used) nil) ;; 030826synfix - ) - (progn - (trc nil "dropping unused" used :mapn-usage mapn usage) - (c-unlink-user used c) - (rplaca useds nil)))) - (setf (cd-useds c) (delete-if #'null (cd-useds c)))) - - +;; -*- 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) + +;____________________________ cell calculate and set ___________________ +; + +(defun c-calculate-and-set (c) + (when (c-stopped) + (princ #\.) + (return-from c-calculate-and-set)) + + (c-assert (not (cmdead c))) + + (when (find c *c-calculators*) ;; circularity + (c-stop :c-calculate-and-set-circ-ask) + (trc "md-slot-value breaking on circularity" c *c-calculators*) + (break ;; problem when testing cells on some CLs + "cell ~a midst askers: ~a" c *c-calculators*)) + + (count-it :c-calculate-and-set ) + ;;; (count-it :c-calculate-and-set (type-of (c-model c))) ;; (c-slot-name c)) + + ;;(with-metrics (nil nil () "calc n set" (c-slot-name c) (c-model c)) + (progn ;; wtrc (0 200 "calc n set" (c-slot-name c) (c-model c)) + (cd-usage-clear-all c) + + (let ((mycalc (incf (cr-rethinking c) 1)) + (newvalue (let ((*c-calculators* (cons c *c-calculators*)) + *synapse-factory* ;; clear, then if desired each access to potential other cell must estab. *synapse-factory* + ) + (c-assert (c-model c)) + #+not (when (plusp *trcdepth*) + (format t "ccalcnset> calcing ~a calcers ~a" c *c-calculators*)) + (funcall (cr-rule c) c)))) + + #+notso (c-assert (not (typep newvalue 'cell)) () + "new value for cell ~s is itself a cell: ~s. probably nested (c? ... (c? ))" + c newvalue) + (when (and *c-debug* (typep newvalue 'cell)) + (trc "new value for cell ~s is itself a cell: ~s. probably nested (c? ... (c? ))" + c newvalue)) + (when (< mycalc (cr-rethinking c)) + ;; + ;; means we re-entered rule and managed to compute without re-entering under new circumstances + ;; of later entry. use later calculation result.. + (trc nil "calc-n-set > breaking off, not lg" c) + ;; + (c-assert (c-validp c)) + (return-from c-calculate-and-set (c-value c))) + + (c-unlink-unused c) + + (md-slot-value-assume (c-model c) + (c-slot-spec c) + (c-absorb-value c newvalue))))) + +#+test +(loop for useds on '(1 2 3 4 5) + for used = (car useds) + for mapn upfrom 5 + when (oddp used) + do (print (list useds mapn))(print used)) + +(defun c-unlink-unused (c &aux (usage (cd-usage c))) + (loop for useds on (cd-useds c) + for used = (car useds) + for mapn upfrom (- *cd-usagect* (length (cd-useds c))) + when (zerop (sbit usage mapn)) + do + (c-assert (not (minusp mapn))) + (c-assert (< mapn *cd-usagect*)) + (if (typep used 'synapse) + (progn + (setf (syn-relevant used) nil) ;; 030826synfix + ) + (progn + (trc nil "dropping unused" used :mapn-usage mapn usage) + (c-unlink-user used c) + (rplaca useds nil)))) + (setf (cd-useds c) (delete-if #'null (cd-useds c)))) + + Index: cells/cell-types.lisp diff -u cells/cell-types.lisp:1.1.1.1 cells/cell-types.lisp:1.2 --- cells/cell-types.lisp:1.1.1.1 Sat Nov 8 18:43:48 2003 +++ cells/cell-types.lisp Tue Dec 16 10:02:58 2003 @@ -1,293 +1,257 @@ -;; -*- 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) - -(defun slot-spec-name (slot-spec) - slot-spec) - -(cc-defstruct (cell (:conc-name c-)) - waking-state - model - slot-spec - value - ) - -(defun c-slot-name (c) - (slot-spec-name (c-slot-spec c))) - -(defun c-validate (self c) - (when (not (and (c-slot-spec c) (c-model c))) -;;; (setf *stop* t) - (format t "~&unadopted cell: ~s md:~s, awake:~s" c self (c-waking-state self)) - (error 'c-unadopted :cell c))) - -(defmethod c-when (other) - (declare (ignorable other)) nil) ;; /// needs work - -(cc-defstruct (synapse - (:include cell) - (:conc-name syn-)) - user - used - (relevant t) ;; not if unused during subsequent eval. but keep to preserve likely state - fire-p - relay-value) - -(defmacro mksynapse ((&rest closeovervars) &key trcp fire-p relay-value) - (let ((used (copy-symbol 'used)) (user (copy-symbol 'user))) - `(lambda (,used ,user) - ,(when trcp - `(trc "making synapse between user" ',trcp ,user :and :used ,used)) - (let (,@closeovervars) - (make-synapse - :used ,used - ;;; 210207kt why? use (c-model (syn-used <syn>)) :c-model (c-model ,used) - :user ,user - :fire-p ,fire-p - :relay-value ,relay-value))))) - -(defmethod print-object ((syn synapse) stream) - (format stream "{syn ~s ==> ~s" (syn-used syn) (syn-user syn))) - - -(defmethod c-true-stalep ((syn synapse)) - (cd-stale-p (syn-user syn))) - -(cc-defstruct (c-user-notifying - (:include cell) - (:conc-name un-)) - (users nil :type list)) - -(cc-defstruct (c-unsteady - (:include c-user-notifying) - (:conc-name unst-)) - cyclic-p - cyclic-value - delta-p - setting-p) - -(cc-defstruct (c-variable - (:include c-unsteady))) - -(cc-defstruct (c-ruled - (:include c-unsteady) - (:conc-name cr-)) - (state :unbound :type symbol) - (rethinking 0 :type number) - lazy - rule) - -(defmethod c-lazy-p ((c c-ruled)) (cr-lazy c)) -(defmethod c-lazy-p (c) (declare (ignore c)) nil) - -(defun c-optimized-away-p (c) - (eql :optimized-away (c-state c))) - -;---------------------------- - - -(defmethod c-true-stalep (c) - (declare (ignore c))) - -(cc-defstruct (c-independent - ;; - ;; these do not optimize away, because also these can be set after initial evaluation of the rule, - ;; so users better stay tuned. - ;; the whole idea here is that the old idea of having cv bodies evaluated immediately finally - ;; broke down when we wanted to say :kids (cv (list (fm-other vertex))) - ;; - (:include c-ruled))) - -(defmethod trcp-slot (self slot-name) - (declare (ignore self slot-name))) - -(defconstant *cd-usagect* 64) - -(cc-defstruct (c-dependent - (:include c-ruled) - (:conc-name cd-)) - (useds nil :type list) - (code nil :type list) ;; /// feature this out on production build - (usage (make-array *cd-usagect* :element-type 'bit - :initial-element 0) :type vector) - stale-p - ) - -;;;(defmethod trcp ((c c-dependent)) -;;; (or (trcp-slot (c-model c) (c-slot-name c)) -;;; ;;(c-lazy-p c) -;;; nil)) - -(defmethod c-true-stalep ((c c-dependent)) - (cd-stale-p c)) - -(cc-defstruct (c-stream - (:include c-ruled) - (:conc-name cs-)) - values) - -;;; (defmacro cell~ (&body body) -;;; `(make-c-stream -;;; :rule (lambda ,@*c-lambda* -;;; ,@body))) - -(cc-defstruct (c-drifter - (:include c-dependent))) - -(cc-defstruct (c-drifter-absolute - (:include c-drifter))) - -;_____________________ accessors __________________________________ - - -(defun (setf c-state) (new-value c) - (if (typep c 'c-ruled) - (setf (cr-state c) new-value) - new-value)) - -(defun c-state (c) - (if (typep c 'c-ruled) - (cr-state c) - :valid)) - -(defun c-unboundp (c) - (eql :unbound (c-state c))) - -(defun c-validp (c) - (find (c-state c) '(:valid :optimized-away))) - -;_____________________ print __________________________________ - -(defmethod print-object :before ((c c-variable) stream) - (declare (ignorable c)) - (format stream "[var:")) - -(defmethod print-object :before ((c c-dependent) stream) - (declare (ignorable c)) - (format stream "[dep~a:" (cond - ((null (c-model c)) #\0) - ((eq :eternal-rest (md-state (c-model c))) #\_) - ((cd-stale-p c) #\#) - ((sw-pending c) #\?) - (t #\space)))) - -(defmethod print-object :before ((c c-independent) stream) - (declare (ignorable c)) - (format stream "[ind:")) - -(defmethod print-object ((c cell) stream) - (c-print-value c stream) - (format stream "=~a/~a]" - (symbol-name (or (c-slot-name c) :anoncell)) - (or (c-model c) :anonmd)) -;;; #+dfdbg (unless *stop* -;;; (assert (find c (cells (c-model c)) :key #'cdr))) - ) - -;__________________ - -(defmethod c-print-value ((c c-ruled) stream) - (format stream "~a" (cond ((unst-setting-p c) "<^^^>") - ((c-validp c) "<vld>") - ((c-unboundp c) "<unb>") - ((cd-stale-p c) "<obs>") - (t "<err>")))) - -(defmethod c-print-value (c stream) - (declare (ignore c stream))) - -;____________________ constructors _______________________________ - -(defmacro c-lambda (&body body) - (let ((c (gensym))) - `(lambda (,c &aux (self (c-model ,c)) - (.cache (c-value ,c))) - (declare (ignorable .cache self)) - (assert (not (cmdead ,c))() "cell dead entering rule ~a" ,c) - ,@body))) - -(defmacro c? (&body body) - `(make-c-dependent - :code ',body - :rule (c-lambda ,@body))) - -(defmacro c?_ (&body body) - `(make-c-dependent - :code ',body - :lazy t - :rule (c-lambda ,@body))) - -(defmacro c?? ((&key (tagp nil) (in nil) (trigger nil) (out t))&body body) - (let ((result (copy-symbol 'result)) - (thetag (gensym))) - `(make-c-dependent - :code ',body - :rule (c-lambda - (let ((,thetag (gensym "tag")) - (*trcdepth* (1+ *trcdepth*)) - ) - (declare (ignorable self ,thetag)) - ,(when in - `(trc "c??> entry" (c-slot-name c) (c-model c) (when ,tagp ,thetag))) - ,(when trigger `(trc "c??> trigger" *cause* c)) - (count-it :c?? (c-slot-name c) (md-name (c-model c))) - (let ((,result (progn ,@body))) - ,(when out `(trc "c?? result:" ,result (c-slot-name c) (when ,tagp ,thetag))) - ,result)))))) - -(defmacro cv (defn) - `(make-c-variable - :value ,defn)) ;; use c-independent if need deferred execution - -(defmacro cv8 (defn) - `(make-c-variable - :cyclic-p t - :value ,defn)) ;; use c-independent if need deferred execution - -(defmacro c... ((value) &body body) - `(make-c-drifter - :code ',body - :value ,value - :rule (c-lambda ,@body))) - -(defmacro c-abs (value &body body) - `(make-c-drifter-absolute - :code ',body - :value ,value - :rule (lambda (c &aux (self (c-model c))) - (declare (ignorable self c)) - ,@body))) - - -(defmacro c-envalue (&body body) - `(make-c-envaluer - :envaluerule (lambda (self) - (declare (ignorable self)) - ,@body))) - -(defmacro c8 ((&optional cyclic-value) &body body) - `(make-c-dependent - :code ',body - :cyclic-p t - :cyclic-value ,cyclic-value - :rule (c-lambda ,@body))) +;; -*- 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) + +(defun slot-spec-name (slot-spec) + slot-spec) + + +(defstruct (cell (:conc-name c-)) + waking-state + model + slot-spec + value + (users nil :type list)) + +(defun test () + (let (x) + (makunbound x) + x)) + +(defun c-slot-name (c) + (slot-spec-name (c-slot-spec c))) + +(defun c-validate (self c) + (when (not (and (c-slot-spec c) (c-model c))) + (format t "~&unadopted cell: ~s md:~s, awake:~s" c self (c-waking-state self)) + (c-break "unadopted cell ~a ~a" self c) + (error 'c-unadopted :cell c))) + +(defmethod c-when (other) + (declare (ignorable other)) nil) ;; /// needs work + +(defstruct (synapse + (:conc-name syn-)) + user + used + (relevant t) ;; not if unused during subsequent eval. but keep to preserve any state + fire-p + relay-value) + +(defmacro mksynapse ((&rest closeovervars) &key trcp fire-p relay-value) + (let ((used (copy-symbol 'used)) (user (copy-symbol 'user))) + `(lambda (,used ,user) + ,(when trcp + `(trc "making synapse between user" ',trcp ,user :and :used ,used)) + (let (,@closeovervars) + (make-synapse + :used ,used + :user ,user + :fire-p ,fire-p + :relay-value ,relay-value))))) + +(defmethod print-object ((syn synapse) stream) + (format stream "{syn ~s ==> ~s" (syn-used syn) (syn-user syn))) + +(defmethod c-true-stalep ((syn synapse)) + (cd-stale-p (syn-user syn))) + +(defstruct (c-variable + (:include cell) + (:conc-name cv-)) + cyclic-p + setting-p) + +(defstruct (c-ruled + (:include cell) + (:conc-name cr-)) + (state :unbound :type symbol) + (rethinking 0 :type number) + lazy + rule) + +(defmethod c-lazy-p ((c c-ruled)) (cr-lazy c)) +(defmethod c-lazy-p (c) (declare (ignore c)) nil) + +(defun c-optimized-away-p (c) + (eql :optimized-away (c-state c))) + +;---------------------------- + +(defmethod c-true-stalep (c) + (declare (ignore c))) + +(defmethod trcp-slot (self slot-name) + (declare (ignore self slot-name))) + +(defconstant *cd-usagect* 64) + +(defstruct (c-dependent + (:include c-ruled) + (:conc-name cd-)) + (useds nil :type list) + (code nil :type list) ;; /// feature this out on production build + (usage (make-array *cd-usagect* :element-type 'bit + :initial-element 0) :type vector) + stale-p + ) + +;;;(defmethod trcp ((c c-dependent)) +;;; (or (trcp-slot (c-model c) (c-slot-name c)) +;;; ;;(c-lazy-p c) +;;; nil)) + +(defmethod c-true-stalep ((c c-dependent)) + (cd-stale-p c)) + +(defstruct (c-stream + (:include c-ruled) + (:conc-name cs-)) + values) + +;;; (defmacro cell~ (&body body) +;;; `(make-c-stream +;;; :rule (lambda ,@*c-lambda* +;;; ,@body))) + +(defstruct (c-drifter + (:include c-dependent))) + +(defstruct (c-drifter-absolute + (:include c-drifter))) + +;_____________________ accessors __________________________________ + + +(defun (setf c-state) (new-value c) + (if (typep c 'c-ruled) + (setf (cr-state c) new-value) + new-value)) + +(defun c-state (c) + (if (typep c 'c-ruled) + (cr-state c) + :valid)) + +(defun c-unboundp (c) + (eql :unbound (c-state c))) + +(defun c-validp (c) + (find (c-state c) '(:valid :optimized-away))) + +;_____________________ print __________________________________ + +(defmethod print-object :before ((c c-variable) stream) + (declare (ignorable c)) + (format stream "[var:")) + +(defmethod print-object :before ((c c-dependent) stream) + (declare (ignorable c)) + (format stream "[dep~a:" (cond + ((null (c-model c)) #\0) + ((eq :eternal-rest (md-state (c-model c))) #\_) + ((cd-stale-p c) #\#) + ((sw-pending c) #\?) + (t #\space)))) + +(defmethod print-object ((c cell) stream) + (c-print-value c stream) + (format stream "=~a/~a]" + (symbol-name (or (c-slot-name c) :anoncell)) + (or (c-model c) :anonmd))) + +;__________________ + +(defmethod c-print-value ((c c-ruled) stream) + (format stream "~a" (cond ((c-validp c) "<vld>") + ((c-unboundp c) "<unb>") + ((cd-stale-p c) "<obs>") + (t "<err>")))) + +(defmethod c-print-value (c stream) + (declare (ignore c stream))) + +;____________________ constructors _______________________________ + +(defmacro c-lambda (&body body) + (let ((c (gensym))) + `(lambda (,c &aux (self (c-model ,c)) + (.cache (c-value ,c))) + (declare (ignorable .cache self)) + (c-assert (not (cmdead ,c)) "cell dead entering rule ~a" ,c) + ,@body))) + +(defmacro c? (&body body) + `(make-c-dependent + :code ',body + :rule (c-lambda ,@body))) + +(defmacro c?_ (&body body) + `(make-c-dependent + :code ',body + :lazy t + :rule (c-lambda ,@body))) + +(defmacro c?? ((&key (tagp nil) (in nil) (trigger nil) (out t))&body body) + (let ((result (copy-symbol 'result)) + (thetag (gensym))) + `(make-c-dependent + :code ',body + :rule (c-lambda + (let ((,thetag (gensym "tag")) + (*trcdepth* (1+ *trcdepth*)) + ) + (declare (ignorable self ,thetag)) + ,(when in + `(trc "c??> entry" (c-slot-name c) (c-model c) (when ,tagp ,thetag))) + ,(when trigger `(trc "c??> trigger" *cause* c)) + (count-it :c?? (c-slot-name c) (md-name (c-model c))) + (let ((,result (progn ,@body))) + ,(when out `(trc "c?? result:" ,result (c-slot-name c) (when ,tagp ,thetag))) + ,result)))))) + +(defmacro cv (defn) + `(make-c-variable + :value ,defn)) + +(defmacro cv8 (defn) + `(make-c-variable + :cyclic-p t + :value ,defn)) + +(defmacro c... ((value) &body body) + `(make-c-drifter + :code ',body + :value ,value + :rule (c-lambda ,@body))) + +(defmacro c-abs (value &body body) + `(make-c-drifter-absolute + :code ',body + :value ,value + :rule (c-lambda ,@body))) + + +(defmacro c-envalue (&body body) + `(make-c-envaluer + :envaluerule (c-lambda ,@body))) Index: cells/cells.asd diff -u cells/cells.asd:1.1.1.1 cells/cells.asd:1.2 --- cells/cells.asd:1.1.1.1 Sat Nov 8 18:43:48 2003 +++ cells/cells.asd Tue Dec 16 10:02:58 2003 @@ -1,36 +1,36 @@ -;;;; -*- 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 - :name "cells" - :author "Kenny Tilton <ktilton(a)nyc.rr.com>" - :version "05-Nov-2003" - :maintainer "Kenny Tilton <ktilton(a)nyc.rr.com>" - :licence "MIT Style" - :description "Cells" - :long-description "The Cells dataflow extension to CLOS." - :components - ((:file "cells") - (:file "flow-control" :depends-on ("cells")) - (:file "strings" :depends-on ("flow-control")) - (:file "detritus" :depends-on ("flow-control")) - (:file "cell-types" :depends-on ("cells")) - (:file "debug" :depends-on ("cells")) - (:file "initialize" :depends-on ("debug")) - (:file "dataflow-management" :depends-on ("debug")) - (:file "md-slot-value" :depends-on ("debug")) - (:file "calc-n-set" :depends-on ("debug")) - (:file "slot-utilities" :depends-on ("debug")) - (:file "optimization" :depends-on ("debug")) - (:file "link" :depends-on ("debug")) - (:file "propagate" :depends-on ("debug")) - (:file "synapse" :depends-on ("debug" "cell-types")) - (:file "model-object" :depends-on ("debug")) - (:file "defmodel" :depends-on ("model-object")) - (:file "md-utilities" :depends-on ("defmodel")) - (:file "family" :depends-on ("propagate" "model-object" "defmodel")) - (:file "fm-utilities" :depends-on ("family")) - (:file "family-values" :depends-on ("fm-utilities")))) +;;;; -*- 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 cormanlisp sbcl scl) + +(asdf:defsystem :cells + :name "cells" + :author "Kenny Tilton <ktilton(a)nyc.rr.com>" + :version "05-Nov-2003" + :maintainer "Kenny Tilton <ktilton(a)nyc.rr.com>" + :licence "MIT Style" + :description "Cells" + :long-description "The Cells dataflow extension to CLOS." + :components + ((:file "cells") + (:file "flow-control" :depends-on ("cells")) + (:file "strings" :depends-on ("flow-control")) + (:file "detritus" :depends-on ("flow-control")) + (:file "cell-types" :depends-on ("cells")) + (:file "debug" :depends-on ("cells")) + (:file "initialize" :depends-on ("debug")) + (:file "dataflow-management" :depends-on ("debug")) + (:file "md-slot-value" :depends-on ("debug")) + (:file "calc-n-set" :depends-on ("debug")) + (:file "slot-utilities" :depends-on ("debug")) + (:file "optimization" :depends-on ("debug")) + (:file "link" :depends-on ("debug")) + (:file "propagate" :depends-on ("debug")) + (:file "synapse" :depends-on ("debug" "cell-types")) + (:file "model-object" :depends-on ("debug")) + (:file "defmodel" :depends-on ("model-object")) + (:file "md-utilities" :depends-on ("defmodel")) + (:file "family" :depends-on ("propagate" "model-object" "defmodel")) + (:file "fm-utilities" :depends-on ("family")) + (:file "family-values" :depends-on ("fm-utilities")))) Index: cells/cells.lisp diff -u cells/cells.lisp:1.2 cells/cells.lisp:1.3 --- cells/cells.lisp:1.2 Thu Nov 13 00:54:53 2003 +++ cells/cells.lisp Tue Dec 16 10:02:58 2003 @@ -1,111 +1,128 @@ -;; -*- 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. - -(eval-when (compile load) - (proclaim '(optimize (speed 2) (safety 1) (space 1) (debug 3)))) - -(defpackage :cells - (:use "COMMON-LISP" - #+allegro "EXCL" - #-(or cormanlisp cmu sbcl) "CLOS" - #+sbcl "SB-MOP" - #+mcl "CCL" - ) - #+clisp (:import-from #:clos "CLASS-SLOTS" "CLASS-PRECEDENCE-LIST") - #+cmu (:import-from "PCL" "CLASS-PRECEDENCE-LIST" "CLASS-SLOTS" - "SLOT-DEFINITION-NAME") - (:export "CELL" "CV" "C?" "C?_" "C??" "WITHOUT-C-DEPENDENCY" "SELF" "*SYNAPSE-FACTORY*" - ".CACHE" "C-LAMBDA" ".CAUSE" - "DEFMODEL" "CELLBRK" "C-AWAKEN" "DEF-C-ECHO" "DEF-C-UNCHANGED-TEST" - "NEW-VALUE" "OLD-VALUE" "C..." - "MKPART" "THEKIDS" "NSIB" "MDVALUE" "^MDVALUE" ".MDVALUE" "KIDS" "^KIDS" ".KIDS" - "CELL-RESET" "UPPER" "FM-MAX" "NEAREST" "^FM-MIN-KID" "^FM-MAX-KID" "MK-KID-SLOT" - "DEF-KID-SLOTS" "FIND-PRIOR" "FM-POS" "KIDNO" "FM-INCLUDES" "FM-ASCENDANT-COMMON" - "FM-KID-CONTAINING" "FM-FIND-IF" "FM-ASCENDANT-IF" "C-ABS" "FM-COLLECT-IF" "CV8" "PSIB" - "TO-BE" "NOT-TO-BE" "SSIBNO" "MD-AWAKEN" - #:delta-diff - ) - #+allegro (:shadowing-import-from #:excl #:fasl-write #:fasl-read #:gc) - ) - -(in-package :cells) - -(defconstant *c-optimizep* t) -(defvar *c-prop-depth* 0) -(defvar *cause* nil) -(defvar *rethink-deferred* nil) -(defvar *synapse-factory* nil) -(defvar *sw-looping* nil) -(defparameter *to-be-awakened* nil) -(defvar *trcdepth* 0) - -(defparameter *c-debug* - #+runtime-system nil - #-runtime-system t) - -(defvar *stop* nil) - -(defun stop () - (setf *stop* t)) - -(defvar *c-calculators* nil) - -(defmacro ssibno () `(position self (^kids .parent))) - -(defmacro gpar () - `(fm-grandparent self)) - -(defmacro nearest (selfform type) - (let ((self (gensym))) - `(bwhen (,self ,selfform) - (if (typep ,self ',type) ,self (upper ,self ,type))))) - -(defmacro def-c-trace (model-type &optional slot cell-type) - `(defmethod trcp ((self ,(case cell-type - (:c? 'c-dependent) - (otherwise 'cell)))) - (and (typep (c-model self) ',model-type) - ,(if slot - `(eq (c-slot-name self) ',slot) - `t)))) - -(defmacro with-dataflow-management ((c-originating) &body body) - (let ((fn (gensym))) - `(let ((,fn (lambda () ,@body))) - (declare (dynamic-extent ,fn)) - (call-with-dataflow-management ,c-originating ,fn)))) - -(defmacro without-c-dependency (&body body) - `(let (*c-calculators*) ,@body)) - -(defmacro without-propagating ((slotname objxpr) &body body) - (let ((c (gensym)) - (c-delta (gensym))) - `(let ((,c (slot-value ,objxpr ',slotname))) - (push (cons ,c nil) *c-noprop*) - (progn ,@body) - (let ((,c-delta (assoc ,c *c-noprop*))) - (assert ,c-delta) - (setf *c-noprop* (delete ,c-delta *c-noprop*)) - (when (cdr ,c-delta) ;; if changed, will be set to /list/ containing priorvalue - (,c (cadr ,c-delta) (caddr ,c-delta))))))) - +;; -*- 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. + +(eval-when (compile load) + (proclaim '(optimize (speed 2) (safety 3) (space 1) (debug 3)))) + +(defpackage :cells + (:use "COMMON-LISP" + #+allegro "EXCL" + #-(or cormanlisp cmu sbcl) "CLOS" + #+sbcl "SB-MOP" + #+mcl "CCL" + ) + #+clisp (:import-from #:clos "CLASS-SLOTS" "CLASS-PRECEDENCE-LIST") + #+cmu (:import-from "PCL" "CLASS-PRECEDENCE-LIST" "CLASS-SLOTS" + "SLOT-DEFINITION-NAME" "TRUE") + (:export "CELL" "CV" "C?" "C?_" "C??" "WITHOUT-C-DEPENDENCY" "SELF" "*SYNAPSE-FACTORY*" + ".CACHE" "C-LAMBDA" ".CAUSE" + "DEFMODEL" "CELLBRK" "C-AWAKEN" "DEF-C-ECHO" "DEF-C-UNCHANGED-TEST" + "NEW-VALUE" "OLD-VALUE" "C..." + "MKPART" "THEKIDS" "NSIB" "MD-VALUE" "^MD-VALUE" ".MD-VALUE" "KIDS" "^KIDS" ".KIDS" + "CELL-RESET" "UPPER" "FM-MAX" "NEAREST" "^FM-MIN-KID" "^FM-MAX-KID" "MK-KID-SLOT" + "DEF-KID-SLOTS" "FIND-PRIOR" "FM-POS" "KID-NO" "FM-INCLUDES" "FM-ASCENDANT-COMMON" + "FM-KID-CONTAINING" "FM-FIND-IF" "FM-ASCENDANT-IF" "C-ABS" "FM-COLLECT-IF" "CV8" "PSIB" + "TO-BE" "NOT-TO-BE" "SSIBNO" "MD-AWAKEN" + "C-BREAK" "C-ASSERT" "C-STOP" "C-STOPPED" "C-ASSERT" + #:delta-diff + ) + #+allegro (:shadowing-import-from #:excl #:fasl-write #:fasl-read #:gc) + ) + +(in-package :cells) + +(defconstant *c-optimizep* t) +(defvar *c-prop-depth* 0) +(defvar *cause* nil) +(defvar *rethink-deferred* nil) +(defvar *synapse-factory* nil) +(defvar *sw-looping* nil) +(defparameter *to-be-awakened* nil) +(defvar *trcdepth* 0) + +(defparameter *c-debug* + #+runtime-system nil + #-runtime-system t) + +(defvar *stop* nil) + +(defun c-stop (why) + (format t "~&C-STOP> stopping because ~a" why) + (setf *stop* t)) + +(defun c-stopped () + *stop*) + +(defmacro c-assert (assertion &optional places fmt$ &rest fmtargs) + (declare (ignore places)) + + `(unless *stop* + (unless ,assertion + (setf *stop* t) + ,(if fmt$ + `(c-break ,fmt$ ,@fmtargs) + `(c-break "failed assertion:" ',assertion))))) + +(defvar *c-calculators* nil) + +(defmacro ssibno () `(position self (^kids .parent))) + +(defmacro gpar () + `(fm-grandparent self)) + +(defmacro nearest (selfform type) + (let ((self (gensym))) + `(bwhen (,self ,selfform) + (if (typep ,self ',type) ,self (upper ,self ,type))))) + +(defmacro def-c-trace (model-type &optional slot cell-type) + `(defmethod trcp ((self ,(case cell-type + (:c? 'c-dependent) + (otherwise 'cell)))) + (and (typep (c-model self) ',model-type) + ,(if slot + `(eq (c-slot-name self) ',slot) + `t)))) + +(defmacro with-dataflow-management ((c-originating) &body body) + (let ((fn (gensym))) + `(let ((,fn (lambda () ,@body))) + (declare (dynamic-extent ,fn)) + (call-with-dataflow-management ,c-originating ,fn)))) + +(defmacro without-c-dependency (&body body) + `(let (*c-calculators*) ,@body)) + +(defmacro without-propagating ((slotname objxpr) &body body) + (let ((c (gensym)) + (c-delta (gensym))) + `(let ((,c (slot-value ,objxpr ',slotname))) + (push (cons ,c nil) *c-noprop*) + (progn ,@body) + (let ((,c-delta (assoc ,c *c-noprop*))) + (c-assert ,c-delta) + (setf *c-noprop* (delete ,c-delta *c-noprop*)) + (when (cdr ,c-delta) ;; if changed, will be set to /list/ containing priorvalue + (,c (cadr ,c-delta) (caddr ,c-delta))))))) + +(define-symbol-macro .cause + *cause*) Index: cells/dataflow-management.lisp diff -u cells/dataflow-management.lisp:1.1.1.1 cells/dataflow-management.lisp:1.2 --- cells/dataflow-management.lisp:1.1.1.1 Sat Nov 8 18:44:00 2003 +++ cells/dataflow-management.lisp Tue Dec 16 10:02:58 2003 @@ -1,223 +1,229 @@ -;; -*- 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) - -(defparameter *df-interference-detection* t) - -(eval-when (compile eval load) - (export '(*df-interference-detection*))) - -(defmethod sw-detect-interference (user trigger) - (declare (ignorable trigger)) - (when #+runtime-system t #-runtime-system *df-interference-detection* - (trc nil "detect entry" user (cd-useds user)) - (dolist (used (cd-useds user)) - (do ((deep-stale (cd-deep-stale used)(cd-deep-stale used))) - ((null deep-stale)) - ;;(trc nil "sw-detect-interference trying deep stale" deep-stale) - (c-rethink deep-stale) - (cond - ((c-true-stalep deep-stale) - (trc "!! true deep stalep: user>" user) - (trc "!! true deep stalep: used>" used) - (trc "!! true deep stalep: deepstale>" deep-stale) - (return-from sw-detect-interference deep-stale #+debugging (list user used deep-stale))) - - ((not (c-true-stalep user)) - (return-from sw-detect-interference nil))))))) - -(defmethod sw-detect-interference ((user c-variable) trigger) - (declare (ignore trigger))) - -(defmethod sw-detect-interference ((user synapse) trigger) - (sw-detect-interference (syn-used user) trigger)) - -(defmethod cd-deep-stale ((c c-dependent)) - (trc nil "cd-deep-stale entry" c) - (if (cd-stale-p c) - c ;; (eko ("deep stalep bingo !!!!!!") c) - (some #'cd-deep-stale (cd-useds c)))) - -(defmethod cd-deep-stale ((syn synapse)) - (cd-deep-stale (syn-used syn))) - -(defmethod cd-deep-stale (c) - (declare (ignore c))) - -(defparameter *sw-pending* nil) -(defparameter *dataflowing* nil) - -(defun dump-pending () - (dotimes (x (length *sw-pending*)) - (let ((p (nth x *sw-pending*))) - (destructuring-bind (heldup . holdup) p - (declare (ignorable holdup)) - (trc heldup " pending!!!!!!!!!!" p) - ))) - ) - -;; mo better diags: holdup (c-true-stalep holdup) heldup (c-true-stalep heldup)))))) - -(defun call-with-dataflow-management (c-originating bodyfn) - (declare (ignorable c-originating)) - (if *dataflowing* - (funcall bodyfn) - (let ((*dataflowing* t) - *sw-pending*) - #+dfdbg (trc nil ">>>>> with-dataflow-management: 001" c-originating) - (setf (unst-setting-p c-originating) t) - (prog1 - (funcall bodyfn) - - (while (and *sw-pending* - (not *sw-looping*)) - - #+dfdbg - (progn - (trc nil "we have pending!!!!!!!!!!" (length *sw-pending*)) - (dump-pending)) - - (let ((pct (length *sw-pending*)) - (oldpending (copy-list *sw-pending*))) - ;;(trace c-rethink) - (labels ((do-last (pending) - (when pending - (do-last (cdr pending)) - ;;(trace c-rethink cd-deep-stale sw-detect-interference) - (destructuring-bind (heldup . holdup) (car pending) - (trc heldup "pending sweep sees held up" heldup :holdup holdup) - (assert (find heldup (cells (c-model heldup)) :key #'cdr)) - (assert (find holdup (cells (c-model holdup)) :key #'cdr)) - ;; (unless (c-true-stalep holdup) - ;; (trc nil "dataflow sees freed blocker" holdup)) - (if (c-true-stalep holdup) - (if (eq :eternal-rest (md-state (c-model holdup))) - (progn (trc "holdup is no more!!!!!!!" holdup (c-true-stalep heldup) heldup)) - (progn - (trc holdup "dataflow retrying blocker" holdup) - (c-rethink holdup))) - (progn - (trc heldup "holdup not stale!!!" holdup :heldup> heldup) - (c-pending-set heldup nil :holdup-unstale) )) - ;;(unless (c-true-stalep heldup) - ;; (trc nil "dataflow sees freed blocked" heldup)) - (when (c-true-stalep heldup) - (trc heldup "dataflow retrying blocked" heldup) - (c-rethink heldup)))))) - ;; (trace c-rethink cd-deep-stale sw-detect-interference) - (do-last *sw-pending*) - ;; (trc "post sweep pending leftovers:" (length *sw-pending*)) - ;; (untrace c-rethink cd-deep-stale sw-detect-interference) - ) - ;;(untrace c-rethink) - (when (and (equal oldpending *sw-pending*) - (eql pct (length *sw-pending*)) - (not *sw-looping*)) - (setf *sw-looping* t) - #+nah (dolist (p *sw-pending*) - (destructuring-bind (heldup . holdup) p - (dump-dependency-path holdup heldup))) - #+nah (dolist (p *sw-pending*) - (destructuring-bind (heldup . holdup) p - (declare (ignorable heldup)) - (when t ;; (trcp holdup) - (dump-stale-path holdup)))) - (break "trigger ~a stuck; cant lose pendings ~a" - c-originating - *sw-pending*)) - - ;; (trc "after sweep sw-pending" *sw-pending*) - ;; (cellbrk) - (when c-originating - (setf (unst-setting-p c-originating) nil)))) - (trc nil "<<<< with-dataflow-management:" c-originating))))) - -(defun dump-stale-path (used) - (assert used) - (when (typep used 'c-dependent) - (loop with any - for used-used in (cd-useds used) - when (dump-stale-path used-used) - do (progn - (setf any t) - (trc "stale-path" used :uses... used-used)) - finally - (when (or any (cd-stale-p used)) - (trc "stale" used) - (return any))))) - -(defun dump-dependency-path (used user) - (assert (and used user)) - (if (eql used user) - (progn - (trc "bingo---------------") - (trc "user" user :uses...) - t) - (let (any) - (dolist (used-user (cd-users used) any) - (when (dump-dependency-path used-user user) - (setf any t) - (trc "user" used-user :uses... used)))))) - -(defun c-pending-set (c newvalue debug-tag) - (declare (ignorable debug-tag)) - (assert (find c (cells (c-model c)) :key #'cdr)) - (when newvalue (trc nil "still pending!!!!!!!!!!!!!!!!!!" c newvalue debug-tag)) - (if newvalue - (bif (known (assoc c *sw-pending*)) - (cond - ((eq newvalue (cdr known)) - (break "hunh? re-pending ~a on same holdup ~a?" c (cdr known))) - ((c-true-stalep (cdr known)) - (break "hunh? pending ~a on second holdup ~a as well as ~a?" c newvalue (cdr known))) - (t - (trc nil "re-pending ~a on new holdup ~a, last ok: ~a" c newvalue (assoc c *sw-pending*)) - (rplacd known newvalue))) ;; risky business, might need whole new assoc entry - (let ((newpending (cons c newvalue))) - (progn - (assert (typep c 'c-dependent)) - (assert (not (eq :eternal-rest (md-state (c-model c))))) - ;;(trc nil "pending on, genealogy holdup: held, holder:" debug-tag c newvalue) - ;;(dump-pending) - ) - ;;; hunh?> (pushnew newpending *sw-pending* :test #'equal) - (push newpending *sw-pending*))) - (bwhen (p (assoc c *sw-pending*)) - (trc nil "clear from sw-pending" debug-tag c (remove-if (lambda (p) - (not (eql c (car p)))) - *sw-pending*)) - (setf *sw-pending* (delete (assoc c *sw-pending*) *sw-pending*)) - (progn - (trc nil "pending off, genealogy holdup: held, holder:" debug-tag p - (count c *sw-pending* :key #'car)) - (dump-pending)) - )) - newvalue) - -(defmethod sw-pending ((c cell)) - (assoc c *sw-pending*)) - -(defmethod sw-pending ((s synapse)) - (sw-pending (syn-used s))) - - +;; -*- 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) + +(defparameter *df-interference-detection* t) + +(eval-when (compile eval load) + (export '(*df-interference-detection*))) + +(defmethod sw-detect-interference (user trigger) + (declare (ignorable trigger)) + (when #+runtime-system t #-runtime-system *df-interference-detection* + (trc nil "detect entry" user (cd-useds user)) + (dolist (used (cd-useds user)) + (do ((deep-stale (cd-deep-stale used)(cd-deep-stale used))) + ((null deep-stale)) + ;;(trc nil "sw-detect-interference trying deep stale" deep-stale) + (c-rethink deep-stale) + (cond + ((c-true-stalep deep-stale) + (trc "!! true deep stalep: user>" user) + (trc "!! true deep stalep: used>" used) + (trc "!! true deep stalep: deepstale>" deep-stale) + (return-from sw-detect-interference deep-stale #+debugging (list user used deep-stale))) + + ((not (c-true-stalep user)) + (return-from sw-detect-interference nil))))))) + +(defmethod sw-detect-interference ((user c-variable) trigger) + (declare (ignore trigger))) + +(defmethod sw-detect-interference ((user synapse) trigger) + (sw-detect-interference (syn-used user) trigger)) + +(defmethod cd-deep-stale ((c c-dependent)) + (trc nil "cd-deep-stale entry" c) + (if (cd-stale-p c) + c ;; (eko ("deep stalep bingo !!!!!!") c) + (some #'cd-deep-stale (cd-useds c)))) + +(defmethod cd-deep-stale ((syn synapse)) + (cd-deep-stale (syn-used syn))) + +(defmethod cd-deep-stale (c) + (declare (ignore c))) + +(defparameter *sw-pending* nil) +(defparameter *dataflowing* nil) + +(defun dump-pending () + (dotimes (x (length *sw-pending*)) + (let ((p (nth x *sw-pending*))) + (destructuring-bind (heldup . holdup) p + (declare (ignorable holdup)) + (trc heldup " pending!!!!!!!!!!" p) + ))) + ) + +;; mo better diags: holdup (c-true-stalep holdup) heldup (c-true-stalep heldup)))))) + +(defun call-with-dataflow-management (c-originating bodyfn) + (declare (ignorable c-originating)) + (if *dataflowing* + (progn + (setf (cv-setting-p c-originating) t) + (prog1 + (funcall bodyfn) + (setf (cv-setting-p c-originating) nil))) + + (let ((*dataflowing* t) + *sw-pending*) + #+dfdbg (trc nil ">>>>> with-dataflow-management: 001" c-originating) + (setf (cv-setting-p c-originating) t) + (prog1 + (funcall bodyfn) + + (while (and *sw-pending* + (not *sw-looping*)) + + #+dfdbg + (progn + (trc nil "we have pending!!!!!!!!!!" (length *sw-pending*)) + (dump-pending)) + + (let ((pct (length *sw-pending*)) + (oldpending (copy-list *sw-pending*))) + ;;(trace c-rethink) + (labels ((do-last (pending) + (when pending + (do-last (cdr pending)) + ;;(trace c-rethink cd-deep-stale sw-detect-interference) + (destructuring-bind (heldup . holdup) (car pending) + (trc heldup "pending sweep sees held up" heldup :holdup holdup) + (c-assert (find heldup (cells (c-model heldup)) :key #'cdr)) + (c-assert (find holdup (cells (c-model holdup)) :key #'cdr)) + ;; (unless (c-true-stalep holdup) + ;; (trc nil "dataflow sees freed blocker" holdup)) + (if (c-true-stalep holdup) + (if (eq :eternal-rest (md-state (c-model holdup))) + (progn (trc "holdup is no more!!!!!!!" holdup (c-true-stalep heldup) heldup)) + (progn + (trc holdup "dataflow retrying blocker" holdup) + (c-rethink holdup))) + (progn + (trc heldup "holdup not stale!!!" holdup :heldup> heldup) + (c-pending-set heldup nil :holdup-unstale) )) + ;;(unless (c-true-stalep heldup) + ;; (trc nil "dataflow sees freed blocked" heldup)) + (when (c-true-stalep heldup) + (trc heldup "dataflow retrying blocked" heldup) + (c-rethink heldup)))))) + ;; (trace c-rethink cd-deep-stale sw-detect-interference) + (do-last *sw-pending*) + ;; (trc "post sweep pending leftovers:" (length *sw-pending*)) + ;; (untrace c-rethink cd-deep-stale sw-detect-interference) + ) + ;;(untrace c-rethink) + (when (and (equal oldpending *sw-pending*) + (eql pct (length *sw-pending*)) + (not *sw-looping*)) + (setf *sw-looping* t) + #+nah (dolist (p *sw-pending*) + (destructuring-bind (heldup . holdup) p + (dump-dependency-path holdup heldup))) + #+nah (dolist (p *sw-pending*) + (destructuring-bind (heldup . holdup) p + (declare (ignorable heldup)) + (when t ;; (trcp holdup) + (dump-stale-path holdup)))) + (break "trigger ~a stuck; cant lose pendings ~a" + c-originating + *sw-pending*)) + + ;; (trc "after sweep sw-pending" *sw-pending*) + ;; (cellbrk) + )) + (when c-originating + (setf (cv-setting-p c-originating) nil)) + (trc nil "<<<< with-dataflow-management:" c-originating))))) + +(defun dump-stale-path (used) + (c-assert used) + (when (typep used 'c-dependent) + (loop with any + for used-used in (cd-useds used) + when (dump-stale-path used-used) + do (progn + (setf any t) + (trc "stale-path" used :uses... used-used)) + finally + (when (or any (cd-stale-p used)) + (trc "stale" used) + (return any))))) + +(defun dump-dependency-path (used user) + (c-assert (and used user)) + (if (eql used user) + (progn + (trc "bingo---------------") + (trc "user" user :uses...) + t) + (let (any) + (dolist (used-user (cd-users used) any) + (when (dump-dependency-path used-user user) + (setf any t) + (trc "user" used-user :uses... used)))))) + +(defun c-pending-set (c newvalue debug-tag) + (declare (ignorable debug-tag)) + (c-assert (find c (cells (c-model c)) :key #'cdr)) + (when newvalue (trc nil "still pending!!!!!!!!!!!!!!!!!!" c newvalue debug-tag)) + (if newvalue + (bif (known (assoc c *sw-pending*)) + (cond + ((eq newvalue (cdr known)) + (break "hunh? re-pending ~a on same holdup ~a?" c (cdr known))) + ((c-true-stalep (cdr known)) + (break "hunh? pending ~a on second holdup ~a as well as ~a?" c newvalue (cdr known))) + (t + (trc nil "re-pending ~a on new holdup ~a, last ok: ~a" c newvalue (assoc c *sw-pending*)) + (rplacd known newvalue))) ;; risky business, might need whole new assoc entry + (let ((newpending (cons c newvalue))) + (progn + (c-assert (typep c 'c-dependent)) + (c-assert (not (eq :eternal-rest (md-state (c-model c))))) + ;;(trc nil "pending on, genealogy holdup: held, holder:" debug-tag c newvalue) + ;;(dump-pending) + ) + ;;; hunh?> (pushnew newpending *sw-pending* :test #'equal) + (push newpending *sw-pending*))) + (bwhen (p (assoc c *sw-pending*)) + (trc nil "clear from sw-pending" debug-tag c (remove-if (lambda (p) + (not (eql c (car p)))) + *sw-pending*)) + (setf *sw-pending* (delete (assoc c *sw-pending*) *sw-pending*)) + (progn + (trc nil "pending off, genealogy holdup: held, holder:" debug-tag p + (count c *sw-pending* :key #'car)) + (dump-pending)) + )) + newvalue) + +(defmethod sw-pending ((c cell)) + (assoc c *sw-pending*)) + +(defmethod sw-pending ((s synapse)) + (sw-pending (syn-used s))) + + Index: cells/debug.lisp diff -u cells/debug.lisp:1.1.1.1 cells/debug.lisp:1.2 --- cells/debug.lisp:1.1.1.1 Sat Nov 8 18:44:00 2003 +++ cells/debug.lisp Tue Dec 16 10:02:58 2003 @@ -1,268 +1,263 @@ -;; -*- 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) - -(defun cellstop () - ;; (break "in-cell-stop") - (setf *stop* t)) - -(defun cellbrk (&optional (tag :anon)) - (unless (or *stop*) - ;; daring move, hoping having handler at outside stops the game (cellstop) - (print `(cell break , tag)) - (break))) - -;----------- trc ------------------------------------------- - -(defun trcdepth-reset () - (setf *trcdepth* 0)) - -(defmacro trc (tgtform &rest os) - (if (eql tgtform 'nil) - '(progn) - (if (stringp tgtform) - `(without-c-dependency - (call-trc t ,tgtform ,@os)) - (let ((tgt (gensym))) - `(without-c-dependency - (bif (,tgt ,tgtform) - (if (trcp ,tgt) - (progn - (assert (stringp ,(car os))) - (call-trc t ,@os)) ;;,(car os) ,tgt ,@(cdr os))) - (progn - (break) - (count-it :trcfailed))) - (count-it :tgtnileval))))))) - -(defun call-trc (stream s &rest os) - (if #+cormanlisp nil #-cormanlisp (and (boundp '*trcdepth*) - *trcdepth*) - (format stream "~&~v,,,'.<~d~>> " (mod *trcdepth* 100) *trcdepth*) - (format stream "~&")) - - (format stream "~a" s) - (let (pkwp) - (dolist (o os) - (format stream (if pkwp " ~s" " | ~s") o) - (setf pkwp (keywordp o)))) - (values)) - -(defun call-trc-to-string (fmt$ &rest fmtargs) - (let ((o$ (make-array '(0) :element-type 'base-char - :fill-pointer 0 :adjustable t))) - (with-output-to-string (ostream o$) - (apply 'call-trc ostream fmt$ fmtargs)) - o$)) - -#+findtrcevalnils -(defmethod trcp :around (other) - (unless (call-next-method other)(break))) - -(defmethod trcp (other) - (eq other t)) - -(defmethod trcp (($ string)) - t) - -(defun trcdepth-incf () - (incf *trcdepth*)) - -(defun trcdepth-decf () - (format t "decrementing trc depth" *trcdepth*) - (decf *trcdepth*)) - -(defmacro wtrc ((&optional (min 1) (max 50) &rest banner) &body body ) - `(let ((*trcdepth* (if *trcdepth* - (1+ *trcdepth*) - 0))) - ,(when banner `(when (>= *trcdepth* ,min) - (if (< *trcdepth* ,max) - (trc ,@banner) - (progn - (break "excess trace notttt!!! ~d" *trcdepth*) ;; ,@banner) - nil)))) - (when (< *trcdepth* ,max) - ,@body))) - -(defmacro wnotrc ((&optional (min 1) (max 50) &rest banner) &body body ) - (declare (ignore min max banner)) - `(progn ,@body)) - -;------ eko -------------------------------------- - - -(defmacro eko ((&rest trcargs) &rest body) - (let ((result (gensym))) - `(let ((,result ,@body)) - (trc ,(car trcargs) :=> ,result ,@(cdr trcargs)) - ,result))) - -(defmacro ek (label &rest body) - (let ((result (gensym))) - `(let ((,result (,@body))) - (when ,label - (trc ,label ,result)) - ,result))) - -;------------- counting --------------------------- -(defvar *count* nil) -(defvar *counting* nil) - -(defmacro with-counts ((onp &rest msg) &body body) - `(if ,onp - (prog2 - (progn - (count-clear ,@msg) - (push t *counting*)) - (progn ,@body) - (pop *counting*) - (show-count t ,@msg)) - (progn ,@body))) - -(defun count-clear (&rest msg) - (declare (ignorable msg)) - (format t "~&count-clear > ~a" msg) - (setf *count* nil)) - -(defmacro count-it (&rest keys) - `(when *counting* - (call-count-it ,@keys))) - -(defun call-count-it (&rest keys) - (declare (ignorable keys)) - ;;; (when (eql :TGTNILEVAL (car keys))(break)) - (let ((entry (assoc keys *count* :test #'equal))) - (if entry - (setf (cdr entry) (1+ (cdr entry))) - (push (cons keys 1) *count*)))) - -(defun show-count (clearp &rest msg) - (format t "~&Counts after: clearp ~a, length ~d: ~s" clearp (length *count*) msg) - (let ((res (sort (copy-list *count*) (lambda (v1 v2) - (let ((v1$ (symbol-name (caar v1))) - (v2$ (symbol-name (caar v2)))) - (if (string= v1$ v2$) - (< (cdr v1) (cdr v2)) - (string< v1$ v2$)))))) - ) - (loop for entry in res - for occs = (cdr entry) - when (plusp occs) - sum occs into running - and do (format t "~&~4d ... ~2d ... ~s" running occs (car entry)))) - (when clearp (count-clear "show-count"))) - -#+test -(loop for entry in '((a . 10)(b . 5)(c . 0)(e . -20)(d . 2)) - for occs = (cdr entry) - when (plusp occs) - sum occs into running - and do (print (list entry occs running))) - - -;-------------------- timex --------------------------------- - -;;;(defmacro timex ((onp &rest trcArgs) &body body) -;;; `(if ,onp -;;; (prog1 -;;; (time -;;; (progn ,@body)) -;;; (trc "timing was of" ,@trcARgs)) -;;; (progn ,@body))) - - -;---------------- Metrics ------------------- - -(defmacro with-metrics ((countp timep &rest trcargs) &body body) - `(with-counts (,countp ,@trcargs) - (timex (,timep ,@trcargs) - ,@body))) - - -; -------- cell conditions (not much used) --------------------------------------------- - -(define-condition xcell () ;; new 2k0227 - ((cell :initarg :cell :reader cell :initform nil) - (appfunc :initarg :appfunc :reader appfunc :initform 'badcell) - (errortext :initarg :errortext :reader errortext :initform "<???>") - (otherdata :initarg :otherdata :reader otherdata :initform "<nootherdata>")) - (:report (lambda (c s) - (format s "~& trouble with cell ~a in function ~s,~s: ~s" - (cell c) (appfunc c) (errortext c) (otherdata c))))) - -(define-condition c-enabling () - ((name :initarg :name :reader name) - (model :initarg :model :reader model) - (cell :initarg :cell :reader cell)) - (:report (lambda (condition stream) - (format stream "~&unhandled <c-enabling>: ~s" condition) - (break "~&i say, unhandled <c-enabling>: ~s" condition)))) - -(define-condition c-fatal (xcell) - ((name :initarg :name :reader name) - (model :initarg :model :reader model) - (cell :initarg :cell :reader cell)) - (:report (lambda (condition stream) - (format stream "~&fatal cell programming error: ~s" condition) - (format stream "~& : ~s" (name condition)) - (format stream "~& : ~s" (model condition)) - (format stream "~& : ~s" (cell condition))))) - -(define-condition c-unadopted (c-fatal) - () - (:report - (lambda (condition stream) - (format stream "~&unadopted cell >: ~s" (cell condition)) - (format stream "~& >: often you mis-edit (c? (c? ...)) nesting is error")))) - - -;----------------------------- link debugging ----------------------- - - -(defun dump-users (c &optional (depth 0)) - (format t "~&~v,4t~s" depth c) - (dolist (user (un-users c)) - (dump-users user (+ 1 depth)))) - -(defun dump-useds (c &optional (depth 0)) - ;(c.trc "dump-useds> entry " c (+ 1 depth)) - (when (zerop depth) - (format t "x~&")) - (format t "~&|usd> ~v,8t~s" depth c) - (when (typep c 'c-ruled) - ;(c.trc "its ruled" c) - (dolist (used (cd-useds c)) - (dump-useds used (+ 1 depth))))) - - -(defun cell-reset () - (setf *count* nil - *stop* nil - *dbg* nil - *mybreak* nil - *c-prop-depth* 0 - *sw-looping* nil - *to-be-awakened* nil - *trcdepth* 0)) - +;; -*- 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) + +(defun cellbrk (&optional (tag :anon)) + (unless (or (c-stopped)) + ;; daring move, hoping having handler at outside stops the game (cellstop) + (print `(cell break , tag)) + (break))) + +;----------- trc ------------------------------------------- + +(defun trcdepth-reset () + (setf *trcdepth* 0)) + +(defmacro trc (tgtform &rest os) + (if (eql tgtform 'nil) + '(progn) + (if (stringp tgtform) + `(without-c-dependency + (call-trc t ,tgtform ,@os)) + (let ((tgt (gensym))) + `(without-c-dependency + (bif (,tgt ,tgtform) + (if (trcp ,tgt) + (progn + (c-assert (stringp ,(car os))) + (call-trc t ,@os)) ;;,(car os) ,tgt ,@(cdr os))) + (progn + ;;; (break) + (count-it :trcfailed))) + (count-it :tgtnileval))))))) + +(defun call-trc (stream s &rest os) + (if #+cormanlisp nil #-cormanlisp (and (boundp '*trcdepth*) + *trcdepth*) + (format stream "~&~v,,,'.<~d~>> " (mod *trcdepth* 100) *trcdepth*) + (format stream "~&")) + + (format stream "~a" s) + (let (pkwp) + (dolist (o os) + (format stream (if pkwp " ~s" " | ~s") o) + (setf pkwp (keywordp o)))) + (values)) + +(defun call-trc-to-string (fmt$ &rest fmtargs) + (let ((o$ (make-array '(0) :element-type 'base-char + :fill-pointer 0 :adjustable t))) + (with-output-to-string (ostream o$) + (apply 'call-trc ostream fmt$ fmtargs)) + o$)) + +#+findtrcevalnils +(defmethod trcp :around (other) + (unless (call-next-method other)(break))) + +(defmethod trcp (other) + (eq other t)) + +(defmethod trcp (($ string)) + t) + +(defun trcdepth-incf () + (incf *trcdepth*)) + +(defun trcdepth-decf () + (format t "decrementing trc depth" *trcdepth*) + (decf *trcdepth*)) + +(defmacro wtrc ((&optional (min 1) (max 50) &rest banner) &body body ) + `(let ((*trcdepth* (if *trcdepth* + (1+ *trcdepth*) + 0))) + ,(when banner `(when (>= *trcdepth* ,min) + (if (< *trcdepth* ,max) + (trc ,@banner) + (progn + (break "excess trace notttt!!! ~d" *trcdepth*) ;; ,@banner) + nil)))) + (when (< *trcdepth* ,max) + ,@body))) + +(defmacro wnotrc ((&optional (min 1) (max 50) &rest banner) &body body ) + (declare (ignore min max banner)) + `(progn ,@body)) + +;------ eko -------------------------------------- + + +(defmacro eko ((&rest trcargs) &rest body) + (let ((result (gensym))) + `(let ((,result ,@body)) + (trc ,(car trcargs) :=> ,result ,@(cdr trcargs)) + ,result))) + +(defmacro ek (label &rest body) + (let ((result (gensym))) + `(let ((,result (,@body))) + (when ,label + (trc ,label ,result)) + ,result))) + +;------------- counting --------------------------- +(defvar *count* nil) +(defvar *counting* nil) + +(defmacro with-counts ((onp &rest msg) &body body) + `(if ,onp + (prog2 + (progn + (count-clear ,@msg) + (push t *counting*)) + (progn ,@body) + (pop *counting*) + (show-count t ,@msg)) + (progn ,@body))) + +(defun count-clear (&rest msg) + (declare (ignorable msg)) + (format t "~&count-clear > ~a" msg) + (setf *count* nil)) + +(defmacro count-it (&rest keys) + `(when *counting* + (call-count-it ,@keys))) + +(defun call-count-it (&rest keys) + (declare (ignorable keys)) + ;;; (when (eql :TGTNILEVAL (car keys))(break)) + (let ((entry (assoc keys *count* :test #'equal))) + (if entry + (setf (cdr entry) (1+ (cdr entry))) + (push (cons keys 1) *count*)))) + +(defun show-count (clearp &rest msg) + (format t "~&Counts after: clearp ~a, length ~d: ~s" clearp (length *count*) msg) + (let ((res (sort (copy-list *count*) (lambda (v1 v2) + (let ((v1$ (symbol-name (caar v1))) + (v2$ (symbol-name (caar v2)))) + (if (string= v1$ v2$) + (< (cdr v1) (cdr v2)) + (string< v1$ v2$)))))) + ) + (loop for entry in res + for occs = (cdr entry) + when (plusp occs) + sum occs into running + and do (format t "~&~4d ... ~2d ... ~s" running occs (car entry)))) + (when clearp (count-clear "show-count"))) + +#+test +(loop for entry in '((a . 10)(b . 5)(c . 0)(e . -20)(d . 2)) + for occs = (cdr entry) + when (plusp occs) + sum occs into running + and do (print (list entry occs running))) + + +;-------------------- timex --------------------------------- + +(defmacro timex ((onp &rest trcArgs) &body body) + `(if ,onp + (prog1 + (time + (progn ,@body)) + (trc "timing was of" ,@trcARgs)) + (progn ,@body))) + + +;---------------- Metrics ------------------- + +(defmacro with-metrics ((countp timep &rest trcargs) &body body) + `(with-counts (,countp ,@trcargs) + (timex (,timep ,@trcargs) + ,@body))) + + +; -------- cell conditions (not much used) --------------------------------------------- + +(define-condition xcell () ;; new 2k0227 + ((cell :initarg :cell :reader cell :initform nil) + (appfunc :initarg :appfunc :reader appfunc :initform 'badcell) + (errortext :initarg :errortext :reader errortext :initform "<???>") + (otherdata :initarg :otherdata :reader otherdata :initform "<nootherdata>")) + (:report (lambda (c s) + (format s "~& trouble with cell ~a in function ~s,~s: ~s" + (cell c) (appfunc c) (errortext c) (otherdata c))))) + +(define-condition c-enabling () + ((name :initarg :name :reader name) + (model :initarg :model :reader model) + (cell :initarg :cell :reader cell)) + (:report (lambda (condition stream) + (format stream "~&unhandled <c-enabling>: ~s" condition) + (break "~&i say, unhandled <c-enabling>: ~s" condition)))) + +(define-condition c-fatal (xcell) + ((name :initarg :name :reader name) + (model :initarg :model :reader model) + (cell :initarg :cell :reader cell)) + (:report (lambda (condition stream) + (format stream "~&fatal cell programming error: ~s" condition) + (format stream "~& : ~s" (name condition)) + (format stream "~& : ~s" (model condition)) + (format stream "~& : ~s" (cell condition))))) + +(define-condition c-unadopted (c-fatal) + () + (:report + (lambda (condition stream) + (format stream "~&unadopted cell >: ~s" (cell condition)) + (format stream "~& >: often you mis-edit (c? (c? ...)) nesting is error")))) + + +;----------------------------- link debugging ----------------------- + + +(defun dump-users (c &optional (depth 0)) + (format t "~&~v,4t~s" depth c) + (dolist (user (c-users c)) + (dump-users user (+ 1 depth)))) + +(defun dump-useds (c &optional (depth 0)) + ;(c.trc "dump-useds> entry " c (+ 1 depth)) + (when (zerop depth) + (format t "x~&")) + (format t "~&|usd> ~v,8t~s" depth c) + (when (typep c 'c-ruled) + ;(c.trc "its ruled" c) + (dolist (used (cd-useds c)) + (dump-useds used (+ 1 depth))))) + + +(defun cell-reset () + (setf *count* nil + *stop* nil + *dbg* nil + *c-break* nil + *c-prop-depth* 0 + *sw-looping* nil + *to-be-awakened* nil + *trcdepth* 0)) \ No newline at end of file Index: cells/defmodel.lisp diff -u cells/defmodel.lisp:1.1.1.1 cells/defmodel.lisp:1.2 --- cells/defmodel.lisp:1.1.1.1 Sat Nov 8 18:44:00 2003 +++ cells/defmodel.lisp Tue Dec 16 10:02:58 2003 @@ -1,121 +1,121 @@ -;; -*- 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) - -(defmacro defmodel (class directsupers slotspecs &rest options) - ;;(print `(defmodel sees directsupers ,directsupers using ,(or directsupers :model-object))) - `(progn - (eval-when (:compile-toplevel :execute :load-toplevel) - (setf (get ',class :cell-defs) nil)) - ; - ; define slot macros before class so they can appear in initforms and default-initargs - ; - ,@(mapcar (lambda (slotspec) - (destructuring-bind - (slotname &rest slotargs - &key (cell t) accessor reader - &allow-other-keys) - slotspec - (declare (ignorable slotargs)) - (when cell - (let* ((readerfn (or reader accessor)) - (deriverfn (intern$ "^" (symbol-name readerfn))) - ) - ; - ; may as well do this here... - ; - ;;(trc nil "slot, deriverfn would be" slotname deriverfn) - `(eval-when (:compile-toplevel :execute :load-toplevel) - (setf (md-slot-cell-type ',class ',slotname) ,cell) - (unless (macro-function ',deriverfn) - (defmacro ,deriverfn (&optional (model 'self) synfactory) - `(let ((*synapse-factory* ,synfactory)) - (,',readerfn ,model)))) - ) - )) - )) - slotspecs) - - ; - ; ------- defclass --------------- (^slot-value ,model ',',slotname) - ; - - (progn - (defclass ,class ,(or directsupers '(model-object));; now we can def the class - ,(mapcar (lambda (s) - (list* (car s) - (let ((ias (cdr s))) - (remf ias :cell) - (remf ias :cwhen) - (remf ias :unchanged-if) - ias))) (mapcar #'copy-list slotspecs)) - (:documentation - ,@(or (cdr (find :documentation options :key #'car)) - '("chya"))) - (:default-initargs ;; nil ok and needed: acl oddity in re not clearing d-i's sans this - ,@(cdr (find :default-initargs options :key #'car))) - (:metaclass ,(or (find :metaclass options :key #'car) - 'standard-class))) - - (defmethod shared-initialize :after ((self ,class) slot-names &rest iargs) - (declare (ignore slot-names iargs)) - ,(when (and directsupers (not (member 'model-object directsupers))) - `(unless (typep self 'model-object) - (error "If no superclass of ~a inherits directly -or indirectly from model-object, model-object must be included as a direct super-class in -the defmodel form for ~a" ',class ',class)))) - ; - ; slot accessors once class is defined... - ; - ,@(mapcar (lambda (slotspec) - (destructuring-bind - (slotname &rest slotargs - &key (cell t) unchanged-if accessor reader writer type - &allow-other-keys) - slotspec - (declare (ignorable slotargs)) - (when cell - (let* ((readerfn (or reader accessor)) - (writerfn (or writer accessor)) - ) - (setf (md-slot-cell-type class slotname) cell) - - `(progn - ,(when readerfn - `(defmethod ,readerfn ((self ,class)) - (md-slot-value self ',slotname))) - - ,(when writerfn - `(defmethod (setf ,writerfn) (new-value (self ,class)) - (setf (md-slot-value self ',slotname) - ,(if type - `(coerce new-value ',type) - 'new-value)))) - - ,(when unchanged-if - `(def-c-unchanged-test (,class ,slotname))) - ) - )) - )) - slotspecs) +;; -*- 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) + +(defmacro defmodel (class directsupers slotspecs &rest options) + ;;(print `(defmodel sees directsupers ,directsupers using ,(or directsupers :model-object))) + `(progn + (eval-when (:compile-toplevel :execute :load-toplevel) + (setf (get ',class :cell-types) nil)) + ; + ; define slot macros before class so they can appear in initforms and default-initargs + ; + ,@(mapcar (lambda (slotspec) + (destructuring-bind + (slotname &rest slotargs + &key (cell t) accessor reader + &allow-other-keys) + slotspec + (declare (ignorable slotargs)) + (when cell + (let* ((readerfn (or reader accessor)) + (deriverfn (intern$ "^" (symbol-name readerfn))) + ) + ; + ; may as well do this here... + ; + ;;(trc nil "slot, deriverfn would be" slotname deriverfn) + `(eval-when (:compile-toplevel :execute :load-toplevel) + (setf (md-slot-cell-type ',class ',slotname) ,cell) + (unless (macro-function ',deriverfn) + (defmacro ,deriverfn (&optional (model 'self) synfactory) + `(let ((*synapse-factory* ,synfactory)) + (,',readerfn ,model)))) + ) + )) + )) + slotspecs) + + ; + ; ------- defclass --------------- (^slot-value ,model ',',slotname) + ; + + (progn + (defclass ,class ,(or directsupers '(model-object));; now we can def the class + ,(mapcar (lambda (s) + (list* (car s) + (let ((ias (cdr s))) + (remf ias :cell) + (remf ias :cwhen) + (remf ias :unchanged-if) + ias))) (mapcar #'copy-list slotspecs)) + (:documentation + ,@(or (cdr (find :documentation options :key #'car)) + '("chya"))) + (:default-initargs ;; nil ok and needed: acl oddity in re not clearing d-i's sans this + ,@(cdr (find :default-initargs options :key #'car))) + (:metaclass ,(or (find :metaclass options :key #'car) + 'standard-class))) + + (defmethod shared-initialize :after ((self ,class) slot-names &rest iargs) + (declare (ignore slot-names iargs)) + ,(when (and directsupers (not (member 'model-object directsupers))) + `(unless (typep self 'model-object) + (error "If no superclass of ~a inherits directly +or indirectly from model-object, model-object must be included as a direct super-class in +the defmodel form for ~a" ',class ',class)))) + ; + ; slot accessors once class is defined... + ; + ,@(mapcar (lambda (slotspec) + (destructuring-bind + (slotname &rest slotargs + &key (cell t) unchanged-if accessor reader writer type + &allow-other-keys) + slotspec + (declare (ignorable slotargs)) + (when cell + (let* ((readerfn (or reader accessor)) + (writerfn (or writer accessor)) + ) + (setf (md-slot-cell-type class slotname) cell) + + `(progn + ,(when readerfn + `(defmethod ,readerfn ((self ,class)) + (md-slot-value self ',slotname))) + + ,(when writerfn + `(defmethod (setf ,writerfn) (new-value (self ,class)) + (setf (md-slot-value self ',slotname) + ,(if type + `(coerce new-value ',type) + 'new-value)))) + + ,(when unchanged-if + `(def-c-unchanged-test (,class ,slotname) ,unchanged-if)) + ) + )) + )) + slotspecs) (find-class ',class)))) Index: cells/detritus.lisp diff -u cells/detritus.lisp:1.1.1.1 cells/detritus.lisp:1.2 --- cells/detritus.lisp:1.1.1.1 Sat Nov 8 18:44:05 2003 +++ cells/detritus.lisp Tue Dec 16 10:02:58 2003 @@ -1,49 +1,49 @@ -;; -*- 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 *dbg*) - -(defmacro wdbg (&body body) - `(let ((*dbg* t)) - ,@body)) - -#+clisp -(defun slot-definition-name (slot) - (clos::slotdef-name slot)) - -(defmethod class-slot-named ((classname symbol) slotname) - (class-slot-named (find-class classname) slotname)) - -(defmethod class-slot-named (class slotname) - (find slotname (class-slots class) :key #'slot-definition-name)) - -#+mcl -(defun class-slots (c) - (nconc (copy-list (class-class-slots c)) - (copy-list (class-instance-slots c)))) - -(defun true (it) (declare (ignore it)) t) -(defun false (it) (declare (ignore it))) -(defun xor (c1 c2) - (if c1 (not c2) c2)) +;; -*- 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 *dbg*) + +(defmacro wdbg (&body body) + `(let ((*dbg* t)) + ,@body)) + +#+clisp +(defun slot-definition-name (slot) + (clos::slotdef-name slot)) + +(defmethod class-slot-named ((classname symbol) slotname) + (class-slot-named (find-class classname) slotname)) + +(defmethod class-slot-named (class slotname) + (find slotname (class-slots class) :key #'slot-definition-name)) + +#+mcl +(defun class-slots (c) + (nconc (copy-list (class-class-slots c)) + (copy-list (class-instance-slots c)))) + +(defun true (it) (declare (ignore it)) t) +(defun false (it) (declare (ignore it))) +(defun xor (c1 c2) + (if c1 (not c2) c2)) Index: cells/family-values.lisp diff -u cells/family-values.lisp:1.1.1.1 cells/family-values.lisp:1.2 --- cells/family-values.lisp:1.1.1.1 Sat Nov 8 18:44:05 2003 +++ cells/family-values.lisp Tue Dec 16 10:02:58 2003 @@ -1,105 +1,105 @@ -;; -*- 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-toplevel :load-toplevel :execute) - (export '(family-values family-values-sorted - sortindex sortdirection sortpredicate sortkey - ^sortindex ^sortdirection ^sortpredicate ^sortkey))) - -(defmodel family-values (family) - ( - (kvcollector :initarg :kvcollector - :initform #'identity - :reader kvcollector) - - (kidvalues :cell t - :initform (c? (when (kvcollector self) - (funcall (kvcollector self) (^mdvalue)))) - :accessor kidvalues - :initarg :kidvalues) - - (kvkey :initform #'identity - :initarg :kvkey - :reader kvkey) - - (kvkeytest :initform #'equal - :initarg :kvkeytest - :reader kvkeytest) - - (kidfactory :cell t - :initform #'identity - :initarg :kidfactory - :reader kidfactory) - - (.kids :cell t - :initform (c? (assert (listp (kidvalues self))) - (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))) - :accessor kids - :initarg :kids))) - -(defmethod fv-kid-keep (family oldkid) - (declare (ignorable family oldkid)) - nil) - -(defmodel family-values-sorted (family-values) - ((sortedkids :initarg :sortedkids :accessor sortedkids - :initform nil) - (sortmap :initform (cv nil) :initarg :sortmap :accessor sortmap) - (.kid-slots :cell t - :initform (c? (assert (listp (kidvalues self))) - (mapsort (^sortmap) - (thekids - (mapcar (lambda (kidvalue) - (trc "making kid" kidvalue) - (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))))) - :accessor kid-slots - :initarg :kid-slots))) - -(defun mapsort (map data) - ;;(trc "mapsort map" map) - (if map - (stable-sort data #'< :key (lambda (datum) (or (position datum map) - ;(trc "mapsort datum not in map" datum) - (1+ (length data))))) - data)) - -(def-c-echo sortedkids () - (setf (sortmap self) new-value)) ;; cellular trick to avoid cyclicity - +;; -*- 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-toplevel :load-toplevel :execute) + (export '(family-values family-values-sorted + sortindex sortdirection sortpredicate sortkey + ^sortindex ^sortdirection ^sortpredicate ^sortkey))) + +(defmodel family-values (family) + ( + (kvcollector :initarg :kvcollector + :initform #'identity + :reader kvcollector) + + (kidvalues :cell t + :initform (c? (when (kvcollector self) + (funcall (kvcollector self) (^md-value)))) + :accessor kidvalues + :initarg :kidvalues) + + (kvkey :initform #'identity + :initarg :kvkey + :reader kvkey) + + (kvkeytest :initform #'equal + :initarg :kvkeytest + :reader kvkeytest) + + (kidfactory :cell t + :initform #'identity + :initarg :kidfactory + :reader kidfactory) + + (.kids :cell t + :initform (c? (c-assert (listp (kidvalues self))) + (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))) + :accessor kids + :initarg :kids))) + +(defmethod fv-kid-keep (family oldkid) + (declare (ignorable family oldkid)) + nil) + +(defmodel family-values-sorted (family-values) + ((sortedkids :initarg :sortedkids :accessor sortedkids + :initform nil) + (sortmap :initform (cv nil) :initarg :sortmap :accessor sortmap) + (.kids :cell t + :initform (c? (c-assert (listp (kidvalues self))) + (mapsort (^sortmap) + (thekids + (mapcar (lambda (kidvalue) + (trc "making kid" kidvalue) + (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))))) + :accessor kids + :initarg :kids))) + +(defun mapsort (map data) + ;;(trc "mapsort map" map) + (if map + (stable-sort data #'< :key (lambda (datum) (or (position datum map) + ;(trc "mapsort datum not in map" datum) + (1+ (length data))))) + data)) + +(def-c-echo sortedkids () + (setf (sortmap self) new-value)) ;; cellular trick to avoid cyclicity + Index: cells/family.lisp diff -u cells/family.lisp:1.1.1.1 cells/family.lisp:1.2 --- cells/family.lisp:1.1.1.1 Sat Nov 8 18:44:05 2003 +++ cells/family.lisp Tue Dec 16 10:02:58 2003 @@ -1,240 +1,261 @@ -;; -*- 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-toplevel :execute :load-toplevel) - (export '(model mdvalue family kids kid1 perishable))) - -(defmodel model () - ((.mdvalue :initform nil :accessor mdvalue :initarg :mdvalue))) - -(defmodel perishable () - ((expiration :initform nil :accessor expiration :initarg :expiration))) - -(def-c-echo expiration () - (when new-value - (not-to-be self))) - -(defmodel family (model) - ((.kids :cell t - :initform (cv nil) ;; most useful - :accessor kids - :initarg :kids) - (.kid-slots :cell t - :initform nil - :accessor kid-slots - :initarg :kid-slots))) - -(defmacro thekids (&rest kids) - `(packed-flat! ,@(mapcar (lambda (kid) - (typecase kid - (keyword `(make-instance ',(intern$ (symbol-name kid)))) - (t `,kid))) - kids))) - -(defmacro thekids2 (&rest kids) - `(packed-flat! ,@(mapcar (lambda (kid) - (typecase kid - (keyword `(make-instance ',(intern$ (symbol-name kid)))) - (t `,kid))) - kids))) - -(defun kid1 (self) (car (kids self))) - -;; /// redundancy in following - -(defmacro psib (&optional (selfform 'self)) - (let ((self (gensym))) - `(bwhen (,self ,selfform) - (find-prior ,self (kids (fmparent ,self)))))) - -(defmacro nsib (&optional (selfform 'self)) - (let ((self (gensym))) - `(bwhen (,self ,selfform) - (cadr (member ,self (kids (fmparent ,self))))))) - -(defmacro ^priorSib (self) - (let ((kid (gensym))) - `(let* ((,kid ,self)) - (find-prior ,kid (^kids (fmParent ,kid)))))) - -(defmacro ^firstKidP (self) - (let ((kid (gensym))) - `(let ((,kid ,self)) - (eql ,kid (car (^kids (fmParent ,kid))))))) - -(defmacro ^lastKidP (self) - (let ((kid (gensym))) - `(let ((,kid ,self)) - (null (cdr (member ,kid (^kids (fmParent ,kid)))))))) - -(defun md-adopt (fmparent self) - (assert self) - (assert fmparent) - (assert (typep fmparent 'family)) - - (trc nil "md-adopt >" :by fmparent) - - (let ((currparent (fmparent self)) - (selftype (type-of self))) - (assert (or (null currparent) - (eql fmparent currparent))) - (unless (plusp (adopt-ct self)) - (incf (adopt-ct self)) - (setf (fmparent self) fmparent) - - (bwhen (kid-slots-fn (kid-slots (fmparent self))) - (dolist (ksdef (funcall kid-slots-fn self) self) - (let ((slot-name (ksname ksdef))) - (trc nil "got ksdef " slot-name) - (when (md-slot-cell-type selftype slot-name) - (trc nil "got cell type " slot-name) - (when (or (not (ksifmissing ksdef)) - (and (null (c-slot-value self slot-name)) - (null (md-slot-cell self slot-name)))) - (trc nil "ks missing ok " slot-name) - (multiple-value-bind (c-or-value suppressp) - (funcall (ksrule ksdef) self) - (unless suppressp - (trc nil "c-install " slot-name c-or-value) - (c-install self slot-name c-or-value)))))))) - - ; new for 12/02... - (md-adopt-kids self))) - self) - -(defmethod md-adopt-kids (self) (declare (ignorable self))) -(defmethod md-adopt-kids ((self family)) - (when (slot-boundp self '.kids) - (dolist (k (slot-value self '.kids)) - (unless (fmParent k) - (md-adopt self k))))) - - - - -(defmethod c-slot-value ((self model-object) slot) - (slot-value self slot)) - -(defun md-kids-change (self new-kids old-kids usage) - (assert (listp new-kids)) - (assert (listp old-kids)) - (assert (not (member nil old-kids))) - (assert (not (member nil new-kids))) - - (trc nil "md-kids-change > entry" usage new-kids old-kids) - #+nah (when (and (trcp (car new-kids)) - (eql usage :md-slot-value-assume)) - (break "how here? ~a" self)) - - (dolist (k old-kids) - (unless (member k new-kids) - (trc nil "kids change nailing lost kid" k) - (not-to-be k) - (setf (fmparent k) nil) ;; 020302kt unnecessary? anyway, after not-to-be since that might require fmparent - )) - - (dolist (k new-kids) - (unless (member k old-kids) - (if (eql :nascent (md-state k)) - (progn - #+dfdbg (trc k "adopting par,k:" self k) - (md-adopt self k)) - (unless (eql self (fmParent k)) - ;; 230126 recent changes to kids handling leads to dup kids-change calls - (trc "feature not yet implemented: adopting previously adopted: parent, kid" self (type-of k)) - (trc "old" old-kids) - (trc "new" new-kids) - (break "bad state extant nkid ~a ~a ~a" usage k (md-state k)) - ))))) - -(def-c-echo .kids ((self family)) - (dolist (k new-value) - (to-be k))) - -(defun md-reinitialize (self) - (unless (eql (md-state self) :nascent) - (setf (md-state self) :nascent) - (md-reinitialize-primary self))) - -(defmethod md-reinitialize-primary :after ((self family)) - (dolist (kid (slot-value self '.kids)) ;; caused re-entrance to c? (kids self)) - (md-reinitialize kid))) - -(defmethod md-reinitialize-primary (self) - (cellbrk) - (md-map-cells self nil (lambda (c) - (setf (c-waking-state c) nil) - (when (typep c 'c-ruled) - (setf (c-state c) :unbound))))) - -(defmethod kids ((other model-object)) nil) - -(defmethod not-to-be :before ((fm family)) - (unless (md-untouchable fm) - (trc nil "(not-to-be :before family) not closed stream, backdooropen; kids c-awake; kids c-state" - *svuc-backdoor-open* - (if (md-slot-cell fm '.kids) - (c-waking-state (md-slot-cell fm '.kids)) - :no-kids-cell) - (when (md-slot-cell fm '.kids) - (c-state (md-slot-cell fm 'kids)))) - ;; use backdoor so if kids not yet ruled into - ;; existence they won't be now just to not-to-be them - (let ((svkids (slot-value fm '.kids))) - (when (listp svkids) - (dolist ( kid svkids) - (not-to-be kid))))) - - (trc nil "(not-to-be :before family) exit, kids state" (when (md-slot-cell fm 'kids) - (c-state (md-slot-cell fm 'kids))))) - - -;------------------ kid slotting ---------------------------- -; -(cc-defstruct (kid-slotdef - (:conc-name nil)) - ksname - ksrule - (ksifmissing t)) - -(defmacro mk-kid-slot ((ksname &key ifmissing) ksrule) - `(make-kid-slotdef - :ksname ',ksname - :ksrule (lambda (self) - (declare (ignorable self)) - ,ksrule) - :ksifmissing ,ifmissing)) - -(defmacro def-kid-slots (&rest slot-defs) - `(lambda (self) - (declare (ignorable self)) - (list ,@slot-defs))) - -(defmethod md-name (symbol) - symbol) - -(defmethod md-name ((nada null)) - (unless *stop* - (setq *stop* t) - (break "md-name called on nil"))) \ No newline at end of file +;; -*- 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-toplevel :execute :load-toplevel) + (export '(model md-value family kids kid1 perishable))) + +(defmodel model () + ((.md-name :cell nil :initform nil :initarg :md-name :accessor md-name) + (.fm-parent :cell nil :initform nil :initarg :fm-parent :accessor fm-parent) + (.md-value :initform nil :accessor md-value :initarg :md-value))) + +(defmethod print-object ((self model) s) + (format s "~a" (or (md-name self) (type-of self)))) + +(define-symbol-macro .parent (fm-parent self)) + +(defmethod md-initialize :around ((self model)) + (when (slot-boundp self '.md-name) + (unless (md-name self) + (setf (md-name self) (c-class-name (class-of self))))) + + (when (fm-parent self) + (md-adopt (fm-parent self) self)) + + (call-next-method)) + +(defmodel perishable () + ((expiration :initform nil :accessor expiration :initarg :expiration))) + +(def-c-echo expiration () + (when new-value + (not-to-be self))) + +(defmodel family (model) + ((.kid-slots :cell nil + :initform nil + :accessor kid-slots + :initarg :kid-slots) + (.kids :initform (cv nil) ;; most useful + :accessor kids + :initarg :kids) + )) + +(defmacro thekids (&rest kids) + `(packed-flat! ,@(mapcar (lambda (kid) + (typecase kid + (keyword `(make-instance ',(intern$ (symbol-name kid)))) + (t `,kid))) + kids))) + +(defmacro thekids2 (&rest kids) + `(packed-flat! ,@(mapcar (lambda (kid) + (typecase kid + (keyword `(make-instance ',(intern$ (symbol-name kid)))) + (t `,kid))) + kids))) + +(defun kid1 (self) (car (kids self))) +(defun lastkid (self) (last1 (kids self))) + +;; /// redundancy in following + +(defmacro psib (&optional (selfform 'self)) + (let ((self (gensym))) + `(bwhen (,self ,selfform) + (find-prior ,self (kids (fm-parent ,self)))))) + +(defmacro nsib (&optional (selfform 'self)) + (let ((self (gensym))) + `(bwhen (,self ,selfform) + (cadr (member ,self (kids (fm-parent ,self))))))) + +(defmacro ^priorSib (self) + (let ((kid (gensym))) + `(let* ((,kid ,self)) + (find-prior ,kid (^kids (fm-parent ,kid)))))) + +(defmacro ^firstKidP (self) + (let ((kid (gensym))) + `(let ((,kid ,self)) + (eql ,kid (car (^kids (fm-parent ,kid))))))) + +(defmacro ^lastKidP (self) + (let ((kid (gensym))) + `(let ((,kid ,self)) + (null (cdr (member ,kid (^kids (fm-parent ,kid)))))))) + +(defun md-adopt (fm-parent self) + (c-assert self) + (c-assert fm-parent) + (c-assert (typep fm-parent 'family)) + + + (trc nil "md-adopt >" :kid self (adopt-ct self) :by fm-parent) + + (let ((currparent (fm-parent self)) + (selftype (type-of self))) + (c-assert (or (null currparent) + (eql fm-parent currparent))) + ;; (when (plusp (adopt-ct self))(c-break "2nd adopt ~a, by ~a" self fm-parent)) + (unless (plusp (adopt-ct self)) + (incf (adopt-ct self)) + (setf (fm-parent self) fm-parent) + + (bwhen (kid-slots-fn (kid-slots (fm-parent self))) + (dolist (ksdef (funcall kid-slots-fn self) self) + (let ((slot-name (ksname ksdef))) + (trc nil "got ksdef " slot-name) + (when (md-slot-cell-type selftype slot-name) + (trc fm-parent "got cell type " slot-name) + (when (or (not (ksifmissing ksdef)) + (and (null (c-slot-value self slot-name)) + (null (md-slot-cell self slot-name)))) + (trc fm-parent "ks missing ok " slot-name) + (multiple-value-bind (c-or-value suppressp) + (funcall (ksrule ksdef) self) + (unless suppressp + (trc fm-parent "c-install " slot-name c-or-value) + (c-install self slot-name c-or-value)))))))) + + ; new for 12/02... + (md-adopt-kids self))) + self) + +(defmethod md-adopt-kids (self) (declare (ignorable self))) +(defmethod md-adopt-kids ((self family)) + (when (slot-boundp self '.kids) + (dolist (k (slot-value self '.kids)) + (unless (fm-parent k) + (md-adopt self k))))) + + + + +(defmethod c-slot-value ((self model-object) slot) + (slot-value self slot)) + +(defun md-kids-change (self new-kids old-kids usage) + (c-assert (listp new-kids)) + (c-assert (listp old-kids)) + (c-assert (not (member nil old-kids))) + (c-assert (not (member nil new-kids))) + + (trc nil "md-kids-change > entry" usage new-kids old-kids) + #+nah (when (and (trcp (car new-kids)) + (eql usage :md-slot-value-assume)) + (break "how here? ~a" self)) + + (dolist (k old-kids) + (unless (member k new-kids) + (trc nil "kids change nailing lost kid" k) + (not-to-be k) + (setf (fm-parent k) nil) ;; 020302kt unnecessary? anyway, after not-to-be since that might require fm-parent + )) + + (dolist (k new-kids) + (unless (member k old-kids) + (if (eql :nascent (md-state k)) + (progn + #+dfdbg (trc k "adopting par,k:" self k) + (md-adopt self k)) + (unless (eql self (fm-parent k)) + ;; 230126 recent changes to kids handling leads to dup kids-change calls + (trc "feature not yet implemented: adopting previously adopted: parent, kid" self (type-of k)) + (trc "old" old-kids) + (trc "new" new-kids) + (break "bad state extant nkid ~a ~a ~a" usage k (md-state k)) + ))))) + +(def-c-echo .kids ((self family)) + (dolist (k new-value) + (to-be k))) + +(defun md-reinitialize (self) + (unless (eql (md-state self) :nascent) + (setf (md-state self) :nascent) + (md-reinitialize-primary self))) + +(defmethod md-reinitialize-primary :after ((self family)) + (dolist (kid (slot-value self '.kids)) ;; caused re-entrance to c? (kids self)) + (md-reinitialize kid))) + +(defmethod md-reinitialize-primary (self) + (cellbrk) + (md-map-cells self nil (lambda (c) + (setf (c-waking-state c) nil) + (when (typep c 'c-ruled) + (setf (c-state c) :unbound))))) + +(defmethod kids ((other model-object)) nil) + +(defmethod not-to-be :before ((fm family)) + (unless (md-untouchable fm) + (trc nil "(not-to-be :before family) not closed stream, backdooropen; kids c-awake; kids c-state" + *svuc-backdoor-open* + (if (md-slot-cell fm '.kids) + (c-waking-state (md-slot-cell fm '.kids)) + :no-kids-cell) + (when (md-slot-cell fm '.kids) + (c-state (md-slot-cell fm 'kids)))) + ;; use backdoor so if kids not yet ruled into + ;; existence they won't be now just to not-to-be them + (let ((svkids (slot-value fm '.kids))) + (when (listp svkids) + (dolist ( kid svkids) + (not-to-be kid))))) + + (trc nil "(not-to-be :before family) exit, kids state" (when (md-slot-cell fm 'kids) + (c-state (md-slot-cell fm 'kids))))) + + +;------------------ kid slotting ---------------------------- +; +(defstruct (kid-slotdef + (:conc-name nil)) + ksname + ksrule + (ksifmissing t)) + +(defmacro mk-kid-slot ((ksname &key ifmissing) ksrule) + `(make-kid-slotdef + :ksname ',ksname + :ksrule (lambda (self) + (declare (ignorable self)) + ,ksrule) + :ksifmissing ,ifmissing)) + +(defmacro def-kid-slots (&rest slot-defs) + `(lambda (self) + (declare (ignorable self)) + (list ,@slot-defs))) + +(defmethod md-name (symbol) + symbol) + +(defmethod md-name ((nada null)) + (unless (c-stopped) + (c-stop :md-name-on-null) + (break "md-name called on nil"))) + Index: cells/flow-control.lisp diff -u cells/flow-control.lisp:1.1.1.1 cells/flow-control.lisp:1.2 --- cells/flow-control.lisp:1.1.1.1 Sat Nov 8 18:44:17 2003 +++ cells/flow-control.lisp Tue Dec 16 10:02:58 2003 @@ -1,169 +1,155 @@ -;; -*- 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) - -(defmacro maxf (place &rest othervalues) - `(setf ,place (max ,place ,@othervalues))) - -(defun last1 (thing) - (car (last thing))) - -(defun max-if (&rest values) - (loop for x in values when x maximize x)) - -(defun min-max-of (v1 v2) - (values (min-if v1 v2) (max-if v1 v2))) - -(defun min-if (v1 v2) - (if v1 (if v2 (min v1 v2) v1) v2)) - -(defun list-flatten! (&rest list) - (if (consp list) - (let (head work visited) - (labels ((link (cell) - ;;(format t "~&Link > cons: ~s . ~s" (car cell) (cdr cell)) - (when (and (consp cell) - (member cell visited)) - (break "list-flatten! detects infinite list: cell ~a, visited ~a" cell visited)) - (push cell visited) - - (when cell - (if (consp (car cell)) - (link (car cell)) - (progn - (setf head (or head cell)) - (when work - (rplacd work cell)) - (setf work cell))) - (link (rest cell))))) - (link list)) - head) - list)) - -(defun packed-flat! (&rest uNameit) - (delete-if #'null (list-flatten! uNameIt))) - -(defmacro with-dynamic-fn ((fnName (&rest fnArgs) &body fnBody) &body body) - `(let ((,fnName (lambda ,fnArgs ,@fnBody))) - (declare (dynamic-extent ,fnname)) - ,@body)) - -(eval-when (compile load eval) - (export 'myAssert)) - -(defmacro myAssert (assertion &optional places fmt$ &rest fmtargs) - (declare (ignore places)) - - `(unless *stop* - (unless ,assertion - (setf *stop* t) - ,(if fmt$ - `(mybreak ,fmt$ ,@fmtargs) - `(mybreak "failed assertion:" ',assertion))))) - -(defvar *mybreak*) - -(defun mybreak (&rest args) - (unless (or *mybreak* *stop*) - (setf *mybreak* t) - (setf *stop* t) - (format t "mybreak > stopping > ~a" args) - (apply #'break args))) - -(defun assocv (sym assoc) - (cdr (assoc sym assoc))) - -(defmacro assocv-setf (assoc-place sym-form v) - (let ((sym (gensym))(entry (gensym))) - `(let ((,sym ,sym-form)) - (bIf (,entry (assoc ,sym ,assoc-place)) - (rplacd ,entry ,v) - (push (cons ,sym ,v) ,assoc-place))))) - -(defun intern$ (&rest strings) - (intern (apply #'concatenate 'string (mapcar #'string-upcase strings)))) - -#-allegro -(defmacro until (test &body body) - `(LOOP (WHEN ,test (RETURN)) ,@body)) - -#-allegro -(defmacro while (test &body body) - `(LOOP (unless ,test (RETURN)) ,@body)) - -(defmacro bwhen ((bindvar boundform) &body body) - `(let ((,bindvar ,boundform)) - (when ,bindvar - ,@body))) - -(defmacro bif ((bindvar boundform) yup &optional nope) - `(let ((,bindvar ,boundform)) - (if ,bindvar - ,yup - ,nope))) - -(defmacro maptimes ((nvar count) &body body) - `(loop for ,nvar below ,count - collecting (progn ,@body))) - -; --- cloucell support for struct access of slots ------------------------ - -(eval-when (:compile-toplevel :execute :load-toplevel) - (export '(cc-defstruct instance-slots))) - -(defmacro cc-defstruct (header &rest slots) - (let (name concname (cache (gensym))) - (if (consp header) - (destructuring-bind (hname &rest options) - header - (setf name hname) - (setf concname (bIf (concoption (find :conc-name options :key #'car)) - (unless (eql (second concoption) 'nil) - (second concoption)) - (intern (concatenate 'string - (symbol-name hname) - "-"))))) - (progn - (setf name header) - (setf concname (intern (concatenate 'string - (symbol-name header) "-"))))) - - (let ((cc-info (mapcar (lambda (s) - (let ((sn (if (consp s) - (car s) s))) - (cons sn - (intern (concatenate 'string - (when concname (symbol-name concname)) - (symbol-name sn)))))) - slots))) - `(progn - (defstruct ,header ,@slots) - (let (,cache) - (defmethod instance-slots ((self ,name)) - (or ,cache (setf ,cache (append (call-next-method) ',cc-info))))) - )))) - -(defmethod instance-slots (root) - (declare (ignorable root))) - +;; -*- 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) + +(defmacro maxf (place &rest othervalues) + `(setf ,place (max ,place ,@othervalues))) + +(defun last1 (thing) + (car (last thing))) + +(defun max-if (&rest values) + (loop for x in values when x maximize x)) + +(defun min-max-of (v1 v2) + (values (min-if v1 v2) (max-if v1 v2))) + +(defun min-if (v1 v2) + (if v1 (if v2 (min v1 v2) v1) v2)) + +(defun list-flatten! (&rest list) + (if (consp list) + (let (head work visited) + (labels ((link (cell) + ;;(format t "~&Link > cons: ~s . ~s" (car cell) (cdr cell)) + (when (and (consp cell) + (member cell visited)) + (break "list-flatten! detects infinite list: cell ~a, visited ~a" cell visited)) + (push cell visited) + + (when cell + (if (consp (car cell)) + (link (car cell)) + (progn + (setf head (or head cell)) + (when work + (rplacd work cell)) + (setf work cell))) + (link (rest cell))))) + (link list)) + head) + list)) + +(defun packed-flat! (&rest uNameit) + (delete-if #'null (list-flatten! uNameIt))) + +(defmacro with-dynamic-fn ((fnName (&rest fnArgs) &body fnBody) &body body) + `(let ((,fnName (lambda ,fnArgs ,@fnBody))) + (declare (dynamic-extent ,fnname)) + ,@body)) + +(defvar *c-break*) + +(defun c-break (&rest args) + (unless (or *c-break* *stop*) + (setf *c-break* t) + (c-stop args) + (format t "c-break > stopping > ~a" args) + (apply #'break args))) + +(defmacro assocv-setf (assoc-place sym-form v-form) + (let ((sym (gensym))(entry (gensym))(v (gensym))) + `(let* ((,sym ,sym-form) + (,v ,v-form)) + (bIf (,entry (assoc ,sym ,assoc-place)) + (rplacd ,entry ,v) + (push (cons ,sym ,v) ,assoc-place)) + ,v))) + +(defun intern$ (&rest strings) + (intern (apply #'concatenate 'string (mapcar #'string-upcase strings)))) + +#-allegro +(defmacro until (test &body body) + `(LOOP (WHEN ,test (RETURN)) ,@body)) + +#-allegro +(defmacro while (test &body body) + `(LOOP (unless ,test (RETURN)) ,@body)) + +(defmacro bwhen ((bindvar boundform) &body body) + `(let ((,bindvar ,boundform)) + (when ,bindvar + ,@body))) + +(defmacro bif ((bindvar boundform) yup &optional nope) + `(let ((,bindvar ,boundform)) + (if ,bindvar + ,yup + ,nope))) + +(defmacro maptimes ((nvar count) &body body) + `(loop for ,nvar below ,count + collecting (progn ,@body))) + +; --- cloucell support for struct access of slots ------------------------ + +(eval-when (:compile-toplevel :execute :load-toplevel) + (export '(cc-defstruct instance-slots))) + +(defmacro cc-defstruct (header &rest slots) + (let (name concname (cache (gensym))) + (if (consp header) + (destructuring-bind (hname &rest options) + header + (setf name hname) + (setf concname (bIf (concoption (find :conc-name options :key #'car)) + (unless (eql (second concoption) 'nil) + (second concoption)) + (intern (concatenate 'string + (symbol-name hname) + "-"))))) + (progn + (setf name header) + (setf concname (intern (concatenate 'string + (symbol-name header) "-"))))) + + (let ((cc-info (mapcar (lambda (s) + (let ((sn (if (consp s) + (car s) s))) + (cons sn + (intern (concatenate 'string + (when concname (symbol-name concname)) + (symbol-name sn)))))) + slots))) + `(progn + (defstruct ,header ,@slots) + (let (,cache) + (defmethod instance-slots ((self ,name)) + (or ,cache (setf ,cache (append (call-next-method) ',cc-info))))) + )))) + +(defmethod instance-slots (root) + (declare (ignorable root))) + Index: cells/fm-utilities.lisp diff -u cells/fm-utilities.lisp:1.1.1.1 cells/fm-utilities.lisp:1.2 --- cells/fm-utilities.lisp:1.1.1.1 Sat Nov 8 18:44:17 2003 +++ cells/fm-utilities.lisp Tue Dec 16 10:02:58 2003 @@ -1,557 +1,557 @@ -;; -*- 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) - -(defparameter *fmdbg* nil) - -(eval-when (compile eval load) - (export '(make-part mkpart fm-other fm-traverse fm-descendant-typed do-like-fm-parts - container-typed *fmdbg*))) - -(defun make-part (partname partclass &rest initargs) - ;;(trc "make-part > name class" partname partclass) - (when partclass ;;a little programmer friendliness - (apply #'make-instance partclass :md-name partname initargs))) - -(defmacro mkpart (md-name (mdclass) &rest initargs) - `(make-part ',md-name ',mdclass ,@initargs)) - -(defmethod make-partspec ((partclass symbol)) - (make-part partclass partclass)) - -(defmethod make-partspec ((part model)) - part) - -(defmacro upper (self &optional (type t)) - `(container-typed ,self ',type)) - -(defmethod container (self) (fmparent self)) - -(defmethod container-typed ((self model-object) type) - (assert self) - (let ((parent (container self))) ;; fm- or ps-parent - (cond - ((null parent) nil) - ((typep parent type) parent) - (t (container-typed parent type))))) - -(defun fm-descendant-typed (self type) - (when self - (or (find-if (lambda (k) (typep k type)) (kids self)) - (some (lambda (k) - (fm-descendant-typed k type)) (kids self))))) - -(defun fm-descendant-named (parent name &key (must-find t)) - (fm-find-one parent name :must-find must-find :global-search nil)) - -(defun fm-ascendant-named (parent name) - (when parent - (or (when (eql (md-name parent) name) - parent) - (fm-ascendant-named (fmparent parent) name)))) - -(defun fm-ascendant-typed (parent name) - (when parent - (or (when (typep parent name) - parent) - (fm-ascendant-typed (fmparent parent) name)))) - -(defun fm-ascendant-some (parent somefunction) - (when (and parent somefunction) - (or (funcall somefunction parent) - (fm-ascendant-some (fmparent parent) somefunction)))) - -(defun fm-ascendant-if (self iffunction) - (when (and self iffunction) - (or (when (funcall iffunction self) - self) - (fm-ascendant-if .parent iffunction)))) - -(defun fm-ascendant-common (d1 d2) - (fm-ascendant-some d1 (lambda (node) - (when (fm-includes node d2) - node)))) - -(defun fm-collect-if (tree test) - (let (collection) - (fm-traverse tree (lambda (node) - (when (funcall test node) - (push node collection)))) - (nreverse collection))) - -(defun fm-max (tree key) - (let (max) - (fm-traverse tree (lambda (node) - (if max - (setf max (max max (funcall key node))) - (setf max (funcall key node)))) - :global-search nil) - max)) - - -(defun fm-traverse (family applied-fn &key skipnode skiptree (global-search t) (opaque nil)) - (progn ;; wtrc (0 1600 "fm-traverse2" family) - (labels ((tv-family (fm skippee) - (when *fmdbg* (trc "tv-family" fm)) - - (when (and (typep fm 'model-object) - (not (eql fm skippee))) - (let ((outcome (unless (eql skipnode fm) - (funcall applied-fn fm)))) - (unless (and outcome opaque) - (dolist (kid (sub-nodes fm)) - (tv-family kid nil))))) - (when (and (typep fm 'model-object) - (not (eql fm skippee))) - (let ((outcome (and (not (eql skipnode fm)) - (funcall applied-fn fm)))) - (unless (and outcome opaque) - (dolist (kid (sub-nodes fm)) - (tv-family kid nil))))))) - - (loop for fm = family then (when global-search (fmparent fm)) - and skip = skiptree then fm - unless fm return nil - do (when *fmdbg* (print `(fm-traverse using :fm , fm :skip ,skip))) - (tv-family fm skip))))) - -(defmethod sub-nodes (other) - (declare (ignore other))) - -(defmethod sub-nodes ((self family)) - (kids self)) - -(defmethod fm-ps-parent ((self model-object)) - (fmparent self)) - -(defmacro with-like-fm-parts ((partsvar (self likeclass)) &body body) - `(let (,partsvar) - (fm-traverse ,self (lambda (node) - ;;(trc "with like sees node" node (type-of node) ',likeclass) - (when (typep node ',likeclass) - (push node ,partsvar))) - :skipnode ,self - :global-search nil - :opaque t) - (setf ,partsvar (nreverse ,partsvar)) - (progn ,@body))) - -(defmacro do-like-fm-parts ((partvar (self likeclass) &optional returnvar) &body body) - `(progn - (fm-traverse ,self (lambda (,partvar) - (when (typep ,partvar ',likeclass) - ,@body)) - :skipnode ,self - :global-search nil - :opaque t) - ,returnvar) - ) - -;; -;; family member finding -;; - -#| - (defun fm-member-named (kidname kids) - (member kidname kids :key #'md-name)) - |# - -(defun true-that (that) (declare (ignore that)) t) -;; -;; eventually fm-find-all needs a better name (as does fm-collect) and they -;; should be modified to go through 'gather', which should be the real fm-find-all -;; -(defun fm-gather (family &key (test #'true-that)) - (packed-flat! - (cons (when (funcall test family) family) - (mapcar (lambda (fm) - (fm-gather fm :test test)) - (kids family))))) - -(defun fm-find-all (family md-name &key (must-find t) (global-search t)) - (let ((matches (catch 'fm-find-all - (with-dynamic-fn - (traveller (family) - (with-dynamic-fn - (filter (kid) (eql md-name (md-name kid))) - (let ((matches (remove-if-not filter (kids family)))) - (when matches - (throw 'fm-find-all matches))))) - (fm-traverse family traveller :global-search global-search))))) - (when (and must-find (null matches)) - (setf *stop* t) - (break "fm-find-all > *stop*ping...did not find ~a ~a ~a" family md-name global-search) - ;; (error 'fm-not-found (list md-name family global-search)) - ) - matches)) - -(defun fm-find-next (fm test-fn) - (fm-find-next-within fm test-fn)) - -(defun fm-find-next-within (fm test-fn &optional upperbound &aux (fmparent (unless (eql upperbound fm) - (fmparent fm)))) - (let ((sibs (and fmparent (rest (member fm (kids fmparent)))))) - (or (dolist (s sibs) - (let ((winner (fm-find-if s test-fn))) - (when winner (return winner)))) - (if fmparent - (fm-find-next-within fmparent test-fn upperbound) - (fm-find-if fm test-fn))))) - -(defun fm-find-prior (fm test-fn) - (fm-find-prior-within fm test-fn)) - -(defun fm-find-prior-within (fm test-fn &optional upperbound &aux (fmparent (unless (eql upperbound fm) - (fmparent fm)))) - (let ((sibs (and fmparent (kids fmparent)))) - (or (loop with next-ok - for s on sibs - for last-ok = nil then (or next-ok last-ok) - when (eql fm (first s)) do (loop-finish) - finally (return last-ok) - do (setf next-ok (fm-find-last-if (car s) test-fn))) - (if fmparent - (fm-find-prior-within fmparent test-fn upperbound) - (fm-find-last-if fm test-fn))))) - - (defun fm-find-last-if (family test-fn) - (let ((last)) - (or (and (kids family) - (dolist (k (kids family) last) - (setf last (or (fm-find-last-if k test-fn) last)))) - (when (funcall test-fn family) - family)))) - -(defun fm-prior-sib (self &optional (test-fn #'true-that) - &aux (kids (kids (fmparent self)))) - "Find nearest preceding sibling passing TEST-FN" - (find-if test-fn kids :end (position self kids) :from-end t)) - -(defun fm-next-sib-if (self test-fn) - (some test-fn (cdr (member self (kids (fmparent self)))))) - -(defun fm-next-sib (self) - (car (cdr (member self (kids (fmparent self)))))) - -(defmacro ^fm-next-sib (&optional (self 'self)) - (let ((s (gensym))) - `(let ((,s ,self)) - (car (cdr (member ,s (^kids (fmparent ,s)))))))) - -(defun find-prior (self sibs &key (test #'true-that)) - (assert (member self sibs)) ;; got this by accidentally having toolbar kids dependent..on second calc, - ;; all newkids got over, and when old kids tried to recalculate...not in sibs!! - (unless (eql self (car sibs)) - (labels - ((fpsib (rsibs &aux (psib (car rsibs))) - (assert rsibs () "~&find-prior > fpsib > self ~s not found to prior off" self) - (if (eql self (cadr rsibs)) - (when (funcall test psib) psib) - (or (fpsib (cdr rsibs)) - (when (funcall test psib) psib))))) - (fpsib sibs)))) - -(defun fm-find-if (family test-fn &key skiptopp) ;; 99-03 kt why is thsi depth-first? - (assert test-fn) - (when family - (or (dolist (b (sub-nodes family)) - (let ((match (fm-find-if b test-fn))) - (when match (return match)))) - (when (and (not skiptopp) - (funcall test-fn family)) - family)))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; -;;;; family ordering -;;;; -(defun fm-kid-add (fmparent kid &optional before) - (assert (or (null (fmparent kid)) (eql fmparent (fmparent kid)))) - (assert (typep fmparent 'family)) - (setf (fmparent kid) fmparent) - (fm-kid-insert kid before)) - -(defun fm-kid-insert-last (goal &aux (fmparent (fmparent goal))) - (setf (kids fmparent) (nconc (kids fmparent) (list goal)))) - -(defun fm-kid-insert-first (goal &aux (fmparent (fmparent goal))) - (setf (kids fmparent) (cons goal (kids fmparent)))) - -(defun fm-kid-insert (kid &optional before &aux (dakids (kids (fmparent kid)))) - (assert (or (null before) (eql (fmparent kid) (fmparent before)))) - (setf (kids (fmparent kid)) - (if before - (if (eql before (car dakids)) - (cons kid dakids) - (let ((cell (member before dakids))) - (rplaca cell kid) - (rplacd cell (cons before (cdr cell))) - (cons (car dakids) (rest dakids)))) - (if dakids - (progn - (rplacd (last dakids) (cons kid nil)) - (cons (car dakids) (rest dakids))) - (cons kid dakids))))) - -(defun fm-kid-remove (kid &key (quiesce t) &aux (parent (fmparent kid))) - (when quiesce - (fm-quiesce-all kid)) - (when parent - (setf (kids parent) (remove kid (kids parent))) - ;; (setf (fmparent kid) nil) gratuitous housekeeping caused ensuing focus echo - ;; image-invalidate to fail since no access to containing window via fmparent chain - )) - -(defun fm-quiesce-all (md) - (md-quiesce md) - (dolist (kid (kids md)) - (when (and kid (not (md-untouchable kid))) - (fm-quiesce-all kid))) - md) - - -(defun fm-kid-replace (oldkid newkid &aux (fmparent (fmparent oldkid))) - (assert (member oldkid (kids fmparent)) () - "~&oldkid ~s not amongst kids of its fmparent ~s" - oldkid fmparent) - (when fmparent ;; silly test given above assert--which is right? - (assert (typep fmparent 'family)) - (setf (fmparent newkid) fmparent) - (setf (kids fmparent) (substitute newkid oldkid (kids fmparent))) - ;;(rplaca (member oldkid (kids fmparent)) newkid) - newkid)) - -;---------------------------------------------------------- -;; -;; h i g h - o r d e r f a m i l y o p s -;; -;; currently not in use...someday? -(defmacro ^fm-min-max-kid (min-max slot-name &key (default 0) test (fmparent 'self)) - (let ((best (copy-symbol 'best)) - (kid (copy-symbol 'kid)) - ) - `(let ((,best ,default)) - (dolist (,kid (^kids ,fmparent) ,best) - ,(if test - `(when (funcall ,test ,kid) - (setf ,best (funcall ,min-max ,best (,slot-name ,kid)))) - `(bif (slotvalue (,slot-name ,kid)) - (setf ,best (funcall ,min-max ,best slotvalue)) - (break "nil slotvalue ~a in kid ~a of parent ~a" - ',slot-name ,kid ,fmparent))))))) - -(defmacro ^fm-min-kid (slot-name &key (default 0) test (fmparent 'self)) - `(^fm-min-max-kid #'min-if ,slot-name - :default ,default - :test ,test - :fmparent ,fmparent)) - -(defmacro ^fm-max-kid (slot-name &key (default 0) test (fmparent 'self)) - `(^fm-min-max-kid #'max-if ,slot-name - :default ,default - :test ,test - :fmparent ,fmparent)) - -(defmacro ^fm-max-sib (slot-name &key (default 0) test) - `(^fm-max-kid ,slot-name :default ,default - :test ,test - :fmparent (fmparent self))) - -(defmacro ^fm-max-sib-other (slot-name &key (default 0)) - `(with-dynamic-fn (tester (sib) (not (eql self sib))) - (^fm-max-kid ,slot-name :default ,default - :test tester - :fmparent (fmparent self)))) - -(defmacro ^sib-named (name) - `(find ,name (^kids (fmparent self)) :key #'md-name)) - - -(defmacro fm-other (md-name &key (starting 'self) skiptree (test '#'true-that)) - `(fm-find-one ,starting ,(if (consp md-name) - `(list ',(car md-name) ,(cadr md-name)) - `',md-name) - :must-find t - :skiptree ,skiptree - :global-search t - :test ,test)) - -(defmacro fm-otherx (md-name &key (starting 'self) skiptree) - (if (eql starting 'self) - `(or (fm-find-one ,starting ,(if (consp md-name) - `(list ',(car md-name) ,(cadr md-name)) - `',md-name) - :must-find t - :skiptree ,skiptree - :global-search t)) - `(fm-find-one ,starting ,(if (consp md-name) - `(list ',(car md-name) ,(cadr md-name)) - `',md-name) - :must-find t - :skiptree ,skiptree - :global-search t))) - -(defun fm-other-v (md-name starting &optional (global-search t)) - (break) - (fm-find-one starting md-name - :must-find nil - :global-search global-search)) - -(defmacro fm-otherv? (md-name &optional (starting 'self) (global-search t)) - `(fm-other-v ,md-name ,starting ,global-search)) - -(defmacro fm-other? (md-name &optional (starting 'self) (global-search t)) - `(fm-find-one ,starting ,(if (consp md-name) - `(list ',(car md-name) ,(cadr md-name)) - `',md-name) - :must-find nil - :global-search ,global-search)) - -(defun fm! (starting md-name &optional (global-search t)) - (fm-find-one starting md-name - :must-find t - :global-search global-search)) - -(defmacro fm? (md-name &optional (starting 'self) (global-search t)) - `(fm-find-one ,starting ,(if (consp md-name) - `(list ',(car md-name) ,(cadr md-name)) - `',md-name) - :must-find nil - :global-search ,global-search)) - -(defmacro fm-other! (md-name &optional (starting 'self)) - `(fm-find-one ,starting ,(if (consp md-name) - `(list ',(car md-name) ,(cadr md-name)) - `',md-name) - :must-find t - :global-search nil)) - -(defmacro fm-other?! (md-name &optional (starting 'self)) - `(fm-find-one ,starting ,(if (consp md-name) - `(list ',(car md-name) ,(cadr md-name)) - `',md-name) - :must-find nil - :global-search nil)) - -(defmacro fm-collect (md-name &key (must-find t)) - `(fm-find-all self ',md-name :must-find ,must-find)) ;deliberate capture - -(defmacro fm-map (fn md-name) - `(mapcar ,fn (fm-find-all self ',md-name))) ;deliberate capture - -(defmacro fm-mapc (fn md-name) - `(mapc ,fn (fm-find-all self ',md-name))) ;deliberate capture - -(defun fm-pos (goal &aux (fmparent (fmparent goal))) - (when fmparent - (or (position goal (kids fmparent)) - (length (kids fmparent))))) ;; ?!! - -(defmacro fm-count-named (family md-name &key (global-search t)) - `(length (fm-find-all ,family ,md-name - :must-find nil - :global-search ,global-search))) -;--------------------------------------------------------------- - -(defun fm-top (fm &optional (test #'true-that) &aux (fmparent (fmparent fm))) - (cond ((null fmparent) fm) - ((not (funcall test fmparent)) fm) - (t (fm-top fmparent test)))) - -(defun fm-first-above (fm &key (test #'true-that) &aux (fmparent (fmparent fm))) - (cond ((null fmparent) nil) - ((funcall test fmparent) fmparent) - (t (fm-first-above fmparent :test test)))) - -(defun fm-nearest-if (test fm) - (when fm - (if (funcall test fm) - fm - (fm-nearest-if test (fmparent fm))))) - -(defun fm-includes (fm sought) - (fm-ancestorp fm sought)) - -(defun fm-ancestorp (fm sought) - (assert fm) - (when sought - (or (eql fm sought) - (fm-includes fm (fmparent sought))))) - -(defun fm-kid-containing (fmparent descendant) - (with-dynamic-fn (finder (node) (not (eql fmparent node))) - (fm-top descendant finder))) - -(defun make-name (root &optional subscript) - (if subscript (list root subscript) root)) - -(defun name-root (md-name) - (if (atom md-name) md-name (car md-name))) - -(defun name-subscript (md-name) - (when (consp md-name) (cadr md-name))) - -(defun fm-find-one (family md-name &key (must-find t) - (global-search t) skiptree (test #'true-that)) - (flet ((matcher (fm) - (trc nil "fm-find-one matcher sees" md-name fm (md-name fm)) - (when (and (eql (name-root md-name) - (or (md-name fm) (c-class-name (class-of fm)))) - (or (null (name-subscript md-name)) - (eql (name-subscript md-name) (fm-pos fm))) - (funcall test fm)) - (throw 'fm-find-one fm)))) - #-lispworks (declare (dynamic-extent matcher)) - (trc nil "fm-find-one> entry " md-name family) - (let ((match (catch 'fm-find-one - (fm-traverse family #'matcher - :skiptree skiptree - :global-search global-search)))) - (when (and must-find (null match)) - (trc nil "fm-find-one > erroring fm-not-found" family md-name must-find global-search) - ;;(inspect family) - (let ((*fmdbg* family)) - (fm-find-one family md-name :must-find nil :global-search global-search) - (setf *stop* t) - ;;(trc "fm-find-one > *stop*ping...did not find" family md-name global-search) - (break "fm-find-one > *stop*ping...did not find ~a ~a ~a" family md-name global-search) - - )) - match))) - -(defun fm-find-kid (self name) - (find name (kids self) :key #'md-name)) - -(defun fm-kid-typed (self type) - (assert self) - (find type (kids self) :key #'type-of)) - -(defun kidno (self) - (unless (typep self 'model-object) - (break "not a model object ~a" self)) - (when (and self (fmparent self)) - (assert (member self (kids (fmparent self)))) - (position self (kids (fmparent self))))) - - +;; -*- 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) + +(defparameter *fmdbg* nil) + +(eval-when (compile eval load) + (export '(make-part mkpart fm-other fm-traverse fm-descendant-typed do-like-fm-parts + container-typed *fmdbg*))) + +(defun make-part (partname partclass &rest initargs) + ;;(trc "make-part > name class" partname partclass) + (when partclass ;;a little programmer friendliness + (apply #'make-instance partclass :md-name partname initargs))) + +(defmacro mkpart (md-name (mdclass) &rest initargs) + `(make-part ',md-name ',mdclass ,@initargs)) + +(defmethod make-partspec ((partclass symbol)) + (make-part partclass partclass)) + +(defmethod make-partspec ((part model)) + part) + +(defmacro upper (self &optional (type t)) + `(container-typed ,self ',type)) + +(defmethod container (self) (fm-parent self)) + +(defmethod container-typed ((self model-object) type) + (c-assert self) + (let ((parent (container self))) ;; fm- or ps-parent + (cond + ((null parent) nil) + ((typep parent type) parent) + (t (container-typed parent type))))) + +(defun fm-descendant-typed (self type) + (when self + (or (find-if (lambda (k) (typep k type)) (kids self)) + (some (lambda (k) + (fm-descendant-typed k type)) (kids self))))) + +(defun fm-descendant-named (parent name &key (must-find t)) + (fm-find-one parent name :must-find must-find :global-search nil)) + +(defun fm-ascendant-named (parent name) + (when parent + (or (when (eql (md-name parent) name) + parent) + (fm-ascendant-named (fm-parent parent) name)))) + +(defun fm-ascendant-typed (parent name) + (when parent + (or (when (typep parent name) + parent) + (fm-ascendant-typed (fm-parent parent) name)))) + +(defun fm-ascendant-some (parent somefunction) + (when (and parent somefunction) + (or (funcall somefunction parent) + (fm-ascendant-some (fm-parent parent) somefunction)))) + +(defun fm-ascendant-if (self iffunction) + (when (and self iffunction) + (or (when (funcall iffunction self) + self) + (fm-ascendant-if .parent iffunction)))) + +(defun fm-ascendant-common (d1 d2) + (fm-ascendant-some d1 (lambda (node) + (when (fm-includes node d2) + node)))) + +(defun fm-collect-if (tree test) + (let (collection) + (fm-traverse tree (lambda (node) + (when (funcall test node) + (push node collection)))) + (nreverse collection))) + +(defun fm-max (tree key) + (let (max) + (fm-traverse tree (lambda (node) + (if max + (setf max (max max (funcall key node))) + (setf max (funcall key node)))) + :global-search nil) + max)) + + +(defun fm-traverse (family applied-fn &key skipnode skiptree (global-search t) (opaque nil)) + (progn ;; wtrc (0 1600 "fm-traverse2" family) + (labels ((tv-family (fm skippee) + (when *fmdbg* (trc "tv-family" fm)) + + (when (and (typep fm 'model-object) + (not (eql fm skippee))) + (let ((outcome (unless (eql skipnode fm) + (funcall applied-fn fm)))) + (unless (and outcome opaque) + (dolist (kid (sub-nodes fm)) + (tv-family kid nil))))) + (when (and (typep fm 'model-object) + (not (eql fm skippee))) + (let ((outcome (and (not (eql skipnode fm)) + (funcall applied-fn fm)))) + (unless (and outcome opaque) + (dolist (kid (sub-nodes fm)) + (tv-family kid nil))))))) + + (loop for fm = family then (when global-search (fm-parent fm)) + and skip = skiptree then fm + unless fm return nil + do (when *fmdbg* (print `(fm-traverse using :fm , fm :skip ,skip))) + (tv-family fm skip))))) + +(defmethod sub-nodes (other) + (declare (ignore other))) + +(defmethod sub-nodes ((self family)) + (kids self)) + +(defmethod fm-ps-parent ((self model-object)) + (fm-parent self)) + +(defmacro with-like-fm-parts ((partsvar (self likeclass)) &body body) + `(let (,partsvar) + (fm-traverse ,self (lambda (node) + ;;(trc "with like sees node" node (type-of node) ',likeclass) + (when (typep node ',likeclass) + (push node ,partsvar))) + :skipnode ,self + :global-search nil + :opaque t) + (setf ,partsvar (nreverse ,partsvar)) + (progn ,@body))) + +(defmacro do-like-fm-parts ((partvar (self likeclass) &optional returnvar) &body body) + `(progn + (fm-traverse ,self (lambda (,partvar) + (when (typep ,partvar ',likeclass) + ,@body)) + :skipnode ,self + :global-search nil + :opaque t) + ,returnvar) + ) + +;; +;; family member finding +;; + +#| + (defun fm-member-named (kidname kids) + (member kidname kids :key #'md-name)) + |# + +(defun true-that (that) (declare (ignore that)) t) +;; +;; eventually fm-find-all needs a better name (as does fm-collect) and they +;; should be modified to go through 'gather', which should be the real fm-find-all +;; +(defun fm-gather (family &key (test #'true-that)) + (packed-flat! + (cons (when (funcall test family) family) + (mapcar (lambda (fm) + (fm-gather fm :test test)) + (kids family))))) + +(defun fm-find-all (family md-name &key (must-find t) (global-search t)) + (let ((matches (catch 'fm-find-all + (with-dynamic-fn + (traveller (family) + (with-dynamic-fn + (filter (kid) (eql md-name (md-name kid))) + (let ((matches (remove-if-not filter (kids family)))) + (when matches + (throw 'fm-find-all matches))))) + (fm-traverse family traveller :global-search global-search))))) + (when (and must-find (null matches)) + (setf *stop* t) + (break "fm-find-all > *stop*ping...did not find ~a ~a ~a" family md-name global-search) + ;; (error 'fm-not-found (list md-name family global-search)) + ) + matches)) + +(defun fm-find-next (fm test-fn) + (fm-find-next-within fm test-fn)) + +(defun fm-find-next-within (fm test-fn &optional upperbound &aux (fm-parent (unless (eql upperbound fm) + (fm-parent fm)))) + (let ((sibs (and fm-parent (rest (member fm (kids fm-parent)))))) + (or (dolist (s sibs) + (let ((winner (fm-find-if s test-fn))) + (when winner (return winner)))) + (if fm-parent + (fm-find-next-within fm-parent test-fn upperbound) + (fm-find-if fm test-fn))))) + +(defun fm-find-prior (fm test-fn) + (fm-find-prior-within fm test-fn)) + +(defun fm-find-prior-within (fm test-fn &optional upperbound &aux (fm-parent (unless (eql upperbound fm) + (fm-parent fm)))) + (let ((sibs (and fm-parent (kids fm-parent)))) + (or (loop with next-ok + for s on sibs + for last-ok = nil then (or next-ok last-ok) + when (eql fm (first s)) do (loop-finish) + finally (return last-ok) + do (setf next-ok (fm-find-last-if (car s) test-fn))) + (if fm-parent + (fm-find-prior-within fm-parent test-fn upperbound) + (fm-find-last-if fm test-fn))))) + + (defun fm-find-last-if (family test-fn) + (let ((last)) + (or (and (kids family) + (dolist (k (kids family) last) + (setf last (or (fm-find-last-if k test-fn) last)))) + (when (funcall test-fn family) + family)))) + +(defun fm-prior-sib (self &optional (test-fn #'true-that) + &aux (kids (kids (fm-parent self)))) + "Find nearest preceding sibling passing TEST-FN" + (find-if test-fn kids :end (position self kids) :from-end t)) + +(defun fm-next-sib-if (self test-fn) + (some test-fn (cdr (member self (kids (fm-parent self)))))) + +(defun fm-next-sib (self) + (car (cdr (member self (kids (fm-parent self)))))) + +(defmacro ^fm-next-sib (&optional (self 'self)) + (let ((s (gensym))) + `(let ((,s ,self)) + (car (cdr (member ,s (^kids (fm-parent ,s)))))))) + +(defun find-prior (self sibs &key (test #'true-that)) + (c-assert (member self sibs)) ;; got this by accidentally having toolbar kids dependent..on second calc, + ;; all newkids got over, and when old kids tried to recalculate...not in sibs!! + (unless (eql self (car sibs)) + (labels + ((fpsib (rsibs &aux (psib (car rsibs))) + (c-assert rsibs () "~&find-prior > fpsib > self ~s not found to prior off" self) + (if (eql self (cadr rsibs)) + (when (funcall test psib) psib) + (or (fpsib (cdr rsibs)) + (when (funcall test psib) psib))))) + (fpsib sibs)))) + +(defun fm-find-if (family test-fn &key skiptopp) ;; 99-03 kt why is thsi depth-first? + (c-assert test-fn) + (when family + (or (dolist (b (sub-nodes family)) + (let ((match (fm-find-if b test-fn))) + (when match (return match)))) + (when (and (not skiptopp) + (funcall test-fn family)) + family)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; +;;;; family ordering +;;;; +(defun fm-kid-add (fm-parent kid &optional before) + (c-assert (or (null (fm-parent kid)) (eql fm-parent (fm-parent kid)))) + (c-assert (typep fm-parent 'family)) + (setf (fm-parent kid) fm-parent) + (fm-kid-insert kid before)) + +(defun fm-kid-insert-last (goal &aux (fm-parent (fm-parent goal))) + (setf (kids fm-parent) (nconc (kids fm-parent) (list goal)))) + +(defun fm-kid-insert-first (goal &aux (fm-parent (fm-parent goal))) + (setf (kids fm-parent) (cons goal (kids fm-parent)))) + +(defun fm-kid-insert (kid &optional before &aux (dakids (kids (fm-parent kid)))) + (c-assert (or (null before) (eql (fm-parent kid) (fm-parent before)))) + (setf (kids (fm-parent kid)) + (if before + (if (eql before (car dakids)) + (cons kid dakids) + (let ((cell (member before dakids))) + (rplaca cell kid) + (rplacd cell (cons before (cdr cell))) + (cons (car dakids) (rest dakids)))) + (if dakids + (progn + (rplacd (last dakids) (cons kid nil)) + (cons (car dakids) (rest dakids))) + (cons kid dakids))))) + +(defun fm-kid-remove (kid &key (quiesce t) &aux (parent (fm-parent kid))) + (when quiesce + (fm-quiesce-all kid)) + (when parent + (setf (kids parent) (remove kid (kids parent))) + ;; (setf (fm-parent kid) nil) gratuitous housekeeping caused ensuing focus echo + ;; image-invalidate to fail since no access to containing window via fm-parent chain + )) + +(defun fm-quiesce-all (md) + (md-quiesce md) + (dolist (kid (kids md)) + (when (and kid (not (md-untouchable kid))) + (fm-quiesce-all kid))) + md) + + +(defun fm-kid-replace (oldkid newkid &aux (fm-parent (fm-parent oldkid))) + (c-assert (member oldkid (kids fm-parent)) () + "~&oldkid ~s not amongst kids of its fm-parent ~s" + oldkid fm-parent) + (when fm-parent ;; silly test given above assert--which is right? + (c-assert (typep fm-parent 'family)) + (setf (fm-parent newkid) fm-parent) + (setf (kids fm-parent) (substitute newkid oldkid (kids fm-parent))) + ;;(rplaca (member oldkid (kids fm-parent)) newkid) + newkid)) + +;---------------------------------------------------------- +;; +;; h i g h - o r d e r f a m i l y o p s +;; +;; currently not in use...someday? +(defmacro ^fm-min-max-kid (min-max slot-name &key (default 0) test (fm-parent 'self)) + (let ((best (copy-symbol 'best)) + (kid (copy-symbol 'kid)) + ) + `(let ((,best ,default)) + (dolist (,kid (^kids ,fm-parent) ,best) + ,(if test + `(when (funcall ,test ,kid) + (setf ,best (funcall ,min-max ,best (,slot-name ,kid)))) + `(bif (slotvalue (,slot-name ,kid)) + (setf ,best (funcall ,min-max ,best slotvalue)) + (break "nil slotvalue ~a in kid ~a of parent ~a" + ',slot-name ,kid ,fm-parent))))))) + +(defmacro ^fm-min-kid (slot-name &key (default 0) test (fm-parent 'self)) + `(^fm-min-max-kid #'min-if ,slot-name + :default ,default + :test ,test + :fm-parent ,fm-parent)) + +(defmacro ^fm-max-kid (slot-name &key (default 0) test (fm-parent 'self)) + `(^fm-min-max-kid #'max-if ,slot-name + :default ,default + :test ,test + :fm-parent ,fm-parent)) + +(defmacro ^fm-max-sib (slot-name &key (default 0) test) + `(^fm-max-kid ,slot-name :default ,default + :test ,test + :fm-parent (fm-parent self))) + +(defmacro ^fm-max-sib-other (slot-name &key (default 0)) + `(with-dynamic-fn (tester (sib) (not (eql self sib))) + (^fm-max-kid ,slot-name :default ,default + :test tester + :fm-parent (fm-parent self)))) + +(defmacro ^sib-named (name) + `(find ,name (^kids (fm-parent self)) :key #'md-name)) + + +(defmacro fm-other (md-name &key (starting 'self) skiptree (test '#'true-that)) + `(fm-find-one ,starting ,(if (consp md-name) + `(list ',(car md-name) ,(cadr md-name)) + `',md-name) + :must-find t + :skiptree ,skiptree + :global-search t + :test ,test)) + +(defmacro fm-otherx (md-name &key (starting 'self) skiptree) + (if (eql starting 'self) + `(or (fm-find-one ,starting ,(if (consp md-name) + `(list ',(car md-name) ,(cadr md-name)) + `',md-name) + :must-find t + :skiptree ,skiptree + :global-search t)) + `(fm-find-one ,starting ,(if (consp md-name) + `(list ',(car md-name) ,(cadr md-name)) + `',md-name) + :must-find t + :skiptree ,skiptree + :global-search t))) + +(defun fm-other-v (md-name starting &optional (global-search t)) + (break) + (fm-find-one starting md-name + :must-find nil + :global-search global-search)) + +(defmacro fm-otherv? (md-name &optional (starting 'self) (global-search t)) + `(fm-other-v ,md-name ,starting ,global-search)) + +(defmacro fm-other? (md-name &optional (starting 'self) (global-search t)) + `(fm-find-one ,starting ,(if (consp md-name) + `(list ',(car md-name) ,(cadr md-name)) + `',md-name) + :must-find nil + :global-search ,global-search)) + +(defun fm! (starting md-name &optional (global-search t)) + (fm-find-one starting md-name + :must-find t + :global-search global-search)) + +(defmacro fm? (md-name &optional (starting 'self) (global-search t)) + `(fm-find-one ,starting ,(if (consp md-name) + `(list ',(car md-name) ,(cadr md-name)) + `',md-name) + :must-find nil + :global-search ,global-search)) + +(defmacro fm-other! (md-name &optional (starting 'self)) + `(fm-find-one ,starting ,(if (consp md-name) + `(list ',(car md-name) ,(cadr md-name)) + `',md-name) + :must-find t + :global-search nil)) + +(defmacro fm-other?! (md-name &optional (starting 'self)) + `(fm-find-one ,starting ,(if (consp md-name) + `(list ',(car md-name) ,(cadr md-name)) + `',md-name) + :must-find nil + :global-search nil)) + +(defmacro fm-collect (md-name &key (must-find t)) + `(fm-find-all self ',md-name :must-find ,must-find)) ;deliberate capture + +(defmacro fm-map (fn md-name) + `(mapcar ,fn (fm-find-all self ',md-name))) ;deliberate capture + +(defmacro fm-mapc (fn md-name) + `(mapc ,fn (fm-find-all self ',md-name))) ;deliberate capture + +(defun fm-pos (goal &aux (fm-parent (fm-parent goal))) + (when fm-parent + (or (position goal (kids fm-parent)) + (length (kids fm-parent))))) ;; ?!! + +(defmacro fm-count-named (family md-name &key (global-search t)) + `(length (fm-find-all ,family ,md-name + :must-find nil + :global-search ,global-search))) +;--------------------------------------------------------------- + +(defun fm-top (fm &optional (test #'true-that) &aux (fm-parent (fm-parent fm))) + (cond ((null fm-parent) fm) + ((not (funcall test fm-parent)) fm) + (t (fm-top fm-parent test)))) + +(defun fm-first-above (fm &key (test #'true-that) &aux (fm-parent (fm-parent fm))) + (cond ((null fm-parent) nil) + ((funcall test fm-parent) fm-parent) + (t (fm-first-above fm-parent :test test)))) + +(defun fm-nearest-if (test fm) + (when fm + (if (funcall test fm) + fm + (fm-nearest-if test (fm-parent fm))))) + +(defun fm-includes (fm sought) + (fm-ancestorp fm sought)) + +(defun fm-ancestorp (fm sought) + (c-assert fm) + (when sought + (or (eql fm sought) + (fm-includes fm (fm-parent sought))))) + +(defun fm-kid-containing (fm-parent descendant) + (with-dynamic-fn (finder (node) (not (eql fm-parent node))) + (fm-top descendant finder))) + +(defun make-name (root &optional subscript) + (if subscript (list root subscript) root)) + +(defun name-root (md-name) + (if (atom md-name) md-name (car md-name))) + +(defun name-subscript (md-name) + (when (consp md-name) (cadr md-name))) + +(defun fm-find-one (family md-name &key (must-find t) + (global-search t) skiptree (test #'true-that)) + (flet ((matcher (fm) + (trc nil "fm-find-one matcher sees" md-name fm (md-name fm)) + (when (and (eql (name-root md-name) + (or (md-name fm) (c-class-name (class-of fm)))) + (or (null (name-subscript md-name)) + (eql (name-subscript md-name) (fm-pos fm))) + (funcall test fm)) + (throw 'fm-find-one fm)))) + #-lispworks (declare (dynamic-extent matcher)) + (trc nil "fm-find-one> entry " md-name family) + (let ((match (catch 'fm-find-one + (fm-traverse family #'matcher + :skiptree skiptree + :global-search global-search)))) + (when (and must-find (null match)) + (trc nil "fm-find-one > erroring fm-not-found" family md-name must-find global-search) + ;;(inspect family) + (let ((*fmdbg* family)) + (fm-find-one family md-name :must-find nil :global-search global-search) + (setf *stop* t) + ;;(trc "fm-find-one > *stop*ping...did not find" family md-name global-search) + (break "fm-find-one > *stop*ping...did not find ~a ~a ~a" family md-name global-search) + + )) + match))) + +(defun fm-find-kid (self name) + (find name (kids self) :key #'md-name)) + +(defun fm-kid-typed (self type) + (c-assert self) + (find type (kids self) :key #'type-of)) + +(defun kid-no (self) + (unless (typep self 'model-object) + (break "not a model object ~a" self)) + (when (and self (fm-parent self)) + (c-assert (member self (kids (fm-parent self)))) + (position self (kids (fm-parent self))))) + + Index: cells/initialize.lisp diff -u cells/initialize.lisp:1.1.1.1 cells/initialize.lisp:1.2 --- cells/initialize.lisp:1.1.1.1 Sat Nov 8 18:44:17 2003 +++ cells/initialize.lisp Tue Dec 16 10:02:58 2003 @@ -1,105 +1,105 @@ -;; -*- 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 eval load) - (export '(c-envalue))) - -(cc-defstruct (c-envaluer (:conc-name nil)) - envaluerule - ) - -(defun c-awaken (c) - (when *stop* - (princ #\.) - (return-from c-awaken)) - - (assert (c-model c) () "c-awaken sees uninstalled cell" c) - - ; re-entry happen's normally - ; nop it... - ; - (when (c-waking-state c) - ;;(count-it :c-awaken :already) - ;;(trc "c-awaken > already awake" c) - (return-from c-awaken)) - - ;;(trc "c-awaken > awakening" c) - ;;(count-it :c-awaken) - (setf (c-waking-state c) :awakening) - (c-awaken-cell c) - (setf (c-waking-state c) :awake) - c) - -(defun c-ephemeral-p (c) - (eql :ephemeral (md-slot-cell-type (type-of (c-model c)) (c-slot-name c)))) - -(defmethod c-awaken-cell (c) - (declare (ignorable c))) - -(defmethod c-awaken-cell ((c c-variable)) - (when (and (c-ephemeral-p c) - (c-value c)) - (error "Feature not yet supported: initializing ephemeral to other than nil: [~a]" - (c-value c))) - ; - ; nothing to calculate, but every cellular slot should be echoed - ; - (let ((v (c-value c))) - ;;(trc (c-model c) "c-awaken > calling echo" c v (slot-value (c-model c)(c-slot-name c))) - (when (eql '.kids (c-slot-name c)) - (md-kids-change (c-model c) v nil :c-awaken-variable)) - (c-echo-slot-name (c-slot-name c) (c-model c) v nil nil) - (c-ephemeral-reset c))) - -(defmethod c-awaken-cell ((c c-ruled)) - ; - ; ^svuc (with askers supplied) calls c-awaken, and now we call ^svuc crucially without askers - ; this oddity comes from an incident in which an asker-free invocation of ^svuc - ; successfully calculated when the call passing askers failed, i guess because askers not - ; actually to be consulted given the algorithm still were detected as self-referential - ; since the self-ref detector could not anticipate the algorithm's branching. - ; - (let (*c-calculators*) - (c-calculate-and-set c))) - -(defmethod c-awaken-cell ((c c-dependent)) - ; - ; satisfy CormanCL bug - ; - (let (*c-calculators*) - (c-calculate-and-set c))) - -(defmethod c-awaken-cell ((c c-drifter)) - ; - ; drifters *begin* valid, so the derived version's test for unbounditude - ; would keep (drift) rule ever from being evaluated. correct solution - ; (for another day) is to separate awakening (ie, linking to independent - ; cs) from evaluation, tho also evaluating if necessary during - ; awakening, because awakening's other role is to get an instance up to speed - ; at once upon instantiation - ; - (c-calculate-and-set c) - (cond ((c-validp c) (c-value c)) - ((c-unboundp c) nil) - (t "illegal state!!!"))) +;; -*- 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 eval load) + (export '(c-envalue))) + +(defstruct (c-envaluer (:conc-name nil)) + envaluerule + ) + +(defun c-awaken (c) + (when *stop* + (princ #\.) + (return-from c-awaken)) + + (c-assert (c-model c) () "c-awaken sees uninstalled cell" c) + + ; re-entry happen's normally + ; nop it... + ; + (when (c-waking-state c) + ;;(count-it :c-awaken :already) + ;;(trc "c-awaken > already awake" c) + (return-from c-awaken)) + + ;;(trc "c-awaken > awakening" c) + ;;(count-it :c-awaken) + (setf (c-waking-state c) :awakening) + (c-awaken-cell c) + (setf (c-waking-state c) :awake) + c) + +(defun c-ephemeral-p (c) + (eql :ephemeral (md-slot-cell-type (type-of (c-model c)) (c-slot-name c)))) + +(defmethod c-awaken-cell (c) + (declare (ignorable c))) + +(defmethod c-awaken-cell ((c c-variable)) + (when (and (c-ephemeral-p c) + (c-value c)) + (c-break "Feature not yet supported: initializing ephemeral to other than nil: [~a]" + (c-value c))) + ; + ; nothing to calculate, but every cellular slot should be echoed + ; + (let ((v (c-value c))) + ;;(trc (c-model c) "c-awaken > calling echo" c v (slot-value (c-model c)(c-slot-name c))) + (when (eql '.kids (c-slot-name c)) + (md-kids-change (c-model c) v nil :c-awaken-variable)) + (c-echo-slot-name (c-slot-name c) (c-model c) v nil nil) + (c-ephemeral-reset c))) + +(defmethod c-awaken-cell ((c c-ruled)) + ; + ; ^svuc (with askers supplied) calls c-awaken, and now we call ^svuc crucially without askers + ; this oddity comes from an incident in which an asker-free invocation of ^svuc + ; successfully calculated when the call passing askers failed, i guess because askers not + ; actually to be consulted given the algorithm still were detected as self-referential + ; since the self-ref detector could not anticipate the algorithm's branching. + ; + (let (*c-calculators*) + (c-calculate-and-set c))) + +(defmethod c-awaken-cell ((c c-dependent)) + ; + ; satisfy CormanCL bug + ; + (let (*c-calculators*) + (c-calculate-and-set c))) + +(defmethod c-awaken-cell ((c c-drifter)) + ; + ; drifters *begin* valid, so the derived version's test for unbounditude + ; would keep (drift) rule ever from being evaluated. correct solution + ; (for another day) is to separate awakening (ie, linking to independent + ; cs) from evaluation, tho also evaluating if necessary during + ; awakening, because awakening's other role is to get an instance up to speed + ; at once upon instantiation + ; + (c-calculate-and-set c) + (cond ((c-validp c) (c-value c)) + ((c-unboundp c) nil) + (t "illegal state!!!"))) Index: cells/link.lisp diff -u cells/link.lisp:1.1.1.1 cells/link.lisp:1.2 --- cells/link.lisp:1.1.1.1 Sat Nov 8 18:44:28 2003 +++ cells/link.lisp Tue Dec 16 10:02:58 2003 @@ -1,226 +1,226 @@ -;; -*- 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) - - -(defun c-link-ex (used &aux (user (car *c-calculators*))) - - (cond - ((cmdead user) (return-from c-link-ex nil)) - ((null used) - ; - ; no cell on used value so it is constant, but if a synapse is involved the constant - ; must still be filtered thru that, albeit only this once - ; - (when *synapse-factory* - (assert (car *c-calculators*)) ;; sanity-check - (funcall *synapse-factory* nil (car *c-calculators*)))) - - ((or (not (typep used 'c-user-notifying)) - (and (typep used 'c-dependent) - (c-optimized-away-p used))) - (return-from c-link-ex nil)) - - (t - ; - ; --------- debug stuff -------------- - (assert user) - (assert (not (cmdead user)) () "dead user in link-ex ~a, used being ~a" user used) - (assert (not (cmdead used)) () "dead used in link-ex ~a, user being ~a" used user) - - #+dfdbg (trc user "c-link > user, used" user used) - (assert (not (eq :eternal-rest (md-state (c-model user))))) - (assert (not (eq :eternal-rest (md-state (c-model used))))) - (count-it :c-link-entry) - (when *c-debug* - (assert (or (null *synapse-factory*) - (functionp *synapse-factory*)) - () - "~s is not a function, but was supplied as a synapse factory between ~s and ~s. probably parentheses wrong, as in (- (^lr x 96))" - *synapse-factory* used user)) - - (let ((used-link - (or - ;; check if linked already - ;; /// looks like a bug: cannot have two synaptic dependencies on same - ;; /// cell slot...probably need to "name" the synapses just for this purpose - ;; - (c-find-used-link user used) - ;; - ;; following may have been a goof, but i like it: let synapse factory - ;; decide not to produce a synapse, in which case dumb direct c-cell link - ;; gets created. - ;; - (bwhen (syn (and *synapse-factory* - (funcall *synapse-factory* used user))) - (c-add-user used syn) - (c-add-used user syn) - ;;(trc used "c-link> users now:" (mapcar #'celltrueuser (un-users used))) - (trc nil "setting used to syn" syn used) - syn) - ;; - ;; make dumb link: used just tells user to rethink. - ;; - (progn - (trc nil "c-link > new user,used " user used) - (c-add-user used user) - (c-add-used user used) - used)))) - - (assert used-link) - (assert (position used-link (cd-useds user)) - () - "used-link ~a does not appear in useds ~a of user ~a" - used-link (cd-useds user) user) - - (let ((mapn (- *cd-usagect* - (- (length (cd-useds user)) - (or (position used-link (cd-useds user)) 0))))) - ;; (trc user "c-link> setting usage bit" user mapn used-link) - (if (minusp mapn) - (break "whoa. more than ~d used? i see ~d" *cd-usagect* (length (cd-useds user))) - (cd-usage-set user mapn))) - used-link)))) - -(defun cd-usage-set (c mapn) - (when (typep c 'synapse) - (setf (syn-relevant c) t)) - (setf (sbit (cd-usage c) mapn) 1)) - -(defun cd-usage-clear-all (c) - (bit-and (cd-usage c) - #*0000000000000000000000000000000000000000000000000000000000000000 - t)) - -(defun c-find-used-link (user-cell used) - "find any existing link to user-cell, the cell itself if direct or a synapse leading to it" - (some (lambda (user) - (if (typep user 'synapse) - (when (eql user-cell (syn-user user)) - user) ;; the synapse is the used link - (when (eql user-cell user) - used))) ;; the link to used is direct (non-synaptic) - (un-users used))) - -(defun c-add-user (used user) - (count-it :c-adduser) - - (typecase used - (c-user-notifying - (trc nil "c-add-user conventional > user, used" user used) - (pushnew user (un-users used))) - - (synapse (setf (syn-user used) user))) - - used) - -(defun c-user-path-exists-p (from-used to-user) - (typecase from-used - (synapse (c-user-path-exists-p (syn-user from-used) to-user)) - (c-user-notifying - (or (find to-user (un-users from-used)) - (find-if (lambda (from-used-user) - (c-user-path-exists-p (c-user-true from-used-user) to-user)) - (un-users from-used)))))) - -; ----------- - -(defun c-add-used (user used) - (count-it :c-used) - #+ucount (unless (member used (cd-useds user)) - (incf *cd-useds*) - (when (zerop (mod *cd-useds* 100)) - (trc "useds count = " *cd-useds*))) - (pushnew used (cd-useds user)) - (trc nil "c-add-used> user <= used" user used (length (cd-useds user))) - (mapcar 'c-users-resort (cd-useds user)) - (cd-useds user)) - -(defun c-users-resort (used) - (typecase used - (synapse (c-users-resort (syn-used used))) - (c-user-notifying - (when (second (un-users used)) - (setf (un-users used) (sort (un-users used) 'c-user-path-exists-p)) - (trc nil "c-users-resort resorted users > used" used (mapcar 'c-slot-name (un-users used))) - (mapcar 'c-users-resort (c-useds used)))))) - -(defmethod c-useds (other) (declare (ignore other))) -(defmethod c-useds ((c c-dependent)) (cd-useds c)) - - -(defun c-quiesce (c) - (typecase c - (cell - (trc nil "c-quiesce unlinking" c) - (c-unlink-from-used c) - (when (typep c 'c-user-notifying) - (dolist (user (un-users c)) - (c-unlink-user c user))) - (c-pending-set c nil :c-quiesce) - ;;; (setf (c-waking-state c) nil) - ;;; (when (eql :rpthead (c-model c)) - (trc nil "cell quiesce nulled cell awake" c)))) - -;------------------------- - -(defmethod c-unlink-from-used ((user c-dependent)) - (dolist (used (cd-useds user)) - #+dfdbg (trc user "unlinking from used" user used) - (c-unlink-user used user)) - ;; shouldn't be necessary (setf (cd-useds user) nil) - ) - -(defmethod c-unlink-from-used (other) - (declare (ignore other))) - -;---------------------------------------------------------- - -(defmethod c-unlink-user ((used c-user-notifying) user) - #+dfdbg (trc user "user unlinking from used" user used) - (setf (un-users used) (delete user (un-users used))) - (c-unlink-used user used)) - -(defmethod c-unlink-user ((syn synapse) user) - (assert (eq user (syn-user syn))) - (c-unlink-user (syn-used syn) syn) - (setf (syn-user syn) nil) ;; gc-paranoia? - ) - -;----------------------------------------------------------- - - -(defmethod c-unlink-used ((user c-dependent) used) - (setf (cd-useds user) (delete used (cd-useds user)))) - -(defmethod c-unlink-used ((syn synapse) used) - (assert (eq used (syn-used syn))) - (setf (syn-used syn) nil) - (c-unlink-used (syn-user syn) syn)) - -; --- very low-vel abstraction - -(defmethod c-user-true (c) c) -(defmethod c-user-true ((syn synapse)) (syn-user syn)) -(defmethod c-used-true (c) c) -(defmethod c-used-true ((syn synapse)) (syn-used syn)) +;; -*- 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) + + +(defun c-link-ex (used &aux (user (car *c-calculators*))) + (c-assert user) + (cond + ((cmdead user) (return-from c-link-ex nil)) + ((null used) + ; + ; no cell on used value so it is constant, but if a synapse is involved the constant + ; must still be filtered thru that, albeit only this once + ; + (when *synapse-factory* + (c-assert (car *c-calculators*)) ;; sanity-check + (funcall *synapse-factory* nil (car *c-calculators*)))) + + ((or (not (typep used 'cell)) + (and (typep used 'c-dependent) + (c-optimized-away-p used))) + (return-from c-link-ex nil)) + + (t + ; + ; --------- debug stuff -------------- + (c-assert user) + (c-assert (not (cmdead user)) () "dead user in link-ex ~a, used being ~a" user used) + (c-assert (not (cmdead used)) () "dead used in link-ex ~a, user being ~a" used user) + + #+dfdbg (trc user "c-link > user, used" user used) + (c-assert (not (eq :eternal-rest (md-state (c-model user))))) + (c-assert (not (eq :eternal-rest (md-state (c-model used))))) + (count-it :c-link-entry) + (when *c-debug* + (c-assert (or (null *synapse-factory*) + (functionp *synapse-factory*)) + () + "~s is not a function, but was supplied as a synapse factory between ~s and ~s. probably parentheses wrong, as in (- (^lr x 96))" + *synapse-factory* used user)) + + (let ((used-link + (or + ;; check if linked already + ;; /// looks like a bug: cannot have two synaptic dependencies on same + ;; /// cell slot...probably need to "name" the synapses just for this purpose + ;; + (c-find-used-link user used) + ;; + ;; following may have been a goof, but i like it: let synapse factory + ;; decide not to produce a synapse, in which case dumb direct c-cell link + ;; gets created. + ;; + (bwhen (syn (and *synapse-factory* + (funcall *synapse-factory* used user))) + (c-add-user used syn) + (c-add-used user syn) + ;;(trc used "c-link> users now:" (mapcar #'celltrueuser (c-users used))) + (trc nil "setting used to syn" syn used) + syn) + ;; + ;; make dumb link: used just tells user to rethink. + ;; + (progn + (trc nil "c-link > new user,used " user used) + (c-add-user used user) + (c-add-used user used) + used)))) + + (c-assert used-link) + (c-assert (position used-link (cd-useds user)) + () + "used-link ~a does not appear in useds ~a of user ~a" + used-link (cd-useds user) user) + + (let ((mapn (- *cd-usagect* + (- (length (cd-useds user)) + (or (position used-link (cd-useds user)) 0))))) + ;; (trc user "c-link> setting usage bit" user mapn used-link) + (if (minusp mapn) + (break "whoa. more than ~d used? i see ~d" *cd-usagect* (length (cd-useds user))) + (cd-usage-set user mapn))) + used-link)))) + +(defun cd-usage-set (c mapn) + (when (typep c 'synapse) + (setf (syn-relevant c) t)) + (setf (sbit (cd-usage c) mapn) 1)) + +(defun cd-usage-clear-all (c) + (bit-and (cd-usage c) + #*0000000000000000000000000000000000000000000000000000000000000000 + t)) + +(defun c-find-used-link (user-cell used) + "find any existing link to user-cell, the cell itself if direct or a synapse leading to it" + (some (lambda (user) + (if (typep user 'synapse) + (when (eql user-cell (syn-user user)) + user) ;; the synapse is the used link + (when (eql user-cell user) + used))) ;; the link to used is direct (non-synaptic) + (c-users used))) + +(defun c-add-user (used user) + (count-it :c-adduser) + + (typecase used + (cell + (trc nil "c-add-user conventional > user, used" user used) + (pushnew user (c-users used))) + + (synapse (setf (syn-user used) user))) + + used) + +(defun c-user-path-exists-p (from-used to-user) + (typecase from-used + (synapse (c-user-path-exists-p (syn-user from-used) to-user)) + (cell + (or (find to-user (c-users from-used)) + (find-if (lambda (from-used-user) + (c-user-path-exists-p (c-user-true from-used-user) to-user)) + (c-users from-used)))))) + +; ----------- + +(defun c-add-used (user used) + (count-it :c-used) + #+ucount (unless (member used (cd-useds user)) + (incf *cd-useds*) + (when (zerop (mod *cd-useds* 100)) + (trc "useds count = " *cd-useds*))) + (pushnew used (cd-useds user)) + (trc nil "c-add-used> user <= used" user used (length (cd-useds user))) + (mapcar 'c-users-resort (cd-useds user)) + (cd-useds user)) + +(defun c-users-resort (used) + (typecase used + (synapse (c-users-resort (syn-used used))) + (cell + (when (second (c-users used)) + (setf (c-users used) (sort (c-users used) 'c-user-path-exists-p)) + (trc nil "c-users-resort resorted users > used" used (mapcar 'c-slot-name (c-users used))) + (mapcar 'c-users-resort (c-useds used)))))) + +(defmethod c-useds (other) (declare (ignore other))) +(defmethod c-useds ((c c-dependent)) (cd-useds c)) + + +(defun c-quiesce (c) + (typecase c + (cell + (trc nil "c-quiesce unlinking" c) + (c-unlink-from-used c) + (when (typep c 'cell) + (dolist (user (c-users c)) + (c-unlink-user c user))) + (c-pending-set c nil :c-quiesce) + ;;; (setf (c-waking-state c) nil) + ;;; (when (eql :rpthead (c-model c)) + (trc nil "cell quiesce nulled cell awake" c)))) + +;------------------------- + +(defmethod c-unlink-from-used ((user c-dependent)) + (dolist (used (cd-useds user)) + #+dfdbg (trc user "unlinking from used" user used) + (c-unlink-user used user)) + ;; shouldn't be necessary (setf (cd-useds user) nil) + ) + +(defmethod c-unlink-from-used (other) + (declare (ignore other))) + +;---------------------------------------------------------- + +(defmethod c-unlink-user ((used cell) user) + #+dfdbg (trc user "user unlinking from used" user used) + (setf (c-users used) (delete user (c-users used))) + (c-unlink-used user used)) + +(defmethod c-unlink-user ((syn synapse) user) + (c-assert (eq user (syn-user syn))) + (c-unlink-user (syn-used syn) syn) + (setf (syn-user syn) nil) ;; gc-paranoia? + ) + +;----------------------------------------------------------- + + +(defmethod c-unlink-used ((user c-dependent) used) + (setf (cd-useds user) (delete used (cd-useds user)))) + +(defmethod c-unlink-used ((syn synapse) used) + (c-assert (eq used (syn-used syn))) + (setf (syn-used syn) nil) + (c-unlink-used (syn-user syn) syn)) + +; --- very low-vel abstraction + +(defmethod c-user-true (c) c) +(defmethod c-user-true ((syn synapse)) (syn-user syn)) +(defmethod c-used-true (c) c) +(defmethod c-used-true ((syn synapse)) (syn-used syn)) Index: cells/md-slot-value.lisp diff -u cells/md-slot-value.lisp:1.1.1.1 cells/md-slot-value.lisp:1.2 --- cells/md-slot-value.lisp:1.1.1.1 Sat Nov 8 18:44:28 2003 +++ cells/md-slot-value.lisp Tue Dec 16 10:02:58 2003 @@ -1,153 +1,150 @@ -;; -*- 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) - -(defun md-slot-cell-flushed (self slot-spec) - (assocv (slot-spec-name slot-spec) (cells-flushed self))) - -(defun md-slot-value (self slot-spec &aux (slot-c (md-slot-cell self slot-spec))) - (when *stop* - (princ #\.) - (return-from md-slot-value)) - ;; (count-it :md-slot-value (slot-spec-name slot-spec)) - #+badidea(when (mdead self) - (trc "md-slot-value> model dead" (type-of self) slot-spec) - (return-from md-slot-value nil)) - (when (eql :nascent (md-state self)) - (md-awaken self)) - - ; this next bit is not written (c-relay-value <link> (etypecase slot-c...)) - ; because that would link before accessing possibly an invalid ruled slot - ; (during md-awaken), and after calculating it would propagate to users and - ; re-enter this calculation. Switching the order of the parameters would - ; also work, but we need to document this very specific order of operations - ; anyway, can't just leave that to the left-right thing. - ; - (let ((slot-value (etypecase slot-c - (null (bd-slot-value self slot-spec)) - (c-variable (c-value slot-c)) - (c-ruled (c-ruled-slot-value slot-c))))) - (c-relay-value - (when (car *c-calculators*) - (c-link-ex slot-c)) - slot-value))) - -(defun c-ruled-slot-value (slot-c) - (trc nil "c-ruled-slot-value entry" slot-c) - (assert (not (cmdead slot-c))) - - (cond - ((c-validp slot-c) - (if (c-true-stalep slot-c) - (c-calculate-and-set slot-c) ;; new for 2003-09-14 - (bif (deep (cd-deep-stale slot-c)) - (progn - (trc nil "valid ~a :but-deepstale ~a, cause: ~a. calcing" - slot-c deep *cause*) - (c-calculate-and-set slot-c)) - #+worked (progn - (trc "valid ~a :but-deepstale ~a, cause: ~a. calcing" - slot-c deep *cause*) - (c-calculate-and-set deep) - (bIf (deep2 (cd-deep-stale slot-c)) - (break "deep, deep trouble ~a :deep2 ~a :deep1 ~a, cause: ~a." - slot-c deep2 deep *cause*) - (progn - (trc "cleared valid with deep stale" slot-c) - (c-calculate-and-set slot-c)))) - (c-value slot-c)))) ;; good to go - - (t (let ((*cause* :on-demand)) ; normal path first time asked - (trc (plusp *trcdepth*) "md-slot-value calc" slot-c *c-calculators*) - (c-calculate-and-set slot-c))))) - -;------------------------------------------------------------- - -(defun (setf md-slot-value) (newvalue self slot-spec) - (when (mdead self) - (return-from md-slot-value)) - (let ((c (md-slot-cell self slot-spec))) - - (when *c-debug* - (c-setting-debug self slot-spec c newvalue)) - - (unless c - (cellstop) - (error "(setf md-slot-value)> cellular slot ~a of ~a cannot be setf unless initialized to c-variable" - slot-spec self) - ) - - (if (unst-setting-p c) - (if (unst-cyclic-p c) - newvalue - (error "setf of ~a propagated back; declare as cyclic (cv8...)" c)) - (let ((absorbedvalue (c-absorb-value c newvalue))) - ;;(assert (not (mdead self))) - (with-dataflow-management (c) - (md-slot-value-assume self slot-spec absorbedvalue)) ;; /// uh-oh. calc-n-set uses this return value - absorbedvalue)))) - -;;;(defmethod trcp ((c c-ruled)) -;;; ;;(trc "trcp ruled" (c-slot-name c) (md-name (c-model c))) -;;; (and (eql 'clo::px (c-slot-name c)) -;;; (eql :mklabel (md-name (c-model c))))) - - -(defun md-slot-value-assume (self slot-spec absorbedvalue - &aux - (c (md-slot-cell self slot-spec)) - (priorstate (when c (c-state c))) - (priorvalue (when c (c-value c))) - ) - (when (mdead self) - (return-from md-slot-value-assume nil)) - (md-slot-value-store self (slot-spec-name slot-spec) - (if c - (setf (c-value c) absorbedvalue) - absorbedvalue)) - - (when (typep c 'c-ruled) - (trc nil " setting cellstate :valid" c) - (setf (c-state c) :valid) - (setf (cd-stale-p c) nil) - (setf (c-waking-state c) :awake) - (c-pending-set c nil :sv-assume) - (c-optimize-away?! c)) ;;; put optimize as early as possible - - ;--- propagation ----------- - ; - (unwind-protect - (if (and (eql priorstate :valid) ;; ie, priorvalue meaningful (nil is ambiguous) - (c-no-news c absorbedvalue priorvalue)) - (progn - (trc nil "(setf md-slot-value) >no-news" priorstate (c-no-news c absorbedvalue priorvalue)) - #+not (count-it :no-news)) - (progn - (when (eql '.kids (slot-spec-name slot-spec)) - #+dfdbg (dolist (K absorbedvalue) (trc k "md-slot-value-assume -> kids change" k self)) - (md-kids-change self absorbedvalue priorvalue :md-slot-value-assume)) - (md-propagate self slot-spec absorbedvalue priorvalue (not (eql :unbound priorstate))))) - (when c - (setf (unst-setting-p c) nil))) - absorbedvalue) - +;; -*- 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) + +(defun md-slot-cell-flushed (self slot-spec) + (cdr (assoc (slot-spec-name slot-spec) (cells-flushed self)))) + +(defun md-slot-value (self slot-spec &aux (slot-c (md-slot-cell self slot-spec))) + (when *stop* + (princ #\.) + (return-from md-slot-value)) + ;; (count-it :md-slot-value (slot-spec-name slot-spec)) + #+badidea(when (mdead self) + (trc "md-slot-value> model dead" (type-of self) slot-spec) + (return-from md-slot-value nil)) + (when (eql :nascent (md-state self)) + (md-awaken self)) + + ; this next bit is not written (c-relay-value <link> (etypecase slot-c...)) + ; because that would link before accessing possibly an invalid ruled slot + ; (during md-awaken), and after calculating it would propagate to users and + ; re-enter this calculation. Switching the order of the parameters would + ; also work, but we need to document this very specific order of operations + ; anyway, can't just leave that to the left-right thing. + ; + (let ((slot-value (etypecase slot-c + (null (bd-slot-value self slot-spec)) + (c-variable (c-value slot-c)) + (c-ruled (c-ruled-slot-value slot-c))))) + (c-relay-value + (when (car *c-calculators*) + (c-link-ex slot-c)) + slot-value))) + +(defun c-ruled-slot-value (slot-c) + (trc nil "c-ruled-slot-value entry" slot-c) + (c-assert (not (cmdead slot-c))) + + (cond + ((c-validp slot-c) + (if (c-true-stalep slot-c) + (c-calculate-and-set slot-c) ;; new for 2003-09-14 + (bif (deep (cd-deep-stale slot-c)) + (progn + (trc nil "valid ~a :but-deepstale ~a, cause: ~a. calcing" + slot-c deep *cause*) + (c-calculate-and-set slot-c)) + #+worked (progn + (trc "valid ~a :but-deepstale ~a, cause: ~a. calcing" + slot-c deep *cause*) + (c-calculate-and-set deep) + (bIf (deep2 (cd-deep-stale slot-c)) + (break "deep, deep trouble ~a :deep2 ~a :deep1 ~a, cause: ~a." + slot-c deep2 deep *cause*) + (progn + (trc "cleared valid with deep stale" slot-c) + (c-calculate-and-set slot-c)))) + (c-value slot-c)))) ;; good to go + + (t (let ((*cause* :on-demand)) ; normal path first time asked + (trc (plusp *trcdepth*) "md-slot-value calc" slot-c *c-calculators*) + (c-calculate-and-set slot-c))))) + +;------------------------------------------------------------- + +(defun (setf md-slot-value) (newvalue self slot-spec) + (when (mdead self) + (return-from md-slot-value)) + (let ((c (md-slot-cell self slot-spec))) + + (when *c-debug* + (c-setting-debug self slot-spec c newvalue)) + + (unless c + (c-stop :setf-md-slot-value) + (c-break "(setf md-slot-value)> cellular slot ~a of ~a cannot be setf unless initialized to c-variable" + slot-spec self) + ) + + (if (cv-setting-p c) + (if (cv-cyclic-p c) + newvalue + (c-break "setf of ~a propagated back; declare as cyclic (cv8...)" c)) + (let ((absorbedvalue (c-absorb-value c newvalue))) + ;;(c-assert (not (mdead self))) + (with-dataflow-management (c) + (md-slot-value-assume self slot-spec absorbedvalue)) ;; /// uh-oh. calc-n-set uses this return value + absorbedvalue)))) + +;;;(defmethod trcp ((c c-ruled)) +;;; ;;(trc "trcp ruled" (c-slot-name c) (md-name (c-model c))) +;;; (and (eql 'clo::px (c-slot-name c)) +;;; (eql :mklabel (md-name (c-model c))))) + + +(defun md-slot-value-assume (self slot-spec absorbedvalue + &aux + (c (md-slot-cell self slot-spec)) + (priorstate (when c (c-state c))) + (priorvalue (when c (c-value c))) + ) + (when (mdead self) + (return-from md-slot-value-assume nil)) + (md-slot-value-store self (slot-spec-name slot-spec) + (if c + (setf (c-value c) absorbedvalue) + absorbedvalue)) + + (when (typep c 'c-ruled) + (trc nil " setting cellstate :valid" c) + (setf (c-state c) :valid) + (setf (cd-stale-p c) nil) + (setf (c-waking-state c) :awake) + (c-pending-set c nil :sv-assume) + (c-optimize-away?! c)) ;;; put optimize as early as possible + + ;--- propagation ----------- + ; + (if (and (eql priorstate :valid) ;; ie, priorvalue meaningful (nil is ambiguous) + (c-no-news c absorbedvalue priorvalue)) + (progn + (trc nil "(setf md-slot-value) >no-news" priorstate (c-no-news c absorbedvalue priorvalue)) + #+not (count-it :no-news)) + (progn + (when (eql '.kids (slot-spec-name slot-spec)) + #+dfdbg (dolist (K absorbedvalue) (trc k "md-slot-value-assume -> kids change" k self)) + (md-kids-change self absorbedvalue priorvalue :md-slot-value-assume)) + (md-propagate self slot-spec absorbedvalue priorvalue (not (eql :unbound priorstate))))) + absorbedvalue) + Index: cells/md-utilities.lisp diff -u cells/md-utilities.lisp:1.1.1.1 cells/md-utilities.lisp:1.2 --- cells/md-utilities.lisp:1.1.1.1 Sat Nov 8 18:44:28 2003 +++ cells/md-utilities.lisp Tue Dec 16 10:02:58 2003 @@ -1,111 +1,111 @@ -;; -*- 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) - -;;;(defmethod update-instance-for-redefined-class ((self model-object) added lost plist &key) -;;; (declare (ignorable added lost plist)) -;;; (when (slot-boundp self '.md-state) (call-next-method))) - -(defmethod occurence ((self model-object)) - ; - ; whether multiply occuring or not, return index of self - ; within list of likenamed siblings, perhaps mixed amongst others - ; of diff names - ; - (let ((selfindex -1)) - (dolist (kid (kids (fmparent self))) - (when (eql (md-name kid) (md-name self)) - (incf selfindex) - (when (eql self kid) - (return-from occurence selfindex)))))) - - -(defun md-awake (self) (eql :awake (md-state self))) - - -(defun fm-grandparent (md) - (fmparent (fmparent md))) - - -(defmethod md-release (other) - (declare (ignorable other))) - -;___________________ birth / death__________________________________ - -(defmethod not-to-be :around (self) - (trc nil "not-to-be clearing 1 fmparent, eternal-rest" self) - (assert (not (eq (md-state self) :eternal-rest))) - - (call-next-method) - - (setf (fmparent self) nil - (md-state self) :eternal-rest) - (trc nil "not-to-be cleared 2 fmparent, eternal-rest" self)) - -(defmethod not-to-be ((self model-object)) - (trc nil "not to be!!!" self) - (unless (md-untouchable self) - (md-quiesce self))) - -(defmethod md-untouchable (self) ;; would be t for closed-stream under acl - (declare (ignore self)) - nil) - -(defun md-quiesce (self) - (trc nil "md-quiesce doing" self) - (md-map-cells self nil (lambda (c) - (trc nil "quiescing" c) - (assert (not (find c *c-calculators*))) - (c-quiesce c)))) - - -(defmethod not-to-be (other) - other) - - - -(defparameter *to-be-dbg* nil) - -(defun to-be (self) - (trc nil "to-be> entry" self (md-state self)) - - (progn ;;wtrc (0 100 "to-be> entry" self (md-state self) (length *to-be-awakened*)) - (when (eql :nascent (md-state self)) ;; formwithview to-be-primary :after => rv-stitch! => side-effects - (let ((already *to-be-awakened*)) - (setf *to-be-awakened* (nconc *to-be-awakened* (list self))) - (trc nil "to-be deferring awaken" self) - (kids self) ;; sick, just for side effect - (unless already - (trc nil "top to-be awakening deferred" self (length *to-be-awakened*)) - (do* ((mds *to-be-awakened* (cdr mds)) - (md (car mds) (car mds))) - ((null mds)) - (if (eql :nascent (md-state md)) - (md-awaken md) - (trc nil "not md-awakening non-nascent" md))) - (setf *to-be-awakened* nil))))) - self) - -(defun md-make (class &rest kwps) - (to-be (apply #'make-instance class kwps))) - +;; -*- 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) + +;;;(defmethod update-instance-for-redefined-class ((self model-object) added lost plist &key) +;;; (declare (ignorable added lost plist)) +;;; (when (slot-boundp self '.md-state) (call-next-method))) + +(defmethod occurence ((self model-object)) + ; + ; whether multiply occuring or not, return index of self + ; within list of likenamed siblings, perhaps mixed amongst others + ; of diff names + ; + (let ((selfindex -1)) + (dolist (kid (kids (fm-parent self))) + (when (eql (md-name kid) (md-name self)) + (incf selfindex) + (when (eql self kid) + (return-from occurence selfindex)))))) + + +(defun md-awake (self) (eql :awake (md-state self))) + + +(defun fm-grandparent (md) + (fm-parent (fm-parent md))) + + +(defmethod md-release (other) + (declare (ignorable other))) + +;___________________ birth / death__________________________________ + +(defmethod not-to-be :around (self) + (trc nil "not-to-be clearing 1 fm-parent, eternal-rest" self) + (c-assert (not (eq (md-state self) :eternal-rest))) + + (call-next-method) + + (setf (fm-parent self) nil + (md-state self) :eternal-rest) + (trc nil "not-to-be cleared 2 fm-parent, eternal-rest" self)) + +(defmethod not-to-be ((self model-object)) + (trc nil "not to be!!!" self) + (unless (md-untouchable self) + (md-quiesce self))) + +(defmethod md-untouchable (self) ;; would be t for closed-stream under acl + (declare (ignore self)) + nil) + +(defun md-quiesce (self) + (trc nil "md-quiesce doing" self) + (md-map-cells self nil (lambda (c) + (trc nil "quiescing" c) + (c-assert (not (find c *c-calculators*))) + (c-quiesce c)))) + + +(defmethod not-to-be (other) + other) + + + +(defparameter *to-be-dbg* nil) + +(defun to-be (self) + (trc nil "to-be> entry" self (md-state self)) + + (progn ;;wtrc (0 100 "to-be> entry" self (md-state self) (length *to-be-awakened*)) + (when (eql :nascent (md-state self)) ;; formwithview to-be-primary :after => rv-stitch! => side-effects + (let ((already *to-be-awakened*)) + (setf *to-be-awakened* (nconc *to-be-awakened* (list self))) + (trc nil "to-be deferring awaken" self) + (kids self) ;; sick, just for side effect + (unless already + (trc nil "top to-be awakening deferred" self (length *to-be-awakened*)) + (do* ((mds *to-be-awakened* (cdr mds)) + (md (car mds) (car mds))) + ((null mds)) + (if (eql :nascent (md-state md)) + (md-awaken md) + (trc nil "not md-awakening non-nascent" md))) + (setf *to-be-awakened* nil))))) + self) + +(defun md-make (class &rest kwps) + (to-be (apply #'make-instance class kwps))) + Index: cells/model-object.lisp diff -u cells/model-object.lisp:1.1.1.1 cells/model-object.lisp:1.2 --- cells/model-object.lisp:1.1.1.1 Sat Nov 8 18:44:28 2003 +++ cells/model-object.lisp Tue Dec 16 10:02:58 2003 @@ -1,193 +1,175 @@ -;; -*- 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) - -;----------------- model-object ---------------------- - -(eval-when (:compile-toplevel :load-toplevel :execute) - (export '(md-name mdwhen fmparent .parent))) - -(defclass model-object () - ((.md-state :initform nil :accessor md-state) ; [nil | :nascent | :alive | :doomed] - (.md-name :initform nil :initarg :md-name :accessor md-name) - (.mdwhen :initform nil :initarg :mdwhen :accessor mdwhen) - (.fmparent :initform nil :initarg :fmparent :accessor fmparent) - (.cells :initform nil :initarg :cells :accessor cells) - (.cells-flushed :initform nil :initarg cells :accessor cells-flushed - :documentation "cells supplied but un-whenned or optimized-away") - (adopt-ct :initform 0 :accessor adopt-ct))) - -(defmethod print-object ((self model-object) s) - (format s "~a" (or (md-name self) (type-of self)))) - -(define-symbol-macro .parent (fmparent self)) - -(defun md-cell-defs (self) - (get (type-of self) :cell-defs)) - -(defmethod md-slot-cell (self slot-spec) - (assocv (slot-spec-name slot-spec) (cells self))) - -(defun md-slot-cell-type (class-name slot-spec) - (bif (entry (assoc (slot-spec-name slot-spec) (get class-name :cell-defs))) - (cdr entry) - (dolist (super (class-precedence-list (find-class class-name))) - (bIf (entry (assoc (slot-spec-name slot-spec) (get (c-class-name super) :cell-defs))) - (return (cdr entry)))))) - - -(defun (setf md-slot-cell-type) (new-type class-name slot-spec) - (assocv-setf (get class-name :cell-defs) (slot-spec-name slot-spec) new-type)) - -(defmethod md-slot-value-store ((self model-object) slot-spec new-value) - (setf (slot-value self (slot-spec-name slot-spec)) new-value)) - -;----------------- navigation: slot <> initarg <> esd <> cell ----------------- - -#+cmu -(defmethod c-class-name ((class pcl::standard-class)) - (pcl::class-name class)) - -(defmethod c-class-name (other) (declare (ignore other)) nil) - -(defmethod c-class-name ((class standard-class)) - (class-name class)) - -(defmethod cellwhen (other) (declare (ignorable other)) nil) - -(defun (setf md-slot-cell) (newcell self slot-spec) - (bif (entry (assoc (slot-spec-name slot-spec) (cells self))) - (let ((old (cdr entry))) ;; s/b being supplanted by kid-slotter - (assert (null (un-users old))) - (assert (null (cd-useds old))) - (trc nil "replacing in model .cells" old newcell self) - (rplacd entry newcell)) - (progn - (trc nil "adding to model .cells" newcell self) - (push (cons (slot-spec-name slot-spec) newcell) - (cells self))))) - -(defun md-map-cells (self type celldo) - (map type (lambda (cellentry) - (bwhen (cell (cdr cellentry)) - (unless (listp cell) - (funcall celldo cell)))) - (cells self))) - -(defun c-install (self sn c) - (assert (typep c 'cell)) - (trc nil "installing cell" sn c) - (setf - (c-model c) self - (c-slot-spec c) sn - (md-slot-cell self sn) c - (slot-value self sn) (when (typep c 'c-variable) - (c-value c)))) - -;------------------ md obj initialization ------------------ - -(defmethod shared-initialize :after ((self model-object) slotnames - &rest initargs &key fmparent mdwhen - &allow-other-keys) - (declare (ignorable initargs slotnames fmparent mdwhen)) - - (dolist (esd (class-slots (class-of self))) - (let* ((sn (slot-definition-name esd)) - (sv (when (slot-boundp self sn) - (slot-value self sn)))) - (when (typep sv 'cell) - (if (md-slot-cell-type (type-of self) sn) - (c-install self sn sv) - (when *c-debug* - (trc "cell ~a offered for non-cellular model/slot ~a/~a" sv self sn)))))) - - (md-initialize self)) - -;;;(defun pick-if-when-slot (esd mdwhen &aux (cellwhen (cellwhen esd))) -;;; (or (null cellwhen) -;;; (some-x-is-in-y cellwhen mdwhen))) - -(defmethod md-initialize (self) - (when (slot-boundp self '.md-name) - (unless (md-name self) - (setf (md-name self) (c-class-name (class-of self))))) - - (when (fmparent self) - (md-adopt (fmparent self) self)) - - (setf (md-state self) :nascent)) - -(defun cells-clear (self) - "allow gc" - ;; - ;; too extreme? 'close-device went after slot when a class - ;; ended up without cells--should not be a crime 2k0320kt - ;; (slot-makunbound self '.cells) - ;; ... - (setf (cells self) nil) ;; try instead - ) - - -;--------- awaken only when ready (in family, for models) -------- - - -(defmethod md-awaken ((self model-object)) - (trc nil "md-awaken entry" self (md-state self)) - (assert (eql :nascent (md-state self))) - ;; (trc nil "awaken doing") - (count-it :md-awaken) - ;;(count-it 'mdawaken (type-of self)) - (setf (md-state self) :awakening) - ;; (trc "md-awaken entry" self) - (dolist (esd (class-slots (class-of self))) - (trc nil "md-awaken scoping slot" self (slot-definition-name esd)) - (when (md-slot-cell-type (type-of self) (slot-definition-name esd)) - (let ((slot-name (slot-definition-name esd))) - (if (not (c-echo-defined slot-name)) - (progn ;; (count-it :md-awaken :no-echo-slot slot-name) - (trc nil "md-awaken deferring cell-awaken since no echo" self esd)) - - (let ((cell (md-slot-cell self slot-name))) - (trc nil "md-awaken finds md-esd-cell " cell) - (when *c-debug* - ; - ; check to see if cell snuck into actual slot value... - ; - (bwhen (sv (slot-value self slot-name)) - (when (typep sv 'cell) - (error "md-awaken ~a found cell ~a in slot ~a" self sv esd)))) - - (if cell - (if (c-lazy-p cell) - (progn - (trc nil "md-awaken deferring cell-awaken since lazy" self esd)) - (c-awaken cell)) - (progn ;; next bit revised to avoid double-echo of optimized cells - (when (eql '.kids slot-name) - (bwhen (sv (slot-value self '.kids)) - (md-kids-change self sv nil :md-awaken-slot))) - (c-echo-initially self slot-name)))))))) - - (setf (md-state self) :awake) - self) - +;; -*- 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) + +;----------------- model-object ---------------------- + +(eval-when (:compile-toplevel :load-toplevel :execute) + (export '(md-name mdwhen fm-parent .parent))) + +(defclass model-object () + ((.md-state :initform nil :accessor md-state) ; [nil | :nascent | :alive | :doomed] + (.mdwhen :initform nil :initarg :mdwhen :accessor mdwhen) + (.cells :initform nil :accessor cells) + (.cells-flushed :initform nil :accessor cells-flushed + :documentation "cells supplied but un-whenned or optimized-away") + (adopt-ct :initform 0 :accessor adopt-ct))) + +(defmethod md-slot-cell (self slot-spec) + (cdr (assoc (slot-spec-name slot-spec) (cells self)))) + +(defun md-slot-cell-type (class-name slot-spec) + (bif (entry (assoc (slot-spec-name slot-spec) (get class-name :cell-types))) + (cdr entry) + (dolist (super (class-precedence-list (find-class class-name))) + (bWhen (entry (assoc (slot-spec-name slot-spec) (get (c-class-name super) :cell-types))) + (return (setf (md-slot-cell-type class-name slot-spec) (cdr entry))))))) + +(defun (setf md-slot-cell-type) (new-type class-name slot-spec) + (assocv-setf (get class-name :cell-types) (slot-spec-name slot-spec) new-type)) + +(defmethod md-slot-value-store ((self model-object) slot-spec new-value) + (setf (slot-value self (slot-spec-name slot-spec)) new-value)) + +;----------------- navigation: slot <> initarg <> esd <> cell ----------------- + +#+cmu +(defmethod c-class-name ((class pcl::standard-class)) + (pcl::class-name class)) + +(defmethod c-class-name (other) (declare (ignore other)) nil) + +(defmethod c-class-name ((class standard-class)) + (class-name class)) + +(defmethod cellwhen (other) (declare (ignorable other)) nil) + +(defun (setf md-slot-cell) (newcell self slot-spec) + (bif (entry (assoc (slot-spec-name slot-spec) (cells self))) + (let ((old (cdr entry))) ;; s/b being supplanted by kid-slotter + (c-assert (null (c-users old))) + (c-assert (null (cd-useds old))) + (trc nil "replacing in model .cells" old newcell self) + (rplacd entry newcell)) + (progn + (trc nil "adding to model .cells" newcell self) + (push (cons (slot-spec-name slot-spec) newcell) + (cells self))))) + +(defun md-map-cells (self type celldo) + (map type (lambda (cellentry) + (bwhen (cell (cdr cellentry)) + (unless (listp cell) + (funcall celldo cell)))) + (cells self))) + +(defun c-install (self sn c) + (c-assert (typep c 'cell)) + (trc nil "installing cell" sn c) + (setf + (c-model c) self + (c-slot-spec c) sn + (md-slot-cell self sn) c + (slot-value self sn) (when (typep c 'c-variable) + (c-value c)))) + +;------------------ md obj initialization ------------------ + +(defmethod shared-initialize :after ((self model-object) slotnames + &rest initargs &key fm-parent mdwhen + &allow-other-keys) + (declare (ignorable initargs slotnames fm-parent mdwhen)) + + (dolist (esd (class-slots (class-of self))) + (let* ((sn (slot-definition-name esd)) + (sv (when (slot-boundp self sn) + (slot-value self sn)))) + (when (typep sv 'cell) + (if (md-slot-cell-type (type-of self) sn) + (c-install self sn sv) + (when *c-debug* + (trc "warning: cell ~a offered for non-cellular model/slot ~a/~a" sv self sn)))))) + + (md-initialize self)) + +;;;(defun pick-if-when-slot (esd mdwhen &aux (cellwhen (cellwhen esd))) +;;; (or (null cellwhen) +;;; (some-x-is-in-y cellwhen mdwhen))) + +(defmethod md-initialize (self) + (setf (md-state self) :nascent)) + +(defun cells-clear (self) + "allow gc" + ;; + ;; too extreme? 'close-device went after slot when a class + ;; ended up without cells--should not be a crime 2k0320kt + ;; (slot-makunbound self '.cells) + ;; ... + (setf (cells self) nil) ;; try instead + ) + + +;--------- awaken only when ready (in family, for models) -------- + + +(defmethod md-awaken ((self model-object)) + (trc nil "md-awaken entry" self (md-state self)) + (c-assert (eql :nascent (md-state self))) + ;; (trc nil "awaken doing") + (count-it :md-awaken) + ;;(count-it 'mdawaken (type-of self)) + (setf (md-state self) :awakening) + ;; (trc "md-awaken entry" self) + (dolist (esd (class-slots (class-of self))) + (trc nil "md-awaken scoping slot" self (slot-definition-name esd)) + (when (md-slot-cell-type (type-of self) (slot-definition-name esd)) + (let ((slot-name (slot-definition-name esd))) + (if (not (c-echo-defined slot-name)) + (progn ;; (count-it :md-awaken :no-echo-slot slot-name) + (trc nil "md-awaken deferring cell-awaken since no echo" self esd)) + + (let ((cell (md-slot-cell self slot-name))) + (trc nil "md-awaken finds md-esd-cell " cell) + (when *c-debug* + ; + ; check to see if cell snuck into actual slot value... + ; + (bwhen (sv (slot-value self slot-name)) + (when (typep sv 'cell) + (c-break "md-awaken ~a found cell ~a in slot ~a" self sv esd)))) + + (if cell + (if (c-lazy-p cell) + (progn + (trc nil "md-awaken deferring cell-awaken since lazy" self esd)) + (c-awaken cell)) + (progn ;; next bit revised to avoid double-echo of optimized cells + (when (eql '.kids slot-name) + (bwhen (sv (slot-value self '.kids)) + (md-kids-change self sv nil :md-awaken-slot))) + (c-echo-initially self slot-name)))))))) + + (setf (md-state self) :awake) + self) + Index: cells/optimization.lisp diff -u cells/optimization.lisp:1.1.1.1 cells/optimization.lisp:1.2 --- cells/optimization.lisp:1.1.1.1 Sat Nov 8 18:44:28 2003 +++ cells/optimization.lisp Tue Dec 16 10:02:58 2003 @@ -1,83 +1,83 @@ -;; -*- 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) - -;____________ cell when ____________________ - -(defparameter *c-whentime* nil) - -(defun call-with-when-time? (whentimes function &aux old) - (rotatef old *c-whentime* whentimes) - ;; (trc "setting *c-whentime* to" *c-whentime*) - (unwind-protect - (funcall function) - (setf *c-whentime* old))) - -;---------- optimizing away cells whose dependents all turn out to be constant ---------------- -; - -(defun c-optimize-away?! (c) - - (typecase c - #+old-code - (c-nested (trc nil "optimize-away nested") - (when (and (null (cd-useds c))) - (rplaca (member c (cellnestedcells (cellaggregatecell c))) (c-value c)) - t)) - (c-dependent - (if (and *c-optimizep* - (c-validp c) - (null (cd-useds c))) - - (progn - (trc nil "optimizing away" c) - (count-it :c-optimized) - - (setf (c-state c) :optimized-away) - - (let ((entry (rassoc c (cells (c-model c))))) ; move from cells to cells-flushed - (assert entry) - (setf (cells (c-model c)) (delete entry (cells (c-model c)))) - (push entry (cells-flushed (c-model c)))) - - (dolist (user (un-users c)) - (setf (cd-useds user) (delete c (cd-useds user))) - (trc nil "checking opti2" c :user> user) - (when (c-optimize-away?! user) - (trc "Wow!!! optimizing chain reaction, first:" c :then user))) - - (setf ; drop foreign refs to aid gc (gc paranoia?) - (c-model c) nil - (un-users c) nil) - - t) - - (progn - (trc nil "not optimizing away" *c-optimizep* (car (cd-useds c)) (c-validp c)) - #+no (dolist (used (cd-useds c)) - (assert (member c (un-users used))) - ;;; (trc nil "found as user of" used) - ) - ; (count-it :c-not-optimize) - ; (count-it (intern-keyword "noopti-" #+nah (c-model c) "-" (symbol-name (c-slot-name c)))) - ))))) +;; -*- 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) + +;____________ cell when ____________________ + +(defparameter *c-whentime* nil) + +(defun call-with-when-time? (whentimes function &aux old) + (rotatef old *c-whentime* whentimes) + ;; (trc "setting *c-whentime* to" *c-whentime*) + (unwind-protect + (funcall function) + (setf *c-whentime* old))) + +;---------- optimizing away cells whose dependents all turn out to be constant ---------------- +; + +(defun c-optimize-away?! (c) + + (typecase c + #+old-code + (c-nested (trc nil "optimize-away nested") + (when (and (null (cd-useds c))) + (rplaca (member c (cellnestedcells (cellaggregatecell c))) (c-value c)) + t)) + (c-dependent + (if (and *c-optimizep* + (c-validp c) + (null (cd-useds c))) + + (progn + (trc nil "optimizing away" c) + (count-it :c-optimized) + + (setf (c-state c) :optimized-away) + + (let ((entry (rassoc c (cells (c-model c))))) ; move from cells to cells-flushed + (c-assert entry) + (setf (cells (c-model c)) (delete entry (cells (c-model c)))) + (push entry (cells-flushed (c-model c)))) + + (dolist (user (c-users c)) + (setf (cd-useds user) (delete c (cd-useds user))) + (trc nil "checking opti2" c :user> user) + (when (c-optimize-away?! user) + (trc "Wow!!! optimizing chain reaction, first:" c :then user))) + + (setf ; drop foreign refs to aid gc (gc paranoia?) + (c-model c) nil + (c-users c) nil) + + t) + + (progn + (trc nil "not optimizing away" *c-optimizep* (car (cd-useds c)) (c-validp c)) + #+no (dolist (used (cd-useds c)) + (c-assert (member c (c-users used))) + ;;; (trc nil "found as user of" used) + ) + ; (count-it :c-not-optimize) + ; (count-it (intern-keyword "noopti-" #+nah (c-model c) "-" (symbol-name (c-slot-name c)))) + ))))) Index: cells/propagate.lisp diff -u cells/propagate.lisp:1.1.1.1 cells/propagate.lisp:1.2 --- cells/propagate.lisp:1.1.1.1 Sat Nov 8 18:44:34 2003 +++ cells/propagate.lisp Tue Dec 16 10:02:58 2003 @@ -1,310 +1,308 @@ -;; -*- 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) - -(defparameter *echodone* nil) - -(defun c-echo-defined (slot-name) - (getf (symbol-plist slot-name) :echo-defined)) - -(defmethod (setf c-true-stalep) (newvalue (user c-ruled)) - #+dfdbg (trc user "setting c-true-stalep" user newvalue) - (assert (find user (cells (c-model user)) :key #'cdr)) - (setf (cd-stale-p user) newvalue)) - -(defmethod (setf c-true-stalep) (newvalue (usersyn synapse)) - #+dfdbg (trc (syn-user usersyn) "synapse setting c-true-stalep" (syn-user usersyn) newvalue usersyn) - (setf (cd-stale-p (syn-user usersyn)) newvalue)) - -(defmethod (setf c-true-stalep) (newvalue other) - (declare (ignore other)) - newvalue) - -(defun c-echo-initially (self slot-spec) - "call during instance init. if echo is defined for slot, and value is non-nil (controversial) force initial echo." - (trc nil "c-echo-initially" self slot-spec - (c-echo-defined (slot-spec-name slot-spec)) - (md-slot-cell self slot-spec)) - (if (c-echo-defined (slot-spec-name slot-spec)) - (bif (c (md-slot-cell self slot-spec)) - (etypecase c - (c-variable (md-propagate self slot-spec (c-value c) nil nil)) - (c-ruled (md-slot-value self slot-spec))) ;; this will echo after calculating if not nil - ; - ; new for 22-03-07: echo even if slot value is nil... - (c-echo-slot-name (slot-spec-name slot-spec) - self - (bd-slot-value self slot-spec) - nil nil)) - (bwhen (c (md-slot-cell self slot-spec)) - (c-ephemeral-reset c)))) - -#-(or cormanlisp clisp) -(defgeneric c-echo-slot-name (slotname self new old old-boundp) (:method-combination progn)) - - -(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))) - -#+(or cormanlisp clisp) -(defmethod c-echo-slot-name (slot-name self new old old-boundp) - (declare (ignorable slot-name self new old old-boundp))) - -;--------------- propagate ---------------------------- -; -; n.b. 990414kt the cell argument may have been optimized away, -; though it is still receiving final processing here. -; - -(defun md-propagate (self slot-spec newvalue priorvalue priorvalue-supplied) - (when (mdead self) - (trc nil "md-propagate n-opping dead" self) - (return-from md-propagate nil)) - - (let (*c-calculators* - (*c-prop-depth* (1+ *c-prop-depth*)) - (c (md-slot-cell self slot-spec))) - ; - ;------ debug stuff --------- - ; - (when *stop* - (princ #\.)(princ #\!) - (return-from md-propagate)) - - (when c - (trc nil "md-propagate> propping" self slot-spec (length (un-users c)) c) - ) - - (when *c-debug* - (when (> *c-prop-depth* 250) - (trc "md-propagate deep" *c-prop-depth* self (slot-spec-name slot-spec) #+nah c)) - (when (> *c-prop-depth* 300) - (break "md-propagate looping" c) - )) - - (when c - ; ------ flag dependents as stale ------------ - ; do before echo in case echo gets back to some user - ; - (dolist (user (un-users c)) - #+dfdbg (trc user "md-prop now setting stale (changer, stale):" c user) - (when (c-user-cares user) - (setf (c-true-stalep user) c)))) - - ; --- manifest new value as needed ----------- - (when (c-echo-defined (slot-spec-name slot-spec)) ;; /// faster than just dispatching? - (when c (trc nil "md-prop now echoing" c)) - (c-echo-slot-name (slot-spec-name slot-spec) - self - newvalue - priorvalue - priorvalue-supplied) - (when (mdead self) ;; hopefully expiration on perishable class - (return-from md-propagate))) - - (when c ; --- now propagate to dependents ------------ - (trc nil "md-prop checking dependents" c (un-users c)) - (let ((*cause* c)) - (dolist (user (un-users c)) - (unless (cmdead user) - (when (c-user-cares user) - (if (c-user-lazy user) - (progn - (trc nil "lazy user not being propagated to" user :by c) - (dolist (u (un-users user)) - (c-propagate-staleness u))) - (progn - (c-rethink user) - (when (mdead self) - (trc nil "md-propagate> self now dead after rethink user: ~a" self user) - (return-from md-propagate nil)) - ))))) - (c-ephemeral-reset c))))) - -(defmethod c-propagate-staleness ((c c-ruled)) - (trc nil "inheriting staleness" c) - (dolist (u (cr-users c)) - (c-propagate-staleness u))) - -(defmethod c-propagate-staleness ((s synapse)) - (trc "I hope this synapse isn't for efficiency" s) - (break) - (c-propagate-staleness (syn-user s))) - -(defmethod c-propagate-staleness (c) - (declare (ignorable c)) - (trc "not inheriting or proagating staleness" c) - ) - -(defmethod c-user-cares (c) c) ;; ie, t -(defmethod c-user-cares ((s synapse)) - (syn-relevant s)) - -(defmethod c-user-lazy (c) (declare (ignore c)) nil) -(defmethod c-user-lazy ((c c-ruled)) - (cr-lazy c)) - - -(defun c-ephemeral-reset (c) - (when c - (when (c-ephemeral-p c) - (trc nil "c-ephemeral-reset resetting:" c) - (setf (c-value c) nil)))) ;; good q: what does (setf <ephem> 'x) return? historically nil, but...? - -;----------------- change detection --------------------------------- - -(defun c-no-news (c newvalue oldvalue) - ;;; (trc nil "c-no-news > checking news between" newvalue oldvalue) - - (if (unst-delta-p c) - (c-identity-p newvalue) - (bIf (test (c-unchanged-test (c-model c) (c-slot-name c))) - (funcall test newvalue oldvalue) - (eql newvalue oldvalue)))) - -(defmacro def-c-unchanged-test ((class slotname) &body test) - `(defmethod c-unchanged-test ((self ,class) (slotname (eql ',slotname))) - ,@test)) - -(defmethod c-unchanged-test (self slotname) - (declare (ignore self slotname)) - nil) - -(defmethod c-identity-p ((value null)) t) -(defmethod c-identity-p ((value number)) (zerop value)) -(defmethod c-identity-p ((value cons)) - ;; this def a little suspect? - (and (c-identity-p (car value)) - (c-identity-p (cdr value)))) - - -;------------------- re think --------------------------------- - -(defun cmdead (c) - (if (typep c 'synapse) - (cmdead (syn-user c)) - (if (null (c-model c)) - (not (c-optimized-away-p c)) - (mdead (c-model c))))) - -(defun mdead (m) (eq :eternal-rest (md-state m))) - -(defun c-rethink (c) - (when *stop* - (princ #\.) - (return-from c-rethink)) - ;;(trc "rethink entry: c, true-stale" c (c-true-stalep c)) - (assert (not (cmdead c))() "rethink entry cmdead ~a" c) - (unless (c-true-stalep c) - (return-from c-rethink)) - - (when *rethink-deferred* - (trc nil "bingo!!!!!! rethink deferring" c *cause*) - (push (list c *cause*) *rethink-deferred*) - (return-from c-rethink)) - - (assert (not (cmdead c))() "rethink here?? cmdead ~a" c) - - ; looking ahead for interference avoids JIT detection, which where a dependency - ; already exists causes re-entrance into the rule, which should calculate the same - ; value twice and echo only once, but still seems like something to avoid since - ; we do already have the technology. - ; - - (bIf (interf (sw-detect-interference c nil)) - (progn - (trc "!!!!!!!!!! rethink of " c :held-up-by interf) - (c-pending-set c interf :interfered) - #+dfdbg (when (trcp c) - (trc "!!!!!!!!!! rethink of " c :held-up-by interf) - #+nah (dump-stale-path interf) - ) - (return-from c-rethink)) - (when (sw-pending c) - (trc nil "no interference now for " c) - (c-pending-set c nil :dis-interfered))) - - (when (cmdead c) - (trc nil "woohoo!!! interference checking finished model off" c) - (return-from c-rethink)) - - (unless (c-true-stalep c) - (trc nil "woohoo!!! interference checking refreshed" c) - (return-from c-rethink)) - - (typecase c - (c-ruled (c-calculate-and-set c)) - - (synapse - (trc nil "c-rethink > testing rethink of: syn,salv,valu" c salvage (c-value (syn-used c))) - (if (funcall (syn-fire-p c) c (c-value (syn-used c))) - (progn - (trc nil "c-rethink> decide yes on rethink on syn, valu" c (c-value (syn-used c))) - (c-rethink (syn-user c))) - (trc nil "c-rethink> decide nooooo on rethink on synapse" c (syn-user c) salvage))) - )) - -(defmacro def-c-echo (slotname - (&optional (selfarg 'self) (newvarg 'new-value) - (oldvarg 'old-value) (oldvargboundp 'old-value-boundp)) - &body echobody) - ;;;(trc "echo body" echobody) - `(progn - (eval-when (:compile-toplevel :load-toplevel :execute) - (setf (get ',slotname :echo-defined) t)) - ,(if (eql (last1 echobody) :test) - (let ((temp1 (gensym)) - (loc-self (gensym))) - `(defmethod c-echo-slot-name #-(or clisp cormanlisp) progn ((slotname (eql ',slotname)) ,selfarg ,newvarg ,oldvarg ,oldvargboundp) - (let ((,temp1 (bump-echo-count ,slotname)) - (,loc-self ,(if (listp selfarg) - (car selfarg) - selfarg))) - (when (and ,oldvargboundp ,oldvarg) - (format t "~&echo ~d (~a ~a) old: ~a" ,temp1 ',slotname ,loc-self ,oldvarg)) - (format t "~&echo ~d (~a ~a) new: ~a" ,temp1 ',slotname ,loc-self ,newvarg)))) - `(defmethod c-echo-slot-name - #-(or clisp cormanlisp) progn - ((slotname (eql ',slotname)) ,selfarg ,newvarg ,oldvarg ,oldvargboundp) - (declare (ignorable ,(etypecase selfarg - (list (car selfarg)) - (atom selfarg)) - ,(etypecase newvarg - (list (car newvarg)) - (atom newvarg)) - ,(etypecase oldvarg - (list (car oldvarg)) - (atom oldvarg)) - ,(etypecase oldvargboundp - (list (car oldvargboundp)) - (atom oldvargboundp)))) - ,@echobody)))) - -(defmacro bump-echo-count (slotname) ;; pure test func - `(if (get ',slotname :echos) - (incf (get ',slotname :echos)) - (setf (get ',slotname :echos) 1))) - +;; -*- 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) + +(defparameter *echodone* nil) + +(defun c-echo-defined (slot-name) + (getf (symbol-plist slot-name) :echo-defined)) + +(defmethod (setf c-true-stalep) (newvalue (user c-ruled)) + #+dfdbg (trc user "setting c-true-stalep" user newvalue) + (c-assert (find user (cells (c-model user)) :key #'cdr)) + (setf (cd-stale-p user) newvalue)) + +(defmethod (setf c-true-stalep) (newvalue (usersyn synapse)) + #+dfdbg (trc (syn-user usersyn) "synapse setting c-true-stalep" (syn-user usersyn) newvalue usersyn) + (setf (cd-stale-p (syn-user usersyn)) newvalue)) + +(defmethod (setf c-true-stalep) (newvalue other) + (declare (ignore other)) + newvalue) + +(defun c-echo-initially (self slot-spec) + "call during instance init. if echo is defined for slot, and value is non-nil (controversial) force initial echo." + (trc nil "c-echo-initially" self slot-spec + (c-echo-defined (slot-spec-name slot-spec)) + (md-slot-cell self slot-spec)) + (if (c-echo-defined (slot-spec-name slot-spec)) + (bif (c (md-slot-cell self slot-spec)) + (etypecase c + (c-variable (md-propagate self slot-spec (c-value c) nil nil)) + (c-ruled (md-slot-value self slot-spec))) ;; this will echo after calculating if not nil + ; + ; new for 22-03-07: echo even if slot value is nil... + (c-echo-slot-name (slot-spec-name slot-spec) + self + (bd-slot-value self slot-spec) + nil nil)) + (bwhen (c (md-slot-cell self slot-spec)) + (c-ephemeral-reset c)))) + +#-(or cormanlisp clisp) +(defgeneric c-echo-slot-name (slotname self new old old-boundp) (:method-combination progn)) + + +(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))) + +#+(or cormanlisp clisp) +(defmethod c-echo-slot-name (slot-name self new old old-boundp) + (declare (ignorable slot-name self new old old-boundp))) + +;--------------- propagate ---------------------------- +; +; n.b. 990414kt the cell argument may have been optimized away, +; though it is still receiving final processing here. +; + +(defun md-propagate (self slot-spec newvalue priorvalue priorvalue-supplied) + (when (mdead self) + (trc nil "md-propagate n-opping dead" self) + (return-from md-propagate nil)) + + (let (*c-calculators* + (*c-prop-depth* (1+ *c-prop-depth*)) + (c (md-slot-cell self slot-spec))) + ; + ;------ debug stuff --------- + ; + (when *stop* + (princ #\.)(princ #\!) + (return-from md-propagate)) + + (when c + (trc nil "md-propagate> propping" self slot-spec (length (c-users c)) c) + ) + + (when *c-debug* + (when (> *c-prop-depth* 250) + (trc "md-propagate deep" *c-prop-depth* self (slot-spec-name slot-spec) #+nah c)) + (when (> *c-prop-depth* 300) + (c-break "md-propagate looping ~c" c) + )) + + (when c + ; ------ flag dependents as stale ------------ + ; do before echo in case echo gets back to some user + ; + (dolist (user (c-users c)) + #+dfdbg (trc user "md-prop now setting stale (changer, stale):" c user) + (when (c-user-cares user) + (setf (c-true-stalep user) c)))) + + ; --- manifest new value as needed ----------- + (when (c-echo-defined (slot-spec-name slot-spec)) ;; /// faster than just dispatching? + (when c (trc nil "md-prop now echoing" c)) + (c-echo-slot-name (slot-spec-name slot-spec) + self + newvalue + priorvalue + priorvalue-supplied) + (when (mdead self) ;; hopefully expiration on perishable class + (return-from md-propagate))) + + (when c ; --- now propagate to dependents ------------ + (trc nil "md-prop checking dependents" c (c-users c)) + (let ((*cause* c)) + (dolist (user (c-users c)) + (unless (cmdead user) + (when (c-user-cares user) + (if (c-user-lazy user) + (progn + (trc nil "lazy user not being propagated to" user :by c) + (dolist (u (c-users user)) + (c-propagate-staleness u))) + (progn + (c-rethink user) + (when (mdead self) + (trc nil "md-propagate> self now dead after rethink user: ~a" self user) + (return-from md-propagate nil)) + ))))) + (c-ephemeral-reset c))))) + +(defmethod c-propagate-staleness ((c c-ruled)) + (trc nil "inheriting staleness" c) + (dolist (u (cr-users c)) + (c-propagate-staleness u))) + +(defmethod c-propagate-staleness ((s synapse)) + (trc "I hope this synapse isn't for efficiency" s) + (break) + (c-propagate-staleness (syn-user s))) + +(defmethod c-propagate-staleness (c) + (declare (ignorable c)) + (trc "not inheriting or proagating staleness" c) + ) + +(defmethod c-user-cares (c) c) ;; ie, t +(defmethod c-user-cares ((s synapse)) + (syn-relevant s)) + +(defmethod c-user-lazy (c) (declare (ignore c)) nil) +(defmethod c-user-lazy ((c c-ruled)) + (cr-lazy c)) + + +(defun c-ephemeral-reset (c) + (when c + (when (c-ephemeral-p c) + (trc nil "c-ephemeral-reset resetting:" c) + (setf (c-value c) nil)))) ;; good q: what does (setf <ephem> 'x) return? historically nil, but...? + +;----------------- change detection --------------------------------- + +(defun c-no-news (c newvalue oldvalue) + ;;; (trc nil "c-no-news > checking news between" newvalue oldvalue) + + (bIf (test (c-unchanged-test (c-model c) (c-slot-name c))) + (funcall test newvalue oldvalue) + (eql newvalue oldvalue))) + +(defmacro def-c-unchanged-test ((class slotname) &body test) + `(defmethod c-unchanged-test ((self ,class) (slotname (eql ',slotname))) + ,@test)) + +(defmethod c-unchanged-test (self slotname) + (declare (ignore self slotname)) + nil) + +(defmethod c-identity-p ((value null)) t) +(defmethod c-identity-p ((value number)) (zerop value)) +(defmethod c-identity-p ((value cons)) + ;; this def a little suspect? + (and (c-identity-p (car value)) + (c-identity-p (cdr value)))) + + +;------------------- re think --------------------------------- + +(defun cmdead (c) + (if (typep c 'synapse) + (cmdead (syn-user c)) + (if (null (c-model c)) + (not (c-optimized-away-p c)) + (mdead (c-model c))))) + +(defun mdead (m) (eq :eternal-rest (md-state m))) + +(defun c-rethink (c) + (when *stop* + (princ #\.) + (return-from c-rethink)) + ;;(trc "rethink entry: c, true-stale" c (c-true-stalep c)) + (c-assert (not (cmdead c))() "rethink entry cmdead ~a" c) + (unless (c-true-stalep c) + (return-from c-rethink)) + + (when *rethink-deferred* + (trc nil "bingo!!!!!! rethink deferring" c *cause*) + (push (list c *cause*) *rethink-deferred*) + (return-from c-rethink)) + + (c-assert (not (cmdead c))() "rethink here?? cmdead ~a" c) + + ; looking ahead for interference avoids JIT detection, which where a dependency + ; already exists causes re-entrance into the rule, which should calculate the same + ; value twice and echo only once, but still seems like something to avoid since + ; we do already have the technology. + ; + + (bIf (interf (sw-detect-interference c nil)) + (progn + (trc "!!!!!!!!!! rethink of " c :held-up-by interf) + (c-pending-set c interf :interfered) + #+dfdbg (when (trcp c) + (trc "!!!!!!!!!! rethink of " c :held-up-by interf) + #+nah (dump-stale-path interf) + ) + (return-from c-rethink)) + (when (sw-pending c) + (trc nil "no interference now for " c) + (c-pending-set c nil :dis-interfered))) + + (when (cmdead c) + (trc nil "woohoo!!! interference checking finished model off" c) + (return-from c-rethink)) + + (unless (c-true-stalep c) + (trc nil "woohoo!!! interference checking refreshed" c) + (return-from c-rethink)) + + (typecase c + (c-ruled (c-calculate-and-set c)) + + (synapse + (trc nil "c-rethink > testing rethink of: syn,salv,valu" c salvage (c-value (syn-used c))) + (if (funcall (syn-fire-p c) c (c-value (syn-used c))) + (progn + (trc nil "c-rethink> decide yes on rethink on syn, valu" c (c-value (syn-used c))) + (c-rethink (syn-user c))) + (trc nil "c-rethink> decide nooooo on rethink on synapse" c (syn-user c) salvage))) + )) + +(defmacro def-c-echo (slotname + (&optional (selfarg 'self) (newvarg 'new-value) + (oldvarg 'old-value) (oldvargboundp 'old-value-boundp)) + &body echobody) + ;;;(trc "echo body" echobody) + `(progn + (eval-when (:compile-toplevel :load-toplevel :execute) + (setf (get ',slotname :echo-defined) t)) + ,(if (eql (last1 echobody) :test) + (let ((temp1 (gensym)) + (loc-self (gensym))) + `(defmethod c-echo-slot-name #-(or clisp cormanlisp) progn ((slotname (eql ',slotname)) ,selfarg ,newvarg ,oldvarg ,oldvargboundp) + (let ((,temp1 (bump-echo-count ,slotname)) + (,loc-self ,(if (listp selfarg) + (car selfarg) + selfarg))) + (when (and ,oldvargboundp ,oldvarg) + (format t "~&echo ~d (~a ~a) old: ~a" ,temp1 ',slotname ,loc-self ,oldvarg)) + (format t "~&echo ~d (~a ~a) new: ~a" ,temp1 ',slotname ,loc-self ,newvarg)))) + `(defmethod c-echo-slot-name + #-(or clisp cormanlisp) progn + ((slotname (eql ',slotname)) ,selfarg ,newvarg ,oldvarg ,oldvargboundp) + (declare (ignorable ,(etypecase selfarg + (list (car selfarg)) + (atom selfarg)) + ,(etypecase newvarg + (list (car newvarg)) + (atom newvarg)) + ,(etypecase oldvarg + (list (car oldvarg)) + (atom oldvarg)) + ,(etypecase oldvargboundp + (list (car oldvargboundp)) + (atom oldvargboundp)))) + ,@echobody)))) + +(defmacro bump-echo-count (slotname) ;; pure test func + `(if (get ',slotname :echos) + (incf (get ',slotname :echos)) + (setf (get ',slotname :echos) 1))) + Index: cells/qells.lisp diff -u cells/qells.lisp:1.1.1.1 cells/qells.lisp:1.2 --- cells/qells.lisp:1.1.1.1 Sat Nov 8 18:44:34 2003 +++ cells/qells.lisp Tue Dec 16 10:02:58 2003 @@ -1,326 +1,326 @@ -;; -*- 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) - - -(defconstant *c-optimizep* t) -(defvar *c-prop-depth* 0) -(defvar *rethinker* nil) -(defvar *rethink-deferred* nil) -(defvar *synapse-factory* nil) -(defvar *sw-looping* nil) - -(defun cell-reset () - (kwt-reset) - (setf - *c-prop-depth* 0 - *sw-looping* nil - *to-be-awakened* nil - )) - - -(defun cellstop () - (break :in-cell-stop) - (setf *stop* t)) - -(defun cellbrk (&optional (tag :anon)) - (unless (or *stop*) - ;; daring move, hoping having handler at outside stops the game (cellstop) - (print `(cell break , tag)) - (break))) - -(defparameter *c-debug* - #+runtime-system nil - #-runtime-system nil) ;; make latter t when in trouble - - -(defvar *c-calculators* nil) - -(defmacro without-c-dependency (&body body) - `(let (*c-calculators*) ,@body)) - -(defun slot-spec-name (slot-spec) - slot-spec) - -(cc-defstruct (cell (:conc-name c-)) - waking-state - model - slot-spec - value - ) - -(defun c-slot-name (c) - (slot-spec-name (c-slot-spec c))) - -(defun c-validate (self c) - (when (not (and (c-slot-spec c) (c-model c))) -;;; (setf *stop* t) - (format t "~&unadopted cell: ~s md:~s, awake:~s" c self (c-waking-state self)) - (error 'c-unadopted :cell c))) - -(defmethod c-when (other) - (declare (ignorable other)) nil) ;; /// needs work - -(cc-defstruct (synapse - (:include cell) - (:conc-name syn-)) - user - used - fire-p - relay-value) - -(defmacro mksynapse ((&rest closeovervars) &key fire-p relay-value) - (let ((used (copy-symbol 'used)) (user (copy-symbol 'user))) - `(lambda (,used ,user) - ;; (trc "making synapse between user" ,user :and :used ,used) - (let (,@closeovervars) - (make-synapse - :used ,used - ;;; 210207kt why? use (c-model (syn-used <syn>)) :c-model (c-model ,used) - :user ,user - - :fire-p ,fire-p - :relay-value ,relay-value))))) - -(defmethod print-object ((syn synapse) stream) - (format stream "{syn ~s ==> ~s" (syn-used syn) (syn-user syn))) - - -(defmethod c-true-stalep ((syn synapse)) - (cd-stale-p (syn-user syn))) - -(cc-defstruct (c-user-notifying - (:include cell) - (:conc-name un-)) - (users nil :type list)) - -(cc-defstruct (c-unsteady - (:include c-user-notifying) - (:conc-name unst-)) - cyclic-p - delta-p - setting-p) - -(cc-defstruct (c-variable - (:include c-unsteady))) - -(cc-defstruct (c-ruled - (:include c-unsteady) - (:conc-name cr-)) - (state :unbound :type symbol) - (rethinking 0 :type number) - rule) - -(defun c-optimized-away-p (c) - (eql :optimized-away (c-state c))) - -;---------------------------- - - -(defmethod c-true-stalep (c) - (declare (ignore c))) - -(cc-defstruct (c-independent - ;; - ;; these do not optimize away, because also these can be set after initial evaluation of the rule, - ;; so users better stay tuned. - ;; the whole idea here is that the old idea of having cv bodies evaluated immediately finally - ;; broke down when we wanted to say :kids (cv (list (fm-other vertex))) - ;; - (:include c-ruled))) - -;;;(defmethod trcp ((c c-dependent)) -;;; (trcp (c-model c))) - -(cc-defstruct (c-dependent - (:include c-ruled) - (:conc-name cd-)) - (useds nil :type list) - (code nil :type list) ;; /// feature this out on production build - (usage (make-array *cd-usagect* :element-type 'bit - :initial-element 0) :type vector) - stale-p - ) - - -(defmethod c-true-stalep ((c c-dependent)) - (cd-stale-p c)) - -(cc-defstruct (c-stream - (:include c-ruled) - (:conc-name cs-)) - values) - -;;; (defmacro cell~ (&body body) -;;; `(make-c-stream -;;; :rule (lambda ,@*c-lambda* -;;; ,@body))) - -(cc-defstruct (c-drifter - (:include c-dependent))) - -(cc-defstruct (c-drifter-absolute - (:include c-drifter))) - -;_____________________ accessors __________________________________ - - -(defun (setf c-state) (new-value c) - (if (typep c 'c-ruled) - (setf (cr-state c) new-value) - new-value)) - -(defun c-state (c) - (if (typep c 'c-ruled) - (cr-state c) - :valid)) - -(defun c-unboundp (c) - (eql :unbound (c-state c))) - -(defun c-validp (c) - (find (c-state c) '(:valid :optimized-away))) - -;_____________________ print __________________________________ - -(defmethod print-object :before ((c c-variable) stream) - (declare (ignorable c)) - (format stream "[var:")) - -(defmethod print-object :before ((c c-dependent) stream) - (declare (ignorable c)) - (format stream "[dep~a:" (cond - ((null (c-model c)) #\0) - ((eq :eternal-rest (md-state (c-model c))) #\_) - ((cd-stale-p c) #\#) - ((sw-pending c) #\?) - (t #\space)))) - -(defmethod print-object :before ((c c-independent) stream) - (declare (ignorable c)) - (format stream "[ind:")) - -(defmethod print-object ((c cell) stream) - (c-print-value c stream) - (format stream "=~a/~a]" - (symbol-name (or (c-slot-name c) :anoncell)) - (or (c-model c) :anonmd)) - #+dfdbg (unless *stop* - (assert (find c (cells (c-model c)) :key #'cdr))) - ) - - -;__________________ - -(defmethod c-print-value ((c c-ruled) stream) - (format stream "~a" (cond ((unst-setting-p c) "<^^^>") - ((c-validp c) "<vld>") - ((c-unboundp c) "<unb>") - ((cd-stale-p c) "<obs>") - (t "<err>")))) - -(defmethod c-print-value (c stream) - (declare (ignore c stream))) - - -;____________________ constructors _______________________________ - -(defmacro c? (&body body) - `(make-c-dependent - :code ',body - :rule (lambda (c &aux (self (c-model c))) - (declare (ignorable self c)) - ,@body))) - (define-symbol-macro .cache. (c-value c)) - -(defmacro c?? ((&key (tagp nil) (in nil) (trigger nil) (out t))&body body) - (let ((result (copy-symbol 'result)) - (thetag (gensym))) - `(make-c-dependent - :code ',body - :rule (lambda (c &aux (self (c-model c))) - (declare (ignorable self c)) - (let ((,thetag (gensym "tag")) - (*trcdepth* (1+ *trcdepth*)) - ) - (declare (ignorable self ,thetag)) - ,(when in - `(trc "c??> entry" (c-slot-name c) (c-model c) (when ,tagp ,thetag))) - ,(when trigger `(trc "c??> trigger" *rethinker* c)) - (count-it :c?? (c-slot-name c) (md-name (c-model c))) - (let ((,result (progn ,@body))) - ,(when out `(trc "c?? result:" ,result (c-slot-name c) (when ,tagp ,thetag))) - ,result)))))) - - -(defmacro cv (defn) - `(make-c-variable - :value ,defn)) ;; use c-independent if need deferred execution - -(defmacro cv8 (defn) - `(make-c-variable - :cyclic-p t - :value ,defn)) ;; use c-independent if need deferred execution - - -(defmacro c... ((value) &body body) - `(make-c-drifter - :code ',body - :value ,value - :rule (lambda (c &aux (self (c-model c))) - (declare (ignorable self c)) - ,@body))) - -(defmacro c-abs (value &body body) - `(make-c-drifter-absolute - :code ',body - :value ,value - :rule (lambda (c &aux (self (c-model c))) - (declare (ignorable self c)) - ,@body))) - - -;;; (defmacro c?v (&body body) -;;; `(make-c-independent -;;; :rule (lambda ,@*c-lambda* -;;; (declare (ignorable self askingcells)) -;;; ,@body))) -;;; -;;; (defmacro cvpi ((&body options) defn) -;;; `(make-c-variable :value ,defn -;;; ,@options)) -;;; -;;; (defmacro ts? (&body body) -;;; `(lambda (self) -;;; (declare (ignorable self)) -;;; ,@body)) -;;; -(defmacro c8 (&body body) - `(make-c-dependent - :cyclic-p t - :rule (lambda (c) - (let ((self (c-model c)) - (*c-calculators* (cons c *c-calculators*)) - *synapse-factory* ;; clear then re-estab via with-synapse on specific dependencies - ) - ,@body)))) +;; -*- 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) + + +(defconstant *c-optimizep* t) +(defvar *c-prop-depth* 0) +(defvar *rethinker* nil) +(defvar *rethink-deferred* nil) +(defvar *synapse-factory* nil) +(defvar *sw-looping* nil) + +(defun cell-reset () + (kwt-reset) + (setf + *c-prop-depth* 0 + *sw-looping* nil + *to-be-awakened* nil + )) + + +(defun cellstop () + (break :in-cell-stop) + (setf *stop* t)) + +(defun cellbrk (&optional (tag :anon)) + (unless (or *stop*) + ;; daring move, hoping having handler at outside stops the game (cellstop) + (print `(cell break , tag)) + (break))) + +(defparameter *c-debug* + #+runtime-system nil + #-runtime-system nil) ;; make latter t when in trouble + + +(defvar *c-calculators* nil) + +(defmacro without-c-dependency (&body body) + `(let (*c-calculators*) ,@body)) + +(defun slot-spec-name (slot-spec) + slot-spec) + +(cc-defstruct (cell (:conc-name c-)) + waking-state + model + slot-spec + value + ) + +(defun c-slot-name (c) + (slot-spec-name (c-slot-spec c))) + +(defun c-validate (self c) + (when (not (and (c-slot-spec c) (c-model c))) +;;; (setf *stop* t) + (format t "~&unadopted cell: ~s md:~s, awake:~s" c self (c-waking-state self)) + (error 'c-unadopted :cell c))) + +(defmethod c-when (other) + (declare (ignorable other)) nil) ;; /// needs work + +(cc-defstruct (synapse + (:include cell) + (:conc-name syn-)) + user + used + fire-p + relay-value) + +(defmacro mksynapse ((&rest closeovervars) &key fire-p relay-value) + (let ((used (copy-symbol 'used)) (user (copy-symbol 'user))) + `(lambda (,used ,user) + ;; (trc "making synapse between user" ,user :and :used ,used) + (let (,@closeovervars) + (make-synapse + :used ,used + ;;; 210207kt why? use (c-model (syn-used <syn>)) :c-model (c-model ,used) + :user ,user + + :fire-p ,fire-p + :relay-value ,relay-value))))) + +(defmethod print-object ((syn synapse) stream) + (format stream "{syn ~s ==> ~s" (syn-used syn) (syn-user syn))) + + +(defmethod c-true-stalep ((syn synapse)) + (cd-stale-p (syn-user syn))) + +(cc-defstruct (c-user-notifying + (:include cell) + (:conc-name un-)) + (users nil :type list)) + +(cc-defstruct (c-unsteady + (:include c-user-notifying) + (:conc-name unst-)) + cyclic-p + delta-p + setting-p) + +(cc-defstruct (c-variable + (:include c-unsteady))) + +(cc-defstruct (c-ruled + (:include c-unsteady) + (:conc-name cr-)) + (state :unbound :type symbol) + (rethinking 0 :type number) + rule) + +(defun c-optimized-away-p (c) + (eql :optimized-away (c-state c))) + +;---------------------------- + + +(defmethod c-true-stalep (c) + (declare (ignore c))) + +(cc-defstruct (c-independent + ;; + ;; these do not optimize away, because also these can be set after initial evaluation of the rule, + ;; so users better stay tuned. + ;; the whole idea here is that the old idea of having cv bodies evaluated immediately finally + ;; broke down when we wanted to say :kids (cv (list (fm-other vertex))) + ;; + (:include c-ruled))) + +;;;(defmethod trcp ((c c-dependent)) +;;; (trcp (c-model c))) + +(cc-defstruct (c-dependent + (:include c-ruled) + (:conc-name cd-)) + (useds nil :type list) + (code nil :type list) ;; /// feature this out on production build + (usage (make-array *cd-usagect* :element-type 'bit + :initial-element 0) :type vector) + stale-p + ) + + +(defmethod c-true-stalep ((c c-dependent)) + (cd-stale-p c)) + +(cc-defstruct (c-stream + (:include c-ruled) + (:conc-name cs-)) + values) + +;;; (defmacro cell~ (&body body) +;;; `(make-c-stream +;;; :rule (lambda ,@*c-lambda* +;;; ,@body))) + +(cc-defstruct (c-drifter + (:include c-dependent))) + +(cc-defstruct (c-drifter-absolute + (:include c-drifter))) + +;_____________________ accessors __________________________________ + + +(defun (setf c-state) (new-value c) + (if (typep c 'c-ruled) + (setf (cr-state c) new-value) + new-value)) + +(defun c-state (c) + (if (typep c 'c-ruled) + (cr-state c) + :valid)) + +(defun c-unboundp (c) + (eql :unbound (c-state c))) + +(defun c-validp (c) + (find (c-state c) '(:valid :optimized-away))) + +;_____________________ print __________________________________ + +(defmethod print-object :before ((c c-variable) stream) + (declare (ignorable c)) + (format stream "[var:")) + +(defmethod print-object :before ((c c-dependent) stream) + (declare (ignorable c)) + (format stream "[dep~a:" (cond + ((null (c-model c)) #\0) + ((eq :eternal-rest (md-state (c-model c))) #\_) + ((cd-stale-p c) #\#) + ((sw-pending c) #\?) + (t #\space)))) + +(defmethod print-object :before ((c c-independent) stream) + (declare (ignorable c)) + (format stream "[ind:")) + +(defmethod print-object ((c cell) stream) + (c-print-value c stream) + (format stream "=~a/~a]" + (symbol-name (or (c-slot-name c) :anoncell)) + (or (c-model c) :anonmd)) + #+dfdbg (unless *stop* + (assert (find c (cells (c-model c)) :key #'cdr))) + ) + + +;__________________ + +(defmethod c-print-value ((c c-ruled) stream) + (format stream "~a" (cond ((unst-setting-p c) "<^^^>") + ((c-validp c) "<vld>") + ((c-unboundp c) "<unb>") + ((cd-stale-p c) "<obs>") + (t "<err>")))) + +(defmethod c-print-value (c stream) + (declare (ignore c stream))) + + +;____________________ constructors _______________________________ + +(defmacro c? (&body body) + `(make-c-dependent + :code ',body + :rule (lambda (c &aux (self (c-model c))) + (declare (ignorable self c)) + ,@body))) + (define-symbol-macro .cache. (c-value c)) + +(defmacro c?? ((&key (tagp nil) (in nil) (trigger nil) (out t))&body body) + (let ((result (copy-symbol 'result)) + (thetag (gensym))) + `(make-c-dependent + :code ',body + :rule (lambda (c &aux (self (c-model c))) + (declare (ignorable self c)) + (let ((,thetag (gensym "tag")) + (*trcdepth* (1+ *trcdepth*)) + ) + (declare (ignorable self ,thetag)) + ,(when in + `(trc "c??> entry" (c-slot-name c) (c-model c) (when ,tagp ,thetag))) + ,(when trigger `(trc "c??> trigger" *rethinker* c)) + (count-it :c?? (c-slot-name c) (md-name (c-model c))) + (let ((,result (progn ,@body))) + ,(when out `(trc "c?? result:" ,result (c-slot-name c) (when ,tagp ,thetag))) + ,result)))))) + + +(defmacro cv (defn) + `(make-c-variable + :value ,defn)) ;; use c-independent if need deferred execution + +(defmacro cv8 (defn) + `(make-c-variable + :cyclic-p t + :value ,defn)) ;; use c-independent if need deferred execution + + +(defmacro c... ((value) &body body) + `(make-c-drifter + :code ',body + :value ,value + :rule (lambda (c &aux (self (c-model c))) + (declare (ignorable self c)) + ,@body))) + +(defmacro c-abs (value &body body) + `(make-c-drifter-absolute + :code ',body + :value ,value + :rule (lambda (c &aux (self (c-model c))) + (declare (ignorable self c)) + ,@body))) + + +;;; (defmacro c?v (&body body) +;;; `(make-c-independent +;;; :rule (lambda ,@*c-lambda* +;;; (declare (ignorable self askingcells)) +;;; ,@body))) +;;; +;;; (defmacro cvpi ((&body options) defn) +;;; `(make-c-variable :value ,defn +;;; ,@options)) +;;; +;;; (defmacro ts? (&body body) +;;; `(lambda (self) +;;; (declare (ignorable self)) +;;; ,@body)) +;;; +(defmacro c8 (&body body) + `(make-c-dependent + :cyclic-p t + :rule (lambda (c) + (let ((self (c-model c)) + (*c-calculators* (cons c *c-calculators*)) + *synapse-factory* ;; clear then re-estab via with-synapse on specific dependencies + ) + ,@body)))) Index: cells/qrock.lisp diff -u cells/qrock.lisp:1.1.1.1 cells/qrock.lisp:1.2 --- cells/qrock.lisp:1.1.1.1 Sat Nov 8 18:44:46 2003 +++ cells/qrock.lisp Tue Dec 16 10:02:58 2003 @@ -1,83 +1,83 @@ -;; -*- 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) - -(defstruct (qrock (:include strudel-object)(:conc-name nil)) - (.accel 32) - (.elapsed (cv 0)) - (.dist (c? (floor (* (qaccel self)(expt (elapsed self) 2)) 2)))) - -(defun qaccel (self) - (q-slot-value (.accel self))) - -(defun (setf qaccel) (newvalue self) - (setf (md-slot-value self '.accel) newvalue)) - -(defun elapsed (self) - (q-slot-value (.elapsed self))) - -(defun (setf elapsed) (newvalue self) - (setf (md-slot-value self '.elapsed) newvalue)) - -(defun dist (self) - (q-slot-value (.dist self))) - -(defun (setf dist) (newvalue self) - (setf (md-slot-value self '.dist) newvalue)) - -(def-c-echo .accel () (trc ".accel" self new-value old-value)) -(def-c-echo .elapsed () - (when (typep new-value 'cell) (break)) - (trc ".elapsed" self new-value old-value)) -(def-c-echo .dist () (trc ".dist" self new-value old-value)) - -(progn - (setf (md-slot-cell-type 'qrock '.accel) t) - (setf (md-slot-cell-type 'qrock '.elapsed) t) - (setf (md-slot-cell-type 'qrock '.dist) t)) - -(defun make-cell-qrock (&rest iargs) - (let ((self (apply #'make-qrock iargs))) - (strudel-initialize self) - (trc "qcs" (q-cells self)) - self)) - -#+test -(let (*to-be-awakened*) - (let ((r (to-be (make-cell-qrock)))) - (dotimes (n 5) - (trc "--------------- time " n) - (setf (elapsed r) n)))) - -(defmethod strudel-initialize :around ((self qrock)) - (flet ((ci (sn sv) - (when (typep sv 'cell) - (q-install self sn sv)))) - (ci '.accel (.accel self)) - (ci '.elapsed (.elapsed self)) - (ci '.dist (.dist self))) - (call-next-method)) - - +;; -*- 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) + +(defstruct (qrock (:include strudel-object)(:conc-name nil)) + (.accel 32) + (.elapsed (cv 0)) + (.dist (c? (floor (* (qaccel self)(expt (elapsed self) 2)) 2)))) + +(defun qaccel (self) + (q-slot-value (.accel self))) + +(defun (setf qaccel) (newvalue self) + (setf (md-slot-value self '.accel) newvalue)) + +(defun elapsed (self) + (q-slot-value (.elapsed self))) + +(defun (setf elapsed) (newvalue self) + (setf (md-slot-value self '.elapsed) newvalue)) + +(defun dist (self) + (q-slot-value (.dist self))) + +(defun (setf dist) (newvalue self) + (setf (md-slot-value self '.dist) newvalue)) + +(def-c-echo .accel () (trc ".accel" self new-value old-value)) +(def-c-echo .elapsed () + (when (typep new-value 'cell) (break)) + (trc ".elapsed" self new-value old-value)) +(def-c-echo .dist () (trc ".dist" self new-value old-value)) + +(progn + (setf (md-slot-cell-type 'qrock '.accel) t) + (setf (md-slot-cell-type 'qrock '.elapsed) t) + (setf (md-slot-cell-type 'qrock '.dist) t)) + +(defun make-cell-qrock (&rest iargs) + (let ((self (apply #'make-qrock iargs))) + (strudel-initialize self) + (trc "qcs" (q-cells self)) + self)) + +#+test +(let (*to-be-awakened*) + (let ((r (to-be (make-cell-qrock)))) + (dotimes (n 5) + (trc "--------------- time " n) + (setf (elapsed r) n)))) + +(defmethod strudel-initialize :around ((self qrock)) + (flet ((ci (sn sv) + (when (typep sv 'cell) + (q-install self sn sv)))) + (ci '.accel (.accel self)) + (ci '.elapsed (.elapsed self)) + (ci '.dist (.dist self))) + (call-next-method)) + + Index: cells/slot-utilities.lisp diff -u cells/slot-utilities.lisp:1.1.1.1 cells/slot-utilities.lisp:1.2 --- cells/slot-utilities.lisp:1.1.1.1 Sat Nov 8 18:44:46 2003 +++ cells/slot-utilities.lisp Tue Dec 16 10:02:58 2003 @@ -1,91 +1,95 @@ -;; -*- 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) - -(defun c-setting-debug (self slot-spec c newvalue) - (declare (ignorable newvalue)) - (if (null c) - (progn - (format t "c-setting-debug > constant ~a in ~a may not be altered..init to (cv nil)" - slot-spec self) - (error "setting-const-cell")) - (let ((self (c-model c)) - (slot-spec (c-slot-spec c))) - ;(trc "c-setting-debug sees" c newvalue self slot-spec) - (when (and c (not (and slot-spec self))) - ;; cv-test handles errors, so don't set *stop* (cellstop) - (error 'c-unadopted :cell c)) - (typecase c - (c-variable) - (c-independent) - (c-dependent - ;(trc "setting c-dependent" c newvalue) - (format t "c-setting-debug > ruled ~a in ~a may not be setf'ed" - (c-slot-name c) self) - (error "setting-ruled-cell")) - )))) - -(defun c-absorb-value (c value) - (typecase c - (c-drifter-absolute (c-value-incf c value 0)) ;; strange but true - (c-drifter (c-value-incf c (c-value c) value)) - (t value))) - -(defmethod c-value-incf (c (envaluer c-envaluer) delta) - (assert (c-model c)) - (c-value-incf c (funcall (envaluerule envaluer) (c-model c)) - delta)) - -(defmethod c-value-incf (c (base number) delta) - (declare (ignore c)) - (if delta - (+ base delta) - base)) - - -;---------------------------------------------------------------------- - -(defun bd-slot-value (self slot-spec) - (slot-value self (slot-spec-name slot-spec))) - -(defun (setf bd-slot-value) (newvalue self slot-spec) - (setf (slot-value self (slot-spec-name slot-spec)) newvalue)) - -(defun bd-bound-slot-value (self slot-spec callerid) - (declare (ignorable callerid)) - (when (bd-slot-boundp self (slot-spec-name slot-spec)) - (bd-slot-value self (slot-spec-name slot-spec)))) - -(defun bd-slot-boundp (self slot-spec) - (slot-boundp self (slot-spec-name slot-spec))) - -(defun bd-slot-makunbound (self slot-spec) - (slot-makunbound self (slot-spec-name slot-spec))) - -#| sample incf -(defmethod c-value-incf ((base fpoint) delta) - (declare (ignore model)) - (if delta - (fp-add base delta) - base)) -|# +;; -*- 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) + +(defun c-setting-debug (self slot-spec c newvalue) + (declare (ignorable newvalue)) + (if (null c) + (progn + (format t "c-setting-debug > constant ~a in ~a may not be altered..init to (cv nil)" + slot-spec self) + + (c-break "setting-const-cell") + (error "setting-const-cell")) + (let ((self (c-model c)) + (slot-spec (c-slot-spec c))) + ;(trc "c-setting-debug sees" c newvalue self slot-spec) + (when (and c (not (and slot-spec self))) + ;; cv-test handles errors, so don't set *stop* (c-stop) + (c-break "unadopted ~a for self ~a spec ~a" c self slot-spec) + (error 'c-unadopted :cell c)) + (typecase c + (c-variable) + (c-dependent + ;(trc "setting c-dependent" c newvalue) + (format t "c-setting-debug > ruled ~a in ~a may not be setf'ed" + (c-slot-name c) self) + + (c-break "setting-ruled-cell") + (error "setting-ruled-cell")) + )))) + +(defun c-absorb-value (c value) + (typecase c + (c-drifter-absolute (c-value-incf c value 0)) ;; strange but true + (c-drifter (c-value-incf c (c-value c) value)) + (t value))) + +(defmethod c-value-incf (c (envaluer c-envaluer) delta) + (c-assert (c-model c)) + (c-value-incf c (funcall (envaluerule envaluer) c) + delta)) + +(defmethod c-value-incf (c (base number) delta) + (declare (ignore c)) + (if delta + (+ base delta) + base)) + + +;---------------------------------------------------------------------- + +(defun bd-slot-value (self slot-spec) + (slot-value self (slot-spec-name slot-spec))) + +(defun (setf bd-slot-value) (newvalue self slot-spec) + (setf (slot-value self (slot-spec-name slot-spec)) newvalue)) + +(defun bd-bound-slot-value (self slot-spec callerid) + (declare (ignorable callerid)) + (when (bd-slot-boundp self (slot-spec-name slot-spec)) + (bd-slot-value self (slot-spec-name slot-spec)))) + +(defun bd-slot-boundp (self slot-spec) + (slot-boundp self (slot-spec-name slot-spec))) + +(defun bd-slot-makunbound (self slot-spec) + (slot-makunbound self (slot-spec-name slot-spec))) + +#| sample incf +(defmethod c-value-incf ((base fpoint) delta) + (declare (ignore model)) + (if delta + (fp-add base delta) + base)) +|# Index: cells/strings.lisp diff -u cells/strings.lisp:1.1.1.1 cells/strings.lisp:1.2 --- cells/strings.lisp:1.1.1.1 Sat Nov 8 18:44:46 2003 +++ cells/strings.lisp Tue Dec 16 10:02:58 2003 @@ -1,204 +1,204 @@ -;; -*- 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 load eval) - (export '(case$ strloc$ make$ space$ char$ conclist$ conc$ - left$ mid$ seg$ right$ insert$ remove$ - trim$ trunc$ abbrev$ empty$ find$ num$ - normalize$ down$ lower$ up$ upper$ equal$ - min$ numeric$ alpha$ assoc$ member$ match-left$ - +return$+ +LF$+))) - -(defmacro case$ (stringForm &rest cases) - (let ((v$ (gensym)) - (default (or (find 'otherwise cases :key #'car) - (find 'otherwise cases :key #'car)))) - (when default - (setf cases (delete default cases))) - `(let ((,v$ ,stringForm)) - (cond - ,@(mapcar (lambda (caseForms) - `((string-equal ,v$ ,(car caseForms)) ,@(rest caseForms))) - cases) - (t ,@(or (cdr default) `(nil))))))) - -;-------- - -(defmethod shortc (other) - (declare (ignorable other)) - (concatenate 'string "noshortc" (symbol-name (class-name (class-of other))))) - -(defmethod longc (other) (shortc other)) - -(defmethod shortc ((nada null)) nil) -(defmethod shortc ((many list)) - (if (consp (cdr many)) - (mapcar #'shortc many) - (conc$ (shortc (car many)) " " (shortc (cdr many))))) -(defmethod shortc ((self string)) self) -(defmethod shortc ((self symbol)) (string self)) -(defmethod shortc ((self number)) (num$ self)) -(defmethod shortc ((self character)) (string self)) - -;----------------------- - -(defun strloc$ (substr str) - (when (and substr str (not (string= substr ""))) - (search substr str))) - -(defun make$ (&optional (size 0) (char #\space)) - (make-string size :initial-element (etypecase char - (character char) - (number (code-char char))))) - -(DEFUN space$ (size) - (make$ size)) - -(defun char$ (char) - (make$ 1 char)) - -(defun conclist$ (ss) - (when ss - (reduce (lambda (s1 s2) (concatenate 'string s1 s2)) ss))) - -(defun conc$ (&rest ss) - (with-output-to-string (stream) - (dolist (s ss) - (when s - (princ (shortc s) stream))))) - -(defun left$ (s n) - (subseq s 0 (max (min n (length s)) 0))) - -(defun mid$ (s offset length) - (let* ((slen (length s)) - (start (min slen (max offset 0))) - (end (max start (min (+ offset length) slen)))) - (subseq s start end))) - -(defun seg$ (s offset end) - (let* ((slen (length s)) - (start (min slen (max offset 0))) - (end (max start (min end slen)))) - (subseq s start end))) - -(defun right$ (s n) - (subseq s (min n (length s)))) - -(defun insert$ (s c &optional (offset (length s))) - (conc$ (subseq s 0 offset) - (string c) - (subseq s offset))) - -(defun remove$ (s offset) - (conc$ (subseq s 0 (1- offset)) - (subseq s offset))) - -(defun trim$ (s) - (assert (or (null s) (stringp s))) - (string-trim '(#\space) s)) - -(defun trunc$ (s char) - (let ((pos (position char s))) - (if pos - (subseq s 0 pos) - s))) - -(defun abbrev$ (long$ max) - (if (<= (length long$) max) - long$ - (conc$ (left$ long$ (- max 3)) "..."))) - -(defmethod empty ((nada null)) t) -(defmethod empty ((c cons)) - (and (empty (car c)) - (empty (cdr c)))) -(defmethod empty ((s string)) (empty$ s)) -(defmethod empty (other) (declare (ignorable other)) nil) - -(defun empty$ (s) - (or (null s) - (if (stringp s) - (string-equal "" (trim$ s)) - #+not (trc nil "empty$> sees non-string" (type-of s))) - )) - -(defmacro find$ (it where &rest args) - `(find ,it ,where ,@args :test #'string-equal)) - -(defmethod num$ ((n number)) - (format nil "~d" n)) - -(defmethod num$ (n) - (format nil "~d" n)) - -(defun normalize$ (s) - (etypecase s - (null "") - (string (string-downcase s)) - (symbol (string-downcase (symbol-name s))))) - -(defun down$ (s) - (string-downcase s)) - -(defun lower$ (s) - (string-downcase s)) - -(defun up$ (s) - (string-upcase s)) - -(defun upper$ (s) - (string-upcase s)) - -(defun equal$ (s1 s2) - (if (empty$ s1) - (empty$ s2) - (when s2 - (string-equal s1 s2)))) - -(defun min$ (&rest ss) - (cond - ((null ss) nil) - ((null (cdr ss)) (car ss)) - (t (let ((rmin$ (apply #'min$ (cdr ss)))) - (if (string< (car ss) rmin$) - (car ss) rmin$))))) - -(defun numeric$ (s &optional trimmed) - (every (lambda (c) (digit-char-p c)) (if trimmed (Trim$ s) s))) - -(defun alpha$ (s) - (every (lambda (c) (alpha-char-p c)) s)) - -(defmacro assoc$ (item alist &rest kws) - `(assoc ,item ,alist :test #'equal ,@kws)) - -(defmacro member$ (item list &rest kws) - `(member ,item ,list :test #'string= ,@kws)) - -(defun match-left$ (a b) - (string-equal a (subseq b 0 (length a)))) - -(defparameter *return$* (conc$ (char$ #\return) (char$ #\linefeed))) -(defparameter *LF$* (string #\linefeed)) +;; -*- 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 load eval) + (export '(case$ strloc$ make$ space$ char$ conclist$ conc$ + left$ mid$ seg$ right$ insert$ remove$ + trim$ trunc$ abbrev$ empty$ find$ num$ + normalize$ down$ lower$ up$ upper$ equal$ + min$ numeric$ alpha$ assoc$ member$ match-left$ + +return$+ +LF$+))) + +(defmacro case$ (stringForm &rest cases) + (let ((v$ (gensym)) + (default (or (find 'otherwise cases :key #'car) + (find 'otherwise cases :key #'car)))) + (when default + (setf cases (delete default cases))) + `(let ((,v$ ,stringForm)) + (cond + ,@(mapcar (lambda (caseForms) + `((string-equal ,v$ ,(car caseForms)) ,@(rest caseForms))) + cases) + (t ,@(or (cdr default) `(nil))))))) + +;-------- + +(defmethod shortc (other) + (declare (ignorable other)) + (concatenate 'string "noshortc" (symbol-name (class-name (class-of other))))) + +(defmethod longc (other) (shortc other)) + +(defmethod shortc ((nada null)) nil) +(defmethod shortc ((many list)) + (if (consp (cdr many)) + (mapcar #'shortc many) + (conc$ (shortc (car many)) " " (shortc (cdr many))))) +(defmethod shortc ((self string)) self) +(defmethod shortc ((self symbol)) (string self)) +(defmethod shortc ((self number)) (num$ self)) +(defmethod shortc ((self character)) (string self)) + +;----------------------- + +(defun strloc$ (substr str) + (when (and substr str (not (string= substr ""))) + (search substr str))) + +(defun make$ (&optional (size 0) (char #\space)) + (make-string size :initial-element (etypecase char + (character char) + (number (code-char char))))) + +(DEFUN space$ (size) + (make$ size)) + +(defun char$ (char) + (make$ 1 char)) + +(defun conclist$ (ss) + (when ss + (reduce (lambda (s1 s2) (concatenate 'string s1 s2)) ss))) + +(defun conc$ (&rest ss) + (with-output-to-string (stream) + (dolist (s ss) + (when s + (princ (shortc s) stream))))) + +(defun left$ (s n) + (subseq s 0 (max (min n (length s)) 0))) + +(defun mid$ (s offset length) + (let* ((slen (length s)) + (start (min slen (max offset 0))) + (end (max start (min (+ offset length) slen)))) + (subseq s start end))) + +(defun seg$ (s offset end) + (let* ((slen (length s)) + (start (min slen (max offset 0))) + (end (max start (min end slen)))) + (subseq s start end))) + +(defun right$ (s n) + (subseq s (min n (length s)))) + +(defun insert$ (s c &optional (offset (length s))) + (conc$ (subseq s 0 offset) + (string c) + (subseq s offset))) + +(defun remove$ (s offset) + (conc$ (subseq s 0 (1- offset)) + (subseq s offset))) + +(defun trim$ (s) + (c-assert (or (null s) (stringp s))) + (string-trim '(#\space) s)) + +(defun trunc$ (s char) + (let ((pos (position char s))) + (if pos + (subseq s 0 pos) + s))) + +(defun abbrev$ (long$ max) + (if (<= (length long$) max) + long$ + (conc$ (left$ long$ (- max 3)) "..."))) + +(defmethod empty ((nada null)) t) +(defmethod empty ((c cons)) + (and (empty (car c)) + (empty (cdr c)))) +(defmethod empty ((s string)) (empty$ s)) +(defmethod empty (other) (declare (ignorable other)) nil) + +(defun empty$ (s) + (or (null s) + (if (stringp s) + (string-equal "" (trim$ s)) + #+not (trc nil "empty$> sees non-string" (type-of s))) + )) + +(defmacro find$ (it where &rest args) + `(find ,it ,where ,@args :test #'string-equal)) + +(defmethod num$ ((n number)) + (format nil "~d" n)) + +(defmethod num$ (n) + (format nil "~d" n)) + +(defun normalize$ (s) + (etypecase s + (null "") + (string (string-downcase s)) + (symbol (string-downcase (symbol-name s))))) + +(defun down$ (s) + (string-downcase s)) + +(defun lower$ (s) + (string-downcase s)) + +(defun up$ (s) + (string-upcase s)) + +(defun upper$ (s) + (string-upcase s)) + +(defun equal$ (s1 s2) + (if (empty$ s1) + (empty$ s2) + (when s2 + (string-equal s1 s2)))) + +(defun min$ (&rest ss) + (cond + ((null ss) nil) + ((null (cdr ss)) (car ss)) + (t (let ((rmin$ (apply #'min$ (cdr ss)))) + (if (string< (car ss) rmin$) + (car ss) rmin$))))) + +(defun numeric$ (s &optional trimmed) + (every (lambda (c) (digit-char-p c)) (if trimmed (Trim$ s) s))) + +(defun alpha$ (s) + (every (lambda (c) (alpha-char-p c)) s)) + +(defmacro assoc$ (item alist &rest kws) + `(assoc ,item ,alist :test #'equal ,@kws)) + +(defmacro member$ (item list &rest kws) + `(member ,item ,list :test #'string= ,@kws)) + +(defun match-left$ (a b) + (string-equal a (subseq b 0 (length a)))) + +(defparameter *return$* (conc$ (char$ #\return) (char$ #\linefeed))) +(defparameter *LF$* (string #\linefeed)) Index: cells/strudel-object.lisp diff -u cells/strudel-object.lisp:1.1.1.1 cells/strudel-object.lisp:1.2 --- cells/strudel-object.lisp:1.1.1.1 Sat Nov 8 18:44:46 2003 +++ cells/strudel-object.lisp Tue Dec 16 10:02:58 2003 @@ -1,145 +1,145 @@ -;; -*- 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) - -;----------------- model-object ---------------------- - -(eval-when (:compile-toplevel :load-toplevel :execute) - (export '(strudel-object))) - -(cc-defstruct (strudel-object (:conc-name nil)) - (q-state :nascent :type keyword) ; [nil | :nascent | :alive | :doomed] - (q-name nil :type symbol) - (q-parent nil) - (q-cells nil :type list) - (q-cells-flushed nil :type list) - (q-adopt-ct 0 :type fixnum)) - -(defmethod strudel-initialize (self) - (unless (q-name self) - (setf (q-name self) (class-name (class-of self)))) - - #+wait (when (q-parent self) - (q-adopt (q-parent self) self)) - self) - -(defmethod cells ((self strudel-object)) - (q-cells self)) - -(defmethod (setf cells) (new-value (self strudel-object)) - (setf (q-cells self) new-value)) - -(defmethod kids ((other strudel-object)) nil) - -(defun q-install (self sn c) - (assert (typep c 'cell)) - (trc nil "installing cell" sn c) - (setf - (c-model c) self - (c-slot-spec c) sn - (md-slot-cell self sn) c)) - -(defmethod (setf md-state) (newv (self strudel-object)) - (setf (q-state self) newv)) - -(defmethod md-state ((self strudel-object)) - (q-state self)) - -(defmethod md-name ((self strudel-object)) (q-name self)) -(defmethod fmparent ((self strudel-object)) (q-parent self)) - -(defmethod print-object ((self strudel-object) s) - (format s "~a" (or (md-name self) (type-of self)))) - -(defun q-slot-value (slot-c) - (when *stop* - (princ #\.) - (return-from q-slot-value)) - ;; (count-it :q-slot-value slot-name slot-spec)) - -;;; (when (eql :nascent (q-state self)) -;;; (md-awaken self)) - - (let ((slot-value (typecase slot-c - (c-variable (c-value slot-c)) - - (c-ruled (cond - ((c-validp slot-c) (c-value slot-c)) ;; good to go - - ((find slot-c *c-calculators*) ;; circularity - (setf *stop* t) - (trc "q-slot-value breaking on circlularity" slot-c *c-calculators*) - (error "cell ~a midst askers: ~a" slot-c *c-calculators*)) - - (t (let ((*cause* :on-demand)) ; normal path first time asked - (trc nil "md-slot-value calc" self slot-spec *c-calculators*) - (c-calculate-and-set slot-c))))) - (otherwise (return-from q-slot-value slot-c))))) - - (bif (synapse (when (car *c-calculators*) - (c-link-ex slot-c))) - (c-relay-value synapse slot-value) - slot-value))) - - - - -(defmethod md-awaken :around ((self strudel-object)) - (trc nil "md-awaken entry" self (md-state self)) - (assert (eql :nascent (md-state self))) - ;; (trc nil "awaken doing") - (count-it :md-awaken) - ;;(count-it 'mdawaken (type-of self)) - (setf (md-state self) :awakening) - ;; (trc "md-awaken entry" self) - (dolist (esd (class-slots (class-of self))) - ;;(trc "md-awaken scoping slot" self (slot-definition-name esd)) - (when (md-slot-cell-type (type-of self) (slot-definition-name esd)) - (let ((slot-name (slot-definition-name esd))) - (if (not (c-echo-defined slot-name)) - (progn ;; (count-it :md-awaken :no-echo-slot slot-name) - (trc nil "md-awaken deferring cell-awaken since no echo" self esd)) - - (let ((cell (md-slot-cell self slot-name))) - (trc nil "md-awaken finds md-esd-cell " self slot-name cell) - - - (if cell - (c-awaken cell) - ; - ; next bit revised to avoid double-echo of optimized cells - ; - (progn - (when (eql '.kids slot-name) - (bwhen (sv (slot-value self '.kids)) - (md-kids-change self sv nil :md-awaken-slot))) - (c-echo-initially self slot-name))))))) - ) - - (setf (md-state self) :awake) - self) - -(defmethod md-slot-value-store ((self strudel-object) slot-spec new-value) - (declare (ignorable slot-spec)) +;; -*- 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) + +;----------------- model-object ---------------------- + +(eval-when (:compile-toplevel :load-toplevel :execute) + (export '(strudel-object))) + +(cc-defstruct (strudel-object (:conc-name nil)) + (q-state :nascent :type keyword) ; [nil | :nascent | :alive | :doomed] + (q-name nil :type symbol) + (q-parent nil) + (q-cells nil :type list) + (q-cells-flushed nil :type list) + (q-adopt-ct 0 :type fixnum)) + +(defmethod strudel-initialize (self) + (unless (q-name self) + (setf (q-name self) (class-name (class-of self)))) + + #+wait (when (q-parent self) + (q-adopt (q-parent self) self)) + self) + +(defmethod cells ((self strudel-object)) + (q-cells self)) + +(defmethod (setf cells) (new-value (self strudel-object)) + (setf (q-cells self) new-value)) + +(defmethod kids ((other strudel-object)) nil) + +(defun q-install (self sn c) + (assert (typep c 'cell)) + (trc nil "installing cell" sn c) + (setf + (c-model c) self + (c-slot-spec c) sn + (md-slot-cell self sn) c)) + +(defmethod (setf md-state) (newv (self strudel-object)) + (setf (q-state self) newv)) + +(defmethod md-state ((self strudel-object)) + (q-state self)) + +(defmethod md-name ((self strudel-object)) (q-name self)) +(defmethod fm-parent ((self strudel-object)) (q-parent self)) + +(defmethod print-object ((self strudel-object) s) + (format s "~a" (or (md-name self) (type-of self)))) + +(defun q-slot-value (slot-c) + (when *stop* + (princ #\.) + (return-from q-slot-value)) + ;; (count-it :q-slot-value slot-name slot-spec)) + +;;; (when (eql :nascent (q-state self)) +;;; (md-awaken self)) + + (let ((slot-value (typecase slot-c + (c-variable (c-value slot-c)) + + (c-ruled (cond + ((c-validp slot-c) (c-value slot-c)) ;; good to go + + ((find slot-c *c-calculators*) ;; circularity + (setf *stop* t) + (trc "q-slot-value breaking on circlularity" slot-c *c-calculators*) + (error "cell ~a midst askers: ~a" slot-c *c-calculators*)) + + (t (let ((*cause* :on-demand)) ; normal path first time asked + (trc nil "md-slot-value calc" self slot-spec *c-calculators*) + (c-calculate-and-set slot-c))))) + (otherwise (return-from q-slot-value slot-c))))) + + (bif (synapse (when (car *c-calculators*) + (c-link-ex slot-c))) + (c-relay-value synapse slot-value) + slot-value))) + + + + +(defmethod md-awaken :around ((self strudel-object)) + (trc nil "md-awaken entry" self (md-state self)) + (assert (eql :nascent (md-state self))) + ;; (trc nil "awaken doing") + (count-it :md-awaken) + ;;(count-it 'mdawaken (type-of self)) + (setf (md-state self) :awakening) + ;; (trc "md-awaken entry" self) + (dolist (esd (class-slots (class-of self))) + ;;(trc "md-awaken scoping slot" self (slot-definition-name esd)) + (when (md-slot-cell-type (type-of self) (slot-definition-name esd)) + (let ((slot-name (slot-definition-name esd))) + (if (not (c-echo-defined slot-name)) + (progn ;; (count-it :md-awaken :no-echo-slot slot-name) + (trc nil "md-awaken deferring cell-awaken since no echo" self esd)) + + (let ((cell (md-slot-cell self slot-name))) + (trc nil "md-awaken finds md-esd-cell " self slot-name cell) + + + (if cell + (c-awaken cell) + ; + ; next bit revised to avoid double-echo of optimized cells + ; + (progn + (when (eql '.kids slot-name) + (bwhen (sv (slot-value self '.kids)) + (md-kids-change self sv nil :md-awaken-slot))) + (c-echo-initially self slot-name))))))) + ) + + (setf (md-state self) :awake) + self) + +(defmethod md-slot-value-store ((self strudel-object) slot-spec new-value) + (declare (ignorable slot-spec)) new-value) Index: cells/synapse.lisp diff -u cells/synapse.lisp:1.1.1.1 cells/synapse.lisp:1.2 --- cells/synapse.lisp:1.1.1.1 Sat Nov 8 18:44:46 2003 +++ cells/synapse.lisp Tue Dec 16 10:02:58 2003 @@ -1,213 +1,213 @@ -;; -*- 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-toplevel :load-toplevel :execute) - (export '(mksynapse fDelta fSensitivity fPlusp fZerop fDifferent))) - -; ___________________________ cell relay value ___________________________________ - -(defparameter *relayspeak* nil) -(defmethod c-relay-value ((syn synapse) value) - ;(trc "c-relay-value> syn, raw value:" syn value) - (let ((res (funcall (syn-relay-value syn) syn value))) - ;(trc "c-relay-value> cell, filtered value:" syn res) - res)) - -(defmethod c-relay-value (cell value) - (declare (ignorable cell)) - (when *relayspeak* - (trc "c-relay-value unspecial > cell value" cell value) - (setf *relayspeak* nil)) - value) - -;__________________________________________________________________________________ -; -(defmethod delta-diff ((new number) (old number) subtypename) - (declare (ignore subtypename)) - (- new old)) - -(defmethod delta-identity ((dispatcher number) subtypename) - (declare (ignore subtypename)) - 0) - -(defmethod delta-abs ((n number) subtypename) - (declare (ignore subtypename)) - (abs n)) - -(defmethod delta-exceeds ((d1 number) (d2 number) subtypename) - (declare (ignore subtypename)) - (> d1 d2)) - -(defmethod delta-greater-or-equal ((d1 number) (d2 number) subtypename) - (declare (ignore subtypename)) - (>= d1 d2)) - -;_________________________________________________________________________________ -; -(defmethod delta-diff (new old (subtypename (eql 'boolean))) - (if new - (if old - :unchanged - :on) - (if old - :off - :unchanged))) - - -(defmethod delta-identity (dispatcher (subtypename (eql 'boolean))) - (declare (ignore dispatcher)) - :unchanged) - -;______________________________________________________________ - -(defun fdeltalist (&key (test #'true)) - (mksynapse (priorlist) - :fire-p (lambda (syn newlist) - (declare (ignorable syn)) - (or (find-if (lambda (new) - ;--- gaining one? ---- - (and (not (member new priorlist)) - (funcall test new))) - newlist) - (find-if (lambda (old) - ;--- losing one? ---- - (not (member old newlist))) ;; all olds have passed test, so skip test here - priorlist))) - - :relay-value (lambda (syn newlist) - (declare (ignorable syn)) - ;/// excess consing on long lists - (setf priorlist (remove-if-not test newlist))))) - -;_______________________________________________________________ - -(defun ffindonce (finderfn) - (mksynapse (bingo bingobound) - - :fire-p (lambda (syn newlist) - (declare (ignorable syn)) - (unless bingo ;; once found, yer done - (setf bingobound t - bingo (find-if finderfn newlist)))) - - :relay-value (lambda (syn newlist) - (declare (ignorable syn)) - (or bingo - (and (not bingobound) ;; don't bother if fire? already looked - (find-if finderfn newlist)))))) - -;___________________________________________________________________ - -(defun fsensitivity (sensitivity &optional subtypename) - (mksynapse (priorrelayvalue) - :fire-p (lambda (syn newvalue) - (declare (ignorable syn)) - (trc nil "fire-p decides" priorrelayvalue sensitivity) - (or (xor priorrelayvalue newvalue) - (eko (nil "fire-p decides" newvalue 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 (nil "fsensitivity relays") - (setf priorrelayvalue newvalue)) ;; no modulation of value, but do record for next time - ))) - -(defun fPlusp () - (mksynapse (priorrelayvalue) - :fire-p (lambda (syn new-basis) - (declare (ignorable syn)) - (eko (nil "fPlusp fire-p decides" priorrelayvalue sensitivity) - (xor priorrelayvalue (plusp new-basis)))) - - :relay-value (lambda (syn new-basis) - (declare (ignorable syn)) - (eko (nil "fPlusp relays") - (setf priorrelayvalue (plusp new-basis))) ;; no modulation of value, but do record for next time - ))) - -(defun fZerop () - (mksynapse (priorrelayvalue) - :fire-p (lambda (syn new-basis) - (declare (ignorable syn)) - (eko (nil "fZerop fire-p decides") - (xor priorrelayvalue (zerop new-basis)))) - - :relay-value (lambda (syn new-basis) - (declare (ignorable syn)) - (eko (nil "fZerop relays") - (setf priorrelayvalue (zerop new-basis))) - ))) - -(defun fDifferent () - (mksynapse (prior-object) - :fire-p (lambda (syn new-object) - (declare (ignorable syn)) - (trc nil "fDiff: prior,new" (not (eql new-object prior-object)) - prior-object new-object) - (not (eql new-object prior-object))) - - :relay-value (lambda (syn new-object) - (declare (ignorable syn)) - (unless (eql new-object prior-object) - (setf prior-object new-object))) - )) -; -;____________________ synapse constructors _______________________________ -; -(defun fdelta (&key sensitivity (type 'number)) - (mksynapse (lastrelaybasis lastboundp) - :fire-p (lambda (syn newbasis) - (declare (ignorable syn)) - (eko (nil "delta fire-p") - (or (null sensitivity) - (let ((delta (delta-diff newbasis lastrelaybasis type))) - (delta-exceeds delta sensitivity type))))) - - :relay-value (lambda (syn newbasis) - (declare (ignorable syn)) - (prog1 - (if lastboundp - (delta-diff newbasis lastrelaybasis type) - (delta-identity newbasis type)) - ;(trc "filter yields to user, value" (c-slot-name user) (c-slot-spec syn) relayvalue) - ;(trc "fdelta > ********************* new lastrelay! " syn lastrelaybasis) - (setf lastboundp t) - (setf lastrelaybasis newbasis))) - )) - - - -(defmethod delta-exceeds (booldelta sensitivity (subtypename (eql 'boolean))) - (unless (eql booldelta :unchanged) - (or (eq sensitivity t) - (eq sensitivity booldelta)))) - -(defun fboolean (&optional (sensitivity 't)) - (fdelta :sensitivity sensitivity :type 'boolean)) - - +;; -*- 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-toplevel :load-toplevel :execute) + (export '(mksynapse fDelta fSensitivity fPlusp fZerop fDifferent))) + +; ___________________________ cell relay value ___________________________________ + +(defparameter *relayspeak* nil) +(defmethod c-relay-value ((syn synapse) value) + ;(trc "c-relay-value> syn, raw value:" syn value) + (let ((res (funcall (syn-relay-value syn) syn value))) + ;(trc "c-relay-value> cell, filtered value:" syn res) + res)) + +(defmethod c-relay-value (cell value) + (declare (ignorable cell)) + (when *relayspeak* + (trc "c-relay-value unspecial > cell value" cell value) + (setf *relayspeak* nil)) + value) + +;__________________________________________________________________________________ +; +(defmethod delta-diff ((new number) (old number) subtypename) + (declare (ignore subtypename)) + (- new old)) + +(defmethod delta-identity ((dispatcher number) subtypename) + (declare (ignore subtypename)) + 0) + +(defmethod delta-abs ((n number) subtypename) + (declare (ignore subtypename)) + (abs n)) + +(defmethod delta-exceeds ((d1 number) (d2 number) subtypename) + (declare (ignore subtypename)) + (> d1 d2)) + +(defmethod delta-greater-or-equal ((d1 number) (d2 number) subtypename) + (declare (ignore subtypename)) + (>= d1 d2)) + +;_________________________________________________________________________________ +; +(defmethod delta-diff (new old (subtypename (eql 'boolean))) + (if new + (if old + :unchanged + :on) + (if old + :off + :unchanged))) + + +(defmethod delta-identity (dispatcher (subtypename (eql 'boolean))) + (declare (ignore dispatcher)) + :unchanged) + +;______________________________________________________________ + +(defun fdeltalist (&key (test #'true)) + (mksynapse (priorlist) + :fire-p (lambda (syn newlist) + (declare (ignorable syn)) + (or (find-if (lambda (new) + ;--- gaining one? ---- + (and (not (member new priorlist)) + (funcall test new))) + newlist) + (find-if (lambda (old) + ;--- losing one? ---- + (not (member old newlist))) ;; all olds have passed test, so skip test here + priorlist))) + + :relay-value (lambda (syn newlist) + (declare (ignorable syn)) + ;/// excess consing on long lists + (setf priorlist (remove-if-not test newlist))))) + +;_______________________________________________________________ + +(defun ffindonce (finderfn) + (mksynapse (bingo bingobound) + + :fire-p (lambda (syn newlist) + (declare (ignorable syn)) + (unless bingo ;; once found, yer done + (setf bingobound t + bingo (find-if finderfn newlist)))) + + :relay-value (lambda (syn newlist) + (declare (ignorable syn)) + (or bingo + (and (not bingobound) ;; don't bother if fire? already looked + (find-if finderfn newlist)))))) + +;___________________________________________________________________ + +(defun fsensitivity (sensitivity &optional subtypename) + (mksynapse (priorrelayvalue) + :fire-p (lambda (syn newvalue) + (declare (ignorable syn)) + (trc nil "fire-p decides" priorrelayvalue sensitivity) + (or (xor priorrelayvalue newvalue) + (eko (nil "fire-p decides" newvalue 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 (nil "fsensitivity relays") + (setf priorrelayvalue newvalue)) ;; no modulation of value, but do record for next time + ))) + +(defun fPlusp () + (mksynapse (priorrelayvalue) + :fire-p (lambda (syn new-basis) + (declare (ignorable syn)) + (eko (nil "fPlusp fire-p decides" priorrelayvalue sensitivity) + (xor priorrelayvalue (plusp new-basis)))) + + :relay-value (lambda (syn new-basis) + (declare (ignorable syn)) + (eko (nil "fPlusp relays") + (setf priorrelayvalue (plusp new-basis))) ;; no modulation of value, but do record for next time + ))) + +(defun fZerop () + (mksynapse (priorrelayvalue) + :fire-p (lambda (syn new-basis) + (declare (ignorable syn)) + (eko (nil "fZerop fire-p decides") + (xor priorrelayvalue (zerop new-basis)))) + + :relay-value (lambda (syn new-basis) + (declare (ignorable syn)) + (eko (nil "fZerop relays") + (setf priorrelayvalue (zerop new-basis))) + ))) + +(defun fDifferent () + (mksynapse (prior-object) + :fire-p (lambda (syn new-object) + (declare (ignorable syn)) + (trc nil "fDiff: prior,new" (not (eql new-object prior-object)) + prior-object new-object) + (not (eql new-object prior-object))) + + :relay-value (lambda (syn new-object) + (declare (ignorable syn)) + (unless (eql new-object prior-object) + (setf prior-object new-object))) + )) +; +;____________________ synapse constructors _______________________________ +; +(defun fdelta (&key sensitivity (type 'number)) + (mksynapse (lastrelaybasis lastboundp) + :fire-p (lambda (syn newbasis) + (declare (ignorable syn)) + (eko (nil "delta fire-p") + (or (null sensitivity) + (let ((delta (delta-diff newbasis lastrelaybasis type))) + (delta-exceeds delta sensitivity type))))) + + :relay-value (lambda (syn newbasis) + (declare (ignorable syn)) + (prog1 + (if lastboundp + (delta-diff newbasis lastrelaybasis type) + (delta-identity newbasis type)) + ;(trc "filter yields to user, value" (c-slot-name user) (c-slot-spec syn) relayvalue) + ;(trc "fdelta > ********************* new lastrelay! " syn lastrelaybasis) + (setf lastboundp t) + (setf lastrelaybasis newbasis))) + )) + + + +(defmethod delta-exceeds (booldelta sensitivity (subtypename (eql 'boolean))) + (unless (eql booldelta :unchanged) + (or (eq sensitivity t) + (eq sensitivity booldelta)))) + +(defun fboolean (&optional (sensitivity 't)) + (fdelta :sensitivity sensitivity :type 'boolean)) + +

1 0

[cells-cvs] CVS update: Directory change: cells/doc/use-cases
by Kenny Tilton 03 Dec '03

03 Dec '03

Update of /project/cells/cvsroot/cells/doc/use-cases In directory common-lisp.net:/tmp/cvs-serv26449/use-cases Log Message: Directory /project/cells/cvsroot/cells/doc/use-cases added to the repository Date: Wed Dec 3 00:09:03 2003 Author: ktilton New directory cells/doc/use-cases added

1 0