[cells-cvs] CVS update: cell-cultures/cells/constructors.lisp cell-cultures/cells/defmodel.lisp cell-cultures/cells/initialize.lisp cell-cultures/cells/md-slot-value.lisp cell-cultures/cells/model-object.lisp cell-cultures/cells/propagate.lisp cell-cultures/cells/synapse-types.lisp cell-cultures/cells/synapse.lisp
Kenny Tilton
ktilton at common-lisp.net
Wed Sep 29 02:50:43 UTC 2004
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 @@
, at 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))
More information about the Cells-cvs
mailing list