June 2006 - cells-cvs@common-lisp.net - mailman3.common-lisp.net

[cells-cvs] CVS cells/cells-test
by ktilton 23 Jun '06

23 Jun '06

Update of /project/cells/cvsroot/cells/cells-test In directory clnet:/tmp/cvs-serv31550/cells-test Modified Files: df-interference.lisp hello-world.lisp test-synapse.lisp test.lisp Log Message: New abbreviated defmodel: defmd Starting to change internals names as the mood hits me. --- /project/cells/cvsroot/cells/cells-test/df-interference.lisp 2006/05/30 02:47:45 1.4 +++ /project/cells/cvsroot/cells/cells-test/df-interference.lisp 2006/06/23 01:04:56 1.5 @@ -64,7 +64,7 @@ ;; - 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 +;; be first evaluated, a might appear before b on c's list of dependents (callers). then the ;; following happens: ;; ;; - c triggers a @@ -113,7 +113,7 @@ (trc "cell is" c) (when (typep (cdr c) 'cell) (print `(notifier ,c)) - (dolist (u (c-users (cdr c))) + (dolist (u (c-callers (cdr c))) (print `(___ ,u))))) )) --- /project/cells/cvsroot/cells/cells-test/hello-world.lisp 2006/06/20 14:16:45 1.4 +++ /project/cells/cvsroot/cells/cells-test/hello-world.lisp 2006/06/23 01:04:56 1.5 @@ -24,13 +24,14 @@ (in-package :cells) + (defmd computer () - (happen (c-in nil) :ephemeral) + (happen (c-in nil) :cell :ephemeral) (location (c? (case (^happen) (:leave :away) (:arrive :at-home) (t .cache)))) ;; ie, unchanged - (response nil :ephemeral)) + (response nil :cell :ephemeral)) (defobserver response(self new-response old-response) (when new-response --- /project/cells/cvsroot/cells/cells-test/test-synapse.lisp 2006/03/16 05:22:08 1.1 +++ /project/cells/cvsroot/cells/cells-test/test-synapse.lisp 2006/06/23 01:04:56 1.2 @@ -22,7 +22,6 @@ (in-package :cells) - (defmodel m-syn () ((m-syn-a :initform nil :initarg :m-syn-a :accessor m-syn-a) (m-syn-b :initform nil :initarg :m-syn-b :accessor m-syn-b) --- /project/cells/cvsroot/cells/cells-test/test.lisp 2006/06/20 14:16:45 1.7 +++ /project/cells/cvsroot/cells/cells-test/test.lisp 2006/06/23 01:04:56 1.8 @@ -34,14 +34,14 @@ - make sure they fire when they should, and do not when they should not -- make sure they survive an evaluation by the user which does not branch to +- make sure they survive an evaluation by the caller which does not branch to them (ie, does not access them) - make sure they optimize away - test with forms which access multiple other cells -- look at direct alteration of a user +- look at direct alteration of a caller - does SETF honor not propagating, as well as a c-ruled after re-calcing @@ -233,7 +233,7 @@ collect (cons sn c)))) (trc "dependencies of" self) (loop for (sn . c) in slot-cells - do (trc "slot" sn :users (mapcar 'c-slot-name (c-users c)))))) + do (trc "slot" sn :callers (mapcar 'c-slot-name (c-callers c)))))) (def-cell-test m-worst-case (let ((m (make-instance 'm-worst-case)))

1 0

[cells-cvs] CVS cells
by ktilton 20 Jun '06

20 Jun '06

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 ,@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 ----------------------

1 0

[cells-cvs] CVS cells/cells-test
by ktilton 20 Jun '06

20 Jun '06

Update of /project/cells/cvsroot/cells/cells-test In directory clnet:/tmp/cvs-serv24993/cells-test Modified Files: hello-world.lisp test-kid-slotting.lisp test.lisp Log Message: --- /project/cells/cvsroot/cells/cells-test/hello-world.lisp 2006/03/16 05:22:08 1.3 +++ /project/cells/cvsroot/cells/cells-test/hello-world.lisp 2006/06/20 14:16:45 1.4 @@ -24,15 +24,13 @@ (in-package :cells) -(defmodel computer () - ((happen :cell :ephemeral :initform (c-in 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))) +(defmd computer () + (happen (c-in nil) :ephemeral) + (location (c? (case (^happen) + (:leave :away) + (:arrive :at-home) + (t .cache)))) ;; ie, unchanged + (response nil :ephemeral)) (defobserver response(self new-response old-response) (when new-response --- /project/cells/cvsroot/cells/cells-test/test-kid-slotting.lisp 2006/03/16 05:22:08 1.2 +++ /project/cells/cvsroot/cells/cells-test/test-kid-slotting.lisp 2006/06/20 14:16:45 1.3 @@ -24,33 +24,28 @@ (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) - )) +(defmd image (family) left top width 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 :if-missing 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))) +(defmd stack (image) + justify + (.kid-slots :initform (lambda (self) + (declare (ignore self)) + (list + (mk-kid-slot (left :if-missing 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 --- /project/cells/cvsroot/cells/cells-test/test.lisp 2006/06/13 05:05:14 1.6 +++ /project/cells/cvsroot/cells/cells-test/test.lisp 2006/06/20 14:16:45 1.7 @@ -65,7 +65,6 @@ (defvar *cell-tests* nil) - #+go (test-cells) @@ -99,12 +98,10 @@ ;; test huge number of useds by one rule -(defmodel m-index (family) - () - (:default-initargs - :md-value (c? (bwhen (ks (^kids)) - ;(trc "chya" (mapcar 'md-value ks)) - (apply '+ (mapcar 'md-value ks)))))) +(defmd m-index (family) + :md-value (c? (bwhen (ks (^kids)) + ;(trc "chya" (mapcar 'md-value ks)) + (apply '+ (mapcar 'md-value ks))))) (def-cell-test many-useds (let ((i (make-instance 'm-index))) @@ -119,18 +116,18 @@ #+test (many-useds) -(defmodel m-null () - ((aa :initform nil :cell nil :initarg :aa :accessor aa))) +(defmd m-null () + (aa :cell nil :initform nil :initarg :aa :accessor aa)) + (def-cell-test m-null (let ((m (make-instance 'm-null :aa 42))) (ct-assert (= 42 (aa m))) - (ct-assert (= 21 (decf (aa m) 21))) + (ct-assert (= 21 (let ((slot 'aa)) + (funcall (fdefinition `(setf ,slot)) (- (aa m) 21) m)))) :okay-m-null)) -(defmodel m-solo () - ((m-solo-a :initform nil :initarg :m-solo-a :accessor m-solo-a) - (m-solo-b :initform nil :initarg :m-solo-b :accessor m-solo-b))) +(defmd m-solo () m-solo-a m-solo-b) (def-cell-test m-solo (let ((m (make-instance 'm-solo @@ -143,9 +140,7 @@ (ct-assert (= 82 (m-solo-b m))) :okay-m-null)) -(defmodel m-var () - ((m-var-a :initform nil :initarg :m-var-a :accessor m-var-a) - (m-var-b :initform nil :initarg :m-var-b :accessor m-var-b))) +(defmd m-var () m-var-a m-var-b) (defobserver m-var-b () (print `(output m-var-b ,self ,new-value ,old-value))) @@ -157,9 +152,9 @@ (ct-assert (= 21 (m-var-a m))) :okay-m-var)) -(defmodel m-var-output () - ((cbb :initform nil :initarg :cbb :accessor cbb) - (aa :cell nil :initform nil :initarg :aa :accessor aa))) +(defmd m-var-output () + cbb + (aa :cell nil :initform nil :initarg :aa :accessor aa)) (defobserver cbb () (trc "output cbb" self) @@ -175,9 +170,7 @@ (ct-assert (eql -15 (aa m))) (list :okay-m-var (aa m)))) -(defmodel m-var-linearize-setf () - ((ccc :initform nil :initarg :ccc :accessor ccc) - (ddd :initform nil :initarg :ddd :accessor ddd))) +(defmd m-var-linearize-setf () ccc ddd) (defobserver ccc () (with-integrity (:change) @@ -198,9 +191,9 @@ ;;; ------------------------------------------------------- -(defmodel m-ruled () - ((eee :initform nil :initarg :eee :accessor eee) - (fff :initform (c? (floor (^ccc) 2)) :initarg :fff :accessor fff))) +(defmd m-ruled () + eee + (fff (c? (floor (^ccc) 2)))) (defobserver eee () (print `(output> eee ,new-value old ,old-value))) @@ -222,15 +215,15 @@ (ct-assert (= 18 (fff m)) m) :okay-m-ruled)) -(defmodel m-worst-case () - ((wc-x :accessor wc-x :initform (c-input () 2)) - (wc-a :accessor wc-a :initform (c? (prog2 - (trc "Start A") - (when (oddp (wc-x self)) - (wc-c self)) - (trc "Stop A")))) - (wc-c :accessor wc-c :initform (c? (evenp (wc-x self)))) - (wc-h :accessor wc-h :initform (c? (or (wc-c self)(wc-a self)))))) +(defmd m-worst-case () + (wc-x (c-input () 2)) + (wc-a (c? (prog2 + (trc "Start A") + (when (oddp (wc-x self)) + (wc-c self)) + (trc "Stop A")))) + (wc-c (c? (evenp (wc-x self)))) + (wc-h (c? (or (wc-c self)(wc-a self))))) (defun dependency-dump (self) (let ((slot-cells (loop for esd in (class-slots (class-of self)) @@ -252,10 +245,9 @@ (dependency-dump m) (ct-assert (eql 3 (incf (wc-x m)))))) -(defmodel c?n-class () - ((aaa :initarg :aaa :accessor aaa) - (bbb :initarg :bbb :accessor bbb) - (sum :initarg :sum :accessor sum :initform (c? (+ (^aaa) (^bbb)))))) +(defmd c?n-class () + aaa bbb + (sum (c? (+ (^aaa) (^bbb))))) (def-cell-test test-c?n () (let ((self (make-instance 'c?n-class

1 0

[cells-cvs] CVS cells/gui-geometry
by ktilton 20 Jun '06

20 Jun '06

Update of /project/cells/cvsroot/cells/gui-geometry In directory clnet:/tmp/cvs-serv24993/gui-geometry Modified Files: defpackage.lisp geo-data-structures.lisp Log Message: --- /project/cells/cvsroot/cells/gui-geometry/defpackage.lisp 2006/06/09 17:21:35 1.3 +++ /project/cells/cvsroot/cells/gui-geometry/defpackage.lisp 2006/06/20 14:16:45 1.4 @@ -18,12 +18,12 @@ (:nicknames #:geo) (:use #:common-lisp #:utils-kt #:cells) (:export #:geometer #:geo-zero-tl #:geo-inline #:a-stack #:a-row - #:px #:py #:ll #:lt #:lr #:lb + #:px #:py #:ll #:lt #:lr #:lb #:pl #:pt #:pr #:pb #:^px #:^py #:^ll #:^lt #:^lr #:^lb #:u96ths #:udots #:uinches #:uin #:upoints #:upts #:u8ths #:u16ths #:u32nds #:mkr #:v2-move #:l-height #:mkv2 #:^offset-within #:inset-lr #:v2-v #:v2-h #:r-bounds - #:lb + #:lb #:cs-target-res #:nr-make #:r-contains --- /project/cells/cvsroot/cells/gui-geometry/geo-data-structures.lisp 2006/06/04 13:19:59 1.1 +++ /project/cells/cvsroot/cells/gui-geometry/geo-data-structures.lisp 2006/06/20 14:16:45 1.2 @@ -216,7 +216,11 @@ (setf min-h 0 min-v 0 max-h 0 max-v 0)) (nr-make r min-h min-v max-h max-v)))) - +(defun nr-union (r sr) ;; unlike other code, this is assuming opengl's up==plus, and proper rectangles + (nr-make r (min (r-left r) (r-left sr)) + (max (r-top r) (r-top sr)) + (max (r-right r) (r-right sr)) + (min (r-bottom r) (r-bottom sr)))) (defun nr-move-to (r h v) (setf (r-left r) h

1 0

[cells-cvs] CVS cells/tutorial
by ktilton 20 Jun '06

20 Jun '06

Update of /project/cells/cvsroot/cells/tutorial In directory clnet:/tmp/cvs-serv24993/tutorial Modified Files: tutorial.lpr Log Message: --- /project/cells/cvsroot/cells/tutorial/tutorial.lpr 2006/06/13 16:19:35 1.4 +++ /project/cells/cvsroot/cells/tutorial/tutorial.lpr 2006/06/20 14:16:45 1.5 @@ -18,7 +18,8 @@ (make-instance 'module :name "05-class-cell.lisp") (make-instance 'module :name "..\\gotchas\\lost-ephemeral-init.lisp") - (make-instance 'module :name "chat-cells.lisp")) + (make-instance 'module :name "chat-cells.lisp") + (make-instance 'module :name "df-interference.lisp")) :projects (list (make-instance 'project-module :name "..\\cells")) :libraries nil :distributed-files nil

1 0

[cells-cvs] CVS cells
by ktilton 15 Jun '06

15 Jun '06

Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv3071 Modified Files: md-slot-value.lisp Log Message: --- /project/cells/cvsroot/cells/md-slot-value.lisp 2006/06/13 16:19:35 1.20 +++ /project/cells/cvsroot/cells/md-slot-value.lisp 2006/06/15 15:55:01 1.21 @@ -182,7 +182,7 @@ (when (and (not (eq propagation-code :propagate)) (eql prior-state :valid) (c-no-news c absorbed-value prior-value)) - (trc "(setf md-slot-value) > early no news" propagation-code prior-state prior-value absorbed-value) + (trc nil "(setf md-slot-value) > early no news" propagation-code prior-state prior-value absorbed-value) (count-it :nonews) (return-from md-slot-value-assume absorbed-value))

1 0

[cells-cvs] CVS cells
by ktilton 13 Jun '06

13 Jun '06

Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv4640 Modified Files: cell-types.lisp initialize.lisp md-slot-value.lisp model-object.lisp propagate.lisp Log Message: Back out change to ephemerals --- /project/cells/cvsroot/cells/cell-types.lisp 2006/06/13 05:05:12 1.11 +++ /project/cells/cvsroot/cells/cell-types.lisp 2006/06/13 16:19:35 1.12 @@ -53,11 +53,11 @@ ; ; Not a type, but an option to the :cell parameter of defmodel ; -(defun c-ephemeral-p (c) +(defun ephemeral-p (c) (eql :ephemeral (md-slot-cell-type (type-of (c-model c)) (c-slot-name c)))) -(defun c-ephemeral-reset (c) - (when (c-ephemeral-p c) ;; so caller does not need to worry about this +(defun ephemeral-reset (c) + (when (ephemeral-p c) ;; so caller does not need to worry about this ; ; as of Cells3 we defer resetting ephemerals because everything ; else gets deferred and we cannot /really/ reset it until @@ -67,9 +67,10 @@ ; ;; good q: what does (setf <ephem> 'x) return? historically nil, but...? ; (with-integrity (:ephemeral-reset c) - (trc nil "!!!!!!!!!!!!!! c-ephemeral-reset resetting:" c) + (trc nil "!!!!!!!!!!!!!! ephemeral-reset resetting:" c) (md-slot-value-store (c-model c) (c-slot-name c) nil) (setf (c-value c) nil) + #+notsureaboutthis (loop for user in (c-users c) do (calculate-and-link user))))) --- /project/cells/cvsroot/cells/initialize.lisp 2006/06/13 05:05:12 1.6 +++ /project/cells/cvsroot/cells/initialize.lisp 2006/06/13 16:19:35 1.7 @@ -33,7 +33,7 @@ ; nothing to calculate, but every cellular slot should be output ; (slot-value-observe (c-slot-name c) (c-model c) (c-value c) nil nil) - (c-ephemeral-reset c)) + (ephemeral-reset c)) (defmethod awaken-cell ((c c-ruled)) (let (*c-calculators*) --- /project/cells/cvsroot/cells/md-slot-value.lisp 2006/06/13 05:05:12 1.19 +++ /project/cells/cvsroot/cells/md-slot-value.lisp 2006/06/13 16:19:35 1.20 @@ -52,7 +52,7 @@ (trc nil "ensure-value-is-current >" c) (cond ((c-currentp c)(trc nil "c-currentp" c)) ;; used to follow c-inputp, but I am toying with letting ephemerals (inputs) fall obsolete - ;; and then get reset here (ie, ((c-input-p c) (c-ephemeral-reset c))). ie, do not assume inputs are never obsolete + ;; and then get reset here (ie, ((c-input-p c) (ephemeral-reset c))). ie, do not assume inputs are never obsolete ;; ((c-inputp c)(trc nil "c-inputp" c)) ;; always current (for now; see above) --- /project/cells/cvsroot/cells/model-object.lisp 2006/06/13 05:05:13 1.6 +++ /project/cells/cvsroot/cells/model-object.lisp 2006/06/13 16:19:35 1.7 @@ -49,6 +49,7 @@ for sn = (slot-definition-name esd) for sv = (when (slot-boundp self sn) (slot-value self sn)) + ;;do (print (list self sn sv (typep sv 'cell))) when (typep sv 'cell) do (if (md-slot-cell-type (type-of self) sn) (md-install-cell self sn sv) --- /project/cells/cvsroot/cells/propagate.lisp 2006/06/13 05:05:13 1.16 +++ /project/cells/cvsroot/cells/propagate.lisp 2006/06/13 16:19:35 1.17 @@ -103,7 +103,7 @@ ; would this be bad for persistent CLOS, in which a DB would think there was still a link ; between two records until the value actually got cleared? ; - (c-ephemeral-reset c) + (ephemeral-reset c) )) ; --- slot change -----------------------------------------------------------

1 0

[cells-cvs] CVS cells/tutorial
by ktilton 13 Jun '06

13 Jun '06

Update of /project/cells/cvsroot/cells/tutorial In directory clnet:/tmp/cvs-serv4640/tutorial Modified Files: tutorial.lpr Log Message: Back out change to ephemerals --- /project/cells/cvsroot/cells/tutorial/tutorial.lpr 2006/06/13 05:05:17 1.3 +++ /project/cells/cvsroot/cells/tutorial/tutorial.lpr 2006/06/13 16:19:35 1.4 @@ -17,7 +17,7 @@ "04-formula-once-then-input.lisp") (make-instance 'module :name "05-class-cell.lisp") (make-instance 'module :name - "..\\gotchas\\some-ephemeral-uhoh.lisp") + "..\\gotchas\\lost-ephemeral-init.lisp") (make-instance 'module :name "chat-cells.lisp")) :projects (list (make-instance 'project-module :name "..\\cells")) :libraries nil @@ -88,7 +88,7 @@ :old-space-size 256000 :new-space-size 6144 :runtime-build-option :standard - :on-initialization 'tu-cells::tu-some-ephemeral-uhoh + :on-initialization 'tu-cells::tu-chat-2 :on-restart 'do-default-restart) ;; End of Project Definition

1 0

[cells-cvs] CVS cells/cells-test
by ktilton 13 Jun '06

13 Jun '06

Update of /project/cells/cvsroot/cells/cells-test In directory clnet:/tmp/cvs-serv7503/cells-test Modified Files: test.lisp Log Message: Mostly make ephemerals more transparent by always rerunning rules of dependents. This is actually a bug fix, at some profound level of understanding beyond me. --- /project/cells/cvsroot/cells/cells-test/test.lisp 2006/05/30 02:47:45 1.5 +++ /project/cells/cvsroot/cells/cells-test/test.lisp 2006/06/13 05:05:14 1.6 @@ -72,7 +72,12 @@ (defun test-cells () (loop for test in (reverse *cell-tests*) do (cell-test-init test) - (funcall test))) + (funcall test)) + (print (make-string 40 :initial-element #\*)) + (print (make-string 40 :initial-element #\*)) + (print "*** Cells-test successfully completed **") + (print (make-string 40 :initial-element #\*)) + (print (make-string 40 :initial-element #\*))) (defun cell-test-init (name) (print (make-string 40 :initial-element #\!))

1 0

[cells-cvs] CVS cells/tutorial
by ktilton 13 Jun '06

13 Jun '06

Update of /project/cells/cvsroot/cells/tutorial In directory clnet:/tmp/cvs-serv7503/tutorial Modified Files: tutorial.lpr Log Message: Mostly make ephemerals more transparent by always rerunning rules of dependents. This is actually a bug fix, at some profound level of understanding beyond me. --- /project/cells/cvsroot/cells/tutorial/tutorial.lpr 2006/06/09 17:21:35 1.2 +++ /project/cells/cvsroot/cells/tutorial/tutorial.lpr 2006/06/13 05:05:17 1.3 @@ -2,7 +2,7 @@ (in-package :cg-user) -(defpackage :COMMON-GRAPHICS-USER) +(defpackage :TU-CELLS) (define-project :name :tutorial :modules (list (make-instance 'module :name "test.lisp") @@ -14,12 +14,16 @@ (make-instance 'module :name "02-lesson.lisp") (make-instance 'module :name "03-ephemeral.lisp") (make-instance 'module :name - "04-formula-once-then-input.lisp")) + "04-formula-once-then-input.lisp") + (make-instance 'module :name "05-class-cell.lisp") + (make-instance 'module :name + "..\\gotchas\\some-ephemeral-uhoh.lisp") + (make-instance 'module :name "chat-cells.lisp")) :projects (list (make-instance 'project-module :name "..\\cells")) :libraries nil :distributed-files nil :internally-loaded-files nil - :project-package-name :common-graphics-user + :project-package-name :tu-cells :main-form nil :compilation-unit t :verbose nil @@ -84,7 +88,7 @@ :old-space-size 256000 :new-space-size 6144 :runtime-build-option :standard - :on-initialization 'default-init-function + :on-initialization 'tu-cells::tu-some-ephemeral-uhoh :on-restart 'do-default-restart) ;; End of Project Definition

1 0