[cells-cvs] CVS cells
ktilton
ktilton at common-lisp.net
Tue Jun 20 14:16:45 UTC 2006
Update of /project/cells/cvsroot/cells
In directory clnet:/tmp/cvs-serv24993
Modified Files:
cell-types.lisp cells-manifesto.txt defmodel.lisp
defpackage.lisp link.lisp
Log Message:
--- /project/cells/cvsroot/cells/cell-types.lisp 2006/06/13 16:19:35 1.12
+++ /project/cells/cvsroot/cells/cell-types.lisp 2006/06/20 14:16:44 1.13
@@ -105,8 +105,11 @@
(:conc-name cd-))
;; chop (synapses nil :type list)
(useds nil :type list)
- (usage (make-array 16 :element-type 'bit
- :initial-element 0) :type simple-bit-vector))
+ (usage (blank-usage-mask)))
+
+(defun blank-usage-mask ()
+ (make-array 16 :element-type 'bit
+ :initial-element 0))
(defstruct (c-drifter
(:include c-dependent)))
@@ -153,3 +156,6 @@
(defmethod c-print-value (c stream)
(declare (ignore c stream)))
+
+
+
--- /project/cells/cvsroot/cells/cells-manifesto.txt 2006/06/09 17:21:35 1.5
+++ /project/cells/cvsroot/cells/cells-manifesto.txt 2006/06/20 14:16:44 1.6
@@ -126,14 +126,26 @@
-----------
Ruled Cells come with an instance-specific rule in the form of an anonymous function of two variables,
the instance owning the slot and the prior value (if any) computed by the rule. These rules consist of
-arbitrarily complex Common Lisp code, and are invoked immediately after instance initialization or, if
-they are declared lazy, when their slot readers are invoked.
+arbitrarily complex Common Lisp code, and are invoked immediately after instance initialization (but see
+the next bit on lazy cells).
When a rule runs, any dynamic read (either expressly in the rule source or during the execution of
some function invoked by the rule) of a slot of any instance mediated by a Cell of any type establishes a
runtime dependency of the ruled cell on the slot of the instance that was read. Note then that thanks
to code branching, dependencies can vary after every rule invocation.
+Lazy Ruled Cells
+----------------
+Laziness is cell-specific, applies only to ruled cells, and comes in four varieties:
+
+ :once-asked -- this will get evaluated and "observed" on initialization, but then not get reevaluated
+immediately if dependencies change, rather only when read by application code.
+
+ :until-asked -- this does not get evaluated/observed until read by application code, but then it becomes
+un-lazy, eagerly reevaluated as soon as any dependency changes (not waiting until asked).
+
+ :always -- not evaluated/observed until read, and not reevaluated until read after a dependency changes.
+
Dataflow
--------
When application code assigns a new value to an input Cell (a quick way of saying an instance slot mediated by
@@ -157,6 +169,15 @@
To allow the emergent animated data model to operate usefully on the world outside the model--if only to
update the screen--programmers may specify so-called observer callbacks dispatched according to: slot name,
instance, new value, old value, and whether the old value actually existed (false only on the first go).
+Observers are inherited according to the rules of CLOS class inheritance. If multiple primary observer
+methods apply because of inheritance, they all get run, most specific last.
+
+ie, observers are a GF with PROGN method combination.
+
+Observers get called in two circumstances: as part of Model object initialization, in a processing step
+just after CLOS instance initialization, and when a slot changes value. Any observer of a Cell slot
+is guaranteed to be called at least once during intialization even if a cell slot is bound to a constant
+or if it is an input or ruled Cell that never changes value.
It is legal for observer code to assign to input Cells, but (a) special syntax is required to defer executuion
until the observed state change has fully propagated; and (b) doing so compromises the declarative
@@ -296,20 +317,18 @@
is called 'defpart' in cells-gtk); and, (b) formula that specify the value of CLOS slots."
-- Phillip Eby, PyCells and peak.events,
-... http://www.eby-sarna.com/pipermail/peak/2006-May/002545.html
+ http://www.eby-sarna.com/pipermail/peak/2006-May/002545.html
"What I discovered is quite cool. The Cells system *automatically
discovers* dynamic dependencies, without having to explicitly specify that
X depends on Y, as long as X and Y are both implemented using cell
objects. The system knows when you are computing a value for X, and
registers the fact that Y was read during this computation, thus allowing
-it to automatically invalidate the X calculation if Y changes.
-
-"...Aside from the automatic dependency
-detection, the cells system has another trick that is able to significantly
-reduce the complexity of event cascades, similar to what I was trying (but
-failing) to do using the "scheduled thread" concept in peak.events.
-
-"Specifically, the cells system understands how to make event-based updates
+it to automatically invalidate the X calculation if Y changes....
+Aside from the automatic dependency detection, the cells system has
+another trick that is able to significantly reduce the complexity of
+event cascades, similar to what I was trying (but failing) to do using
+the "scheduled thread" concept in peak.events.
+Specifically, the cells system understands how to make event-based updates
orderly and deterministic, in a way that peak.events cannot. It
effectively divides time into "propagation" and "non-propagation"
states. Instead of simply making callbacks whenever a computed value
--- /project/cells/cvsroot/cells/defmodel.lisp 2006/05/20 06:32:19 1.4
+++ /project/cells/cvsroot/cells/defmodel.lisp 2006/06/20 14:16:44 1.5
@@ -26,98 +26,164 @@
;
; 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 slotname) reader
- &allow-other-keys)
- slotspec
-
- (declare (ignorable slotargs))
- (when cell
- (let* ((reader-fn (or reader accessor))
- (deriver-fn (intern$ "^" (symbol-name reader-fn)))
- )
- ;
- ; 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 ',deriver-fn)
- (defmacro ,deriver-fn ()
- `(,',reader-fn self)))
- )
- ))
- ))
- 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)))
- ;; We handle accessor below
- (when (getf ias :cell t)
- (remf ias :reader)
- (remf ias :writer)
- (remf ias :accessor))
- (remf ias :cell)
- (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 (cadr (find :metaclass options :key #'car))
- 'standard-class)))
-
- (defmethod shared-initialize :after ((self ,class) slot-names &rest iargs &key)
- (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
+ ,@(loop for slotspec in slotspecs
+ collecting (destructuring-bind
+ (slotname &rest slotargs
+ &key (cell t) (accessor slotname) reader
+ &allow-other-keys)
+ slotspec
+
+ (declare (ignorable slotargs))
+ (when cell
+ (let* ((reader-fn (or reader accessor))
+ (deriver-fn (intern$ "^" (symbol-name reader-fn)))
+ )
+ ;
+ ; 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 ',deriver-fn)
+ (defmacro ,deriver-fn ()
+ `(,',reader-fn self)))
+ )
+ ))
+ ))
+
+ ;
+ ; ------- 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)))
+ ;; We handle accessor below
+ (when (getf ias :cell t)
+ (remf ias :reader)
+ (remf ias :writer)
+ (remf ias :accessor))
+ (remf ias :cell)
+ (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 (cadr (find :metaclass options :key #'car))
+ 'standard-class)))
+
+ (defmethod shared-initialize :after ((self ,class) slot-names &rest iargs &key)
+ (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 slotname) reader writer type
- &allow-other-keys)
- slotspec
-
- (declare (ignorable slotargs))
- (when cell
- (let* ((reader-fn (or reader accessor))
- (writer-fn (or writer accessor))
- )
- (setf (md-slot-cell-type class slotname) cell)
+ ;
+ ; slot accessors once class is defined...
+ ;
+ ,@(mapcar (lambda (slotspec)
+ (destructuring-bind
+ (slotname &rest slotargs
+ &key (cell t) unchanged-if (accessor slotname) reader writer type
+ &allow-other-keys)
+ slotspec
+
+ (declare (ignorable slotargs))
+ (when cell
+ (let* ((reader-fn (or reader accessor))
+ (writer-fn (or writer accessor))
+ )
+ (setf (md-slot-cell-type class slotname) cell)
+
+
+ `(progn
+ ,(when reader-fn
+ `(defmethod ,reader-fn ((self ,class))
+ (md-slot-value self ',slotname)))
+ ,(when writer-fn
+ `(defmethod (setf ,writer-fn) (new-value (self ,class))
+ (setf (md-slot-value self ',slotname)
+ ,(if type
+ `(coerce new-value ',type)
+ 'new-value))))
- `(progn
- ,(when reader-fn
- `(defmethod ,reader-fn ((self ,class))
- (md-slot-value self ',slotname)))
-
- ,(when writer-fn
- `(defmethod (setf ,writer-fn) (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))))
+
+(defun defmd-canonicalize-slot (slotname
+ &key
+ (cell nil cell-p)
+ (initform nil initform-p)
+ (initarg (intern (symbol-name slotname) :keyword))
+ (documentation nil documentation-p)
+ (unchanged-if nil unchanged-if-p)
+ (reader slotname reader-p)
+ (writer `(setf ,slotname) writer-p)
+ (accessor slotname accessor-p)
+ (allocation nil allocation-p))
+ (list* slotname :initarg initarg
+ (append
+ (when cell-p (list :cell cell))
+ (when initform-p (list :initform initform))
+ (when unchanged-if-p (list :unchanged-if unchanged-if))
+ (when reader-p (list :reader reader))
+ (when writer-p (list :writer writer))
+ (when (or accessor-p
+ (not (and reader-p writer-p)))
+ (list :accessor accessor))
+ (when allocation-p (list :allocation allocation))
+ (when documentation-p (list :documentation documentation)))))
+
+(defmacro defmd (class superclasses &rest mdspec)
+ `(defmodel ,class ,superclasses
+ ,@(let (definitargs class-options slots)
+ (loop with skip
+ for (spec next) on mdspec
+ if skip
+ do (setf skip nil)
+ else do (etypecase spec
+ (cons
+ (cond
+ ((keywordp (car spec))
+ (assert (find (car spec) '(:documentation :metaclass)))
+ (push spec class-options))
+ ((find (cadr spec) '(:initarg :cell :initform :allocation :reader :writer :accessor :documentation))
+ (push (apply 'defmd-canonicalize-slot spec) slots))
+ (t ;; shortform (slotname initform &rest slotdef-key-values)
+ (push (apply 'defmd-canonicalize-slot
+ (list* (car spec) :initform (cadr spec) (cddr spec))) slots))))
+ (keyword
+ (setf definitargs (append definitargs (list spec next)))
+ (setf skip t))
+ (symbol (push (list spec :initform nil
+ :initarg (intern (symbol-name spec) :keyword)
+ :accessor spec) slots)))
+ finally
+ (return (list* (nreverse slots)
+ (delete-if 'null
+ (list* `(:default-initargs , at definitargs)
+ (nreverse class-options)))))))))
+
+#+test
+(progn
+ (defclass md-test-super ()())
- ,(when unchanged-if
- `(def-c-unchanged-test (,class ,slotname) ,unchanged-if))
- )
- ))
- ))
- slotspecs)
- (find-class ',class))))
+ (defmd defmd-test (md-test-super)
+ (aaa :cell nil :initform nil :initarg :aaa :accessor aaa) ;; defmd would have written the same
+ (aa2 :documentation "hi mom")
+ bbb
+ (ccc 42 :allocation :class)
+ (ddd (c-in nil) :cell :ephemeral)
+ :superx 42 ;; default-initarg
+ (:documentation "as if!")))
\ No newline at end of file
--- /project/cells/cvsroot/cells/defpackage.lisp 2006/05/01 20:23:14 1.6
+++ /project/cells/cvsroot/cells/defpackage.lisp 2006/06/20 14:16:44 1.7
@@ -48,7 +48,7 @@
#:c-formula #:c? #:c_? #:c?8 #:c?_ #:c??
#:with-integrity #:without-c-dependency #:self #:*parent*
#:.cache #:.with-c-cache #:c-lambda
- #:defmodel #:defobserver #:slot-value-observe #:def-c-unchanged-test
+ #:defmodel #:defmd #:defobserver #:slot-value-observe #:def-c-unchanged-test
#:new-value #:old-value #:old-value-boundp #:c...
#:md-awaken
#:mkpart #:make-kid #:the-kids #:nsib #:md-value #:^md-value #:.md-value #:kids #:^kids #:.kids
--- /project/cells/cvsroot/cells/link.lisp 2006/06/07 22:12:55 1.11
+++ /project/cells/cvsroot/cells/link.lisp 2006/06/20 14:16:44 1.12
@@ -88,9 +88,7 @@
; ---------------------------------------------
(defun cd-usage-clear-all (c)
- (loop with a = (cd-usage c)
- for bitn below (array-dimension a 0)
- do (setf (sbit a bitn) 0)))
+ (setf (cd-usage c) (blank-usage-mask)))
;--- unlink from used ----------------------
More information about the Cells-cvs
mailing list