Update of /project/cells/cvsroot/cell-cultures/cells In directory common-lisp.net:/tmp/cvs-serv13558/cells
Modified Files: constructors.lisp defmodel.lisp initialize.lisp md-slot-value.lisp model-object.lisp propagate.lisp synapse-types.lisp synapse.lisp Log Message: Resolve problems with FTGL. Texture fonts will require upcoming fix in FTGL 2.1 currently in testing Date: Wed Sep 29 04:50:18 2004 Author: ktilton
Index: cell-cultures/cells/constructors.lisp diff -u cell-cultures/cells/constructors.lisp:1.2 cell-cultures/cells/constructors.lisp:1.3 --- cell-cultures/cells/constructors.lisp:1.2 Sun Jul 4 20:59:41 2004 +++ cell-cultures/cells/constructors.lisp Wed Sep 29 04:50:13 2004 @@ -82,7 +82,7 @@ ,result))))))
(defmacro c-formula ((&rest keys &key lazy) &body forms) - (declare (ignore lazy)) + (assert (member lazy '(nil t :once-asked :until-asked :always))) `(make-c-dependent :code ',forms :value-state :unevaluated
Index: cell-cultures/cells/defmodel.lisp diff -u cell-cultures/cells/defmodel.lisp:1.2 cell-cultures/cells/defmodel.lisp:1.3 --- cell-cultures/cells/defmodel.lisp:1.2 Wed Jul 21 13:49:37 2004 +++ cell-cultures/cells/defmodel.lisp Wed Sep 29 04:50:13 2004 @@ -80,8 +80,7 @@ (:metaclass ,(or (find :metaclass options :key #'car) 'standard-class)))
- #-allegro-v6.2 - (defmethod shared-initialize :after ((self ,class) slot-names &rest iargs) + (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)
Index: cell-cultures/cells/initialize.lisp diff -u cell-cultures/cells/initialize.lisp:1.1 cell-cultures/cells/initialize.lisp:1.2 --- cell-cultures/cells/initialize.lisp:1.1 Sat Jun 26 20:38:36 2004 +++ cell-cultures/cells/initialize.lisp Wed Sep 29 04:50:13 2004 @@ -70,13 +70,6 @@ (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*) (trc "c-awaken-cell c-ruled clearing *c-calculators*" c) (c-calculate-and-set c)))
Index: cell-cultures/cells/md-slot-value.lisp diff -u cell-cultures/cells/md-slot-value.lisp:1.3 cell-cultures/cells/md-slot-value.lisp:1.4 --- cell-cultures/cells/md-slot-value.lisp:1.3 Wed Jul 7 03:25:40 2004 +++ cell-cultures/cells/md-slot-value.lisp Wed Sep 29 04:50:13 2004 @@ -84,7 +84,7 @@ (let ((raw-value (progn (let ((*c-calculators* (cons c *c-calculators*))) - (trc nil "c-calculate-and-set> just added to *c-calculators*:" + (trc nil "c-calculate-and-set> new *c-calculators*:" *c-calculators*) (c-assert (c-model c)) (funcall (cr-rule c) c)))))
Index: cell-cultures/cells/model-object.lisp diff -u cell-cultures/cells/model-object.lisp:1.4 cell-cultures/cells/model-object.lisp:1.5 --- cell-cultures/cells/model-object.lisp:1.4 Wed Jul 21 13:49:37 2004 +++ cell-cultures/cells/model-object.lisp Wed Sep 29 04:50:13 2004 @@ -136,26 +136,26 @@ (setf (md-state self) :awakening) (dolist (esd (class-slots (class-of self))) (when (md-slot-cell-type (type-of self) (slot-definition-name esd)) - (let ((slot-name (slot-definition-name esd))) - (let ((c (md-slot-cell self slot-name))) - (when *c-debug* - (bwhen (sv (and (slot-boundp self slot-name) - (slot-value self slot-name))) - (when (typep sv 'cell) - (c-break "md-awaken ~a found cell ~a in slot ~a" self sv esd)))) + (let* ((slot-name (slot-definition-name esd)) + (c (md-slot-cell self slot-name))) + (when *c-debug* + (bwhen (sv (and (slot-boundp self slot-name) + (slot-value self slot-name))) + (when (typep sv 'cell) + (c-break "md-awaken ~a found cell ~a in slot ~a" self sv esd))))
- (if c - (cond - ((c-lazy c) - (trc nil "md-awaken deferring c-awaken since lazy" - self esd)) - ((eq :nascent (c-state c)) (c-awaken c))) + (if c + (cond + ((find (c-lazy c) '(:until-asked :always t)) + (trc nil "md-awaken deferring c-awaken since lazy" + self esd)) + ((eq :nascent (c-state c)) (c-awaken c)))
- (progn ;; next bit revised to avoid double-output of optimized cells - (when (eql '.kids slot-name) - (bwhen (sv (slot-value self '.kids)) - (md-kids-change self sv nil :md-awaken-slot))) - (c-output-initially self slot-name))))))) + (progn + (when (eql '.kids slot-name) + (bwhen (sv (slot-value self '.kids)) + (md-kids-change self sv nil :md-awaken-slot))) + (c-output-slot nil slot-name self (bd-slot-value self slot-name) nil nil))))))
(setf (md-state self) :awake) self)
Index: cell-cultures/cells/propagate.lisp diff -u cell-cultures/cells/propagate.lisp:1.3 cell-cultures/cells/propagate.lisp:1.4 --- cell-cultures/cells/propagate.lisp:1.3 Wed Jul 7 03:25:40 2004 +++ cell-cultures/cells/propagate.lisp Wed Sep 29 04:50:13 2004 @@ -60,13 +60,15 @@ (trc nil "c-propagate-to-users > queueing" c :cause *causation*) (let ((causation (cons c *causation*))) ;; in case deferred (with-integrity (:user-notify :user-notify c) + (assert (null *c-calculators*)) (let ((*causation* causation)) (trc nil "c-propagate-to-users > notifying users of" c) (dolist (user (c-users c)) (bwhen (dead (catch :mdead (trc nil "c-propagate-to-users> *data-pulse-id*, user, c:" *data-pulse-id* user c) (when (c-user-cares user) - (c-value-ensure-current user)))) + (c-value-ensure-current user)) + nil)) (when (eq dead (c-model c)) (trc nil "!!! aborting further user prop of dead" dead) (return-from c-propagate-to-users)) @@ -74,23 +76,10 @@
(defun c-user-cares (c) (not (or (c-currentp c) - (cr-lazy c)))) + (member (cr-lazy c) '(t :always :once-asked)))))
(defun c-output-defined (slot-name) (getf (symbol-plist slot-name) :output-defined)) - -(defun c-output-initially (self slot-name) - "call during instance init to force initial output." - (trc nil "c-output-initially" self slot-name - (c-output-defined slot-name) - (md-slot-cell self slot-name)) - (bif (c (md-slot-cell self slot-name)) - (cond - ((c-lazy c)) - ((c-inputp c) - (c-propagate c nil nil)) - (t (md-slot-value self slot-name))) ;; this will output after calculating if not nil - (c-output-slot nil slot-name self (bd-slot-value self slot-name) nil nil)))
(defun c-output-slot (c slot-name self new-value prior-value prior-value-supplied) (let ((causation *causation*)) ;; in case deferred
Index: cell-cultures/cells/synapse-types.lisp diff -u cell-cultures/cells/synapse-types.lisp:1.1 cell-cultures/cells/synapse-types.lisp:1.2 --- cell-cultures/cells/synapse-types.lisp:1.1 Sat Jun 26 20:38:36 2004 +++ cell-cultures/cells/synapse-types.lisp Wed Sep 29 04:50:13 2004 @@ -26,7 +26,7 @@ `(with-synapse ((prior-fire-value) :fire-p (lambda (syn new-value) (declare (ignorable syn)) - (trc "f-sensitivity fire-p decides" prior-fire-value ,sensitivity) + (trc nil "f-sensitivity fire-p decides" prior-fire-value ,sensitivity) (or (xor prior-fire-value new-value) (eko (nil "fire-p decides" new-value prior-fire-value ,sensitivity) (delta-greater-or-equal
Index: cell-cultures/cells/synapse.lisp diff -u cell-cultures/cells/synapse.lisp:1.2 cell-cultures/cells/synapse.lisp:1.3 --- cell-cultures/cells/synapse.lisp:1.2 Sun Jul 4 20:59:41 2004 +++ cell-cultures/cells/synapse.lisp Wed Sep 29 04:50:13 2004 @@ -36,8 +36,7 @@ ,@body))) (cd-synapses (car *c-calculators*))))))) - (progn ;;let ((*c-calculators* (cons synapse *c-calculators*))) - (c-value-ensure-current synapse))))) + (c-value-ensure-current synapse))))
(defmacro make-synaptic-ruled (syn-user (fire-p fire-value) &body body) (let ((new-value (gensym))