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
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
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
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
[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
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
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
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
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