[cells-cvs] CVS update: cells/cell-types.lisp cells/cells.lpr cells/link.lisp cells/md-slot-value.lisp cells/propagate.lisp cells/synapse-types.lisp cells/synapse.lisp cells/test.lisp
Kenny Tilton
ktilton at common-lisp.net
Thu May 19 20:17:50 UTC 2005
Update of /project/cells/cvsroot/cells
In directory common-lisp.net:/tmp/cvs-serv15391
Modified Files:
cell-types.lisp cells.lpr link.lisp md-slot-value.lisp
propagate.lisp synapse-types.lisp synapse.lisp test.lisp
Log Message:
Fix synapses, unifying with ruled cells
Date: Thu May 19 22:17:47 2005
Author: ktilton
Index: cells/cell-types.lisp
diff -u cells/cell-types.lisp:1.3 cells/cell-types.lisp:1.4
--- cells/cell-types.lisp:1.3 Wed May 18 23:47:29 2005
+++ cells/cell-types.lisp Thu May 19 22:17:47 2005
@@ -95,20 +95,20 @@
:stepper ,stepper
:to ,to :donep ,donep))))
-(defmethod md-slot-value-assume :around ((c c-stream) (s streamer))
- (bif (to (streamer-to s))
- (loop for slot-value = (streamer-from s)
- then (bif (stepper (streamer-stepper s))
- (funcall stepper c)
- (incf slot-value))
- until (bif (to (streamer-to s))
- (> slot-value to)
- (bwhen (donep-test (streamer-donep s))
- (funcall donep-test c)))
- do (progn
- (print `(assume doing ,slot-value))
- (call-next-method c slot-value))))
- (c-optimize-away?! c))
+;;;(defmethod md-slot-value-assume :around ((c c-stream) (s streamer))
+;;; (bif (to (streamer-to s))
+;;; (loop for slot-value = (streamer-from s)
+;;; then (bif (stepper (streamer-stepper s))
+;;; (funcall stepper c)
+;;; (incf slot-value))
+;;; until (bif (to (streamer-to s))
+;;; (> slot-value to)
+;;; (bwhen (donep-test (streamer-donep s))
+;;; (funcall donep-test c)))
+;;; do (progn
+;;; (print `(assume doing ,slot-value))
+;;; (call-next-method c slot-value))))
+;;; (c-optimize-away?! c))
#+test
(progn
Index: cells/cells.lpr
diff -u cells/cells.lpr:1.2 cells/cells.lpr:1.3
--- cells/cells.lpr:1.2 Sun May 8 01:12:40 2005
+++ cells/cells.lpr Thu May 19 22:17:47 2005
@@ -24,7 +24,10 @@
(make-instance 'module :name "family.lisp")
(make-instance 'module :name "fm-utilities.lisp")
(make-instance 'module :name "family-values.lisp")
- (make-instance 'module :name "test.lisp"))
+ (make-instance 'module :name "test.lisp")
+ (make-instance 'module :name "test-ephemeral.lisp")
+ (make-instance 'module :name "test-cycle.lisp")
+ (make-instance 'module :name "test-synapse.lisp"))
:projects (list (make-instance 'project-module :name
"utils-kt\\utils-kt"))
:libraries nil
Index: cells/link.lisp
diff -u cells/link.lisp:1.2 cells/link.lisp:1.3
--- cells/link.lisp:1.2 Wed May 18 23:47:29 2005
+++ cells/link.lisp Thu May 19 22:17:47 2005
@@ -140,7 +140,7 @@
;----------------------------------------------------------
(defun c-unlink-user (used user)
- #+dfdbg (trc user "user unlinking from used" user used)
+ (trc nil "user unlinking from used" user used)
(setf (c-users used) (delete user (c-users used)))
(c-unlink-used user used))
Index: cells/md-slot-value.lisp
diff -u cells/md-slot-value.lisp:1.5 cells/md-slot-value.lisp:1.6
--- cells/md-slot-value.lisp:1.5 Wed May 18 23:47:29 2005
+++ cells/md-slot-value.lisp Thu May 19 22:17:47 2005
@@ -96,19 +96,18 @@
(cd-usage-clear-all c)
- (let ((raw-value
- (progn
- (let ((*c-calculators* (cons c *c-calculators*)))
- (trc nil "c-calculate-and-set> new *c-calculators*:"
- *c-calculators*)
- (c-assert (c-model c))
- (funcall (cr-rule c) c)))))
+ (multiple-value-bind (raw-value propagation-code)
+ (let ((*c-calculators* (cons c *c-calculators*)))
+ (trc nil "c-calculate-and-set> new *c-calculators*:"
+ *c-calculators*)
+ (c-assert (c-model c))
+ (funcall (cr-rule c) c))
(when (and *c-debug* (typep raw-value 'cell))
(c-break "new value for cell ~s is itself a cell: ~s. probably nested (c? ... (c? ))"
c raw-value))
(c-unlink-unused c)
- (md-slot-value-assume c raw-value))))
+ (md-slot-value-assume c raw-value propagation-code))))
(if nil ;; *dbg*
(ukt::wtrc (0 100 "calcnset" c) (body))(body))))
@@ -155,13 +154,13 @@
(with-integrity (:setf :setf c new-value)
(trc nil "(setf md-slot-value) calling assume" c new-value)
- (md-slot-value-assume c new-value))
+ (md-slot-value-assume c new-value nil))
new-value)
-(defmethod md-slot-value-assume (c raw-value)
+(defmethod md-slot-value-assume (c raw-value propagation-code)
(assert c)
(without-c-dependency
(let ((prior-state (c-value-state c))
@@ -179,15 +178,17 @@
(c-value-state c) :valid
(c-state c) :awake)
- (unless (typep c 'c-stream) ;; c-stream needs to run out first stream at least
- (c-optimize-away?! c)) ;;; put optimize test here to avoid needless linking
+;;; (unless (typep c 'c-stream) ;; c-stream needs to run out first stream at least
+;;; (c-optimize-away?! c)) ;;; put optimize test here to avoid needless linking
; --- data flow propagation -----------
;
(trc nil "md-sv comparing" c prior-state absorbed-value prior-value)
- (if (and (eql prior-state :valid)
- (c-no-news c absorbed-value prior-value))
+ (if (or (eq propagation-code :no-propagate)
+ (and (null propagation-code)
+ (eql prior-state :valid)
+ (c-no-news c absorbed-value prior-value)))
(progn
(trc nil "(setf md-slot-value) >no news" prior-state (c-no-news c absorbed-value prior-value))
(count-it :nonews))
Index: cells/propagate.lisp
diff -u cells/propagate.lisp:1.4 cells/propagate.lisp:1.5
--- cells/propagate.lisp:1.4 Wed May 18 23:47:29 2005
+++ cells/propagate.lisp Thu May 19 22:17:47 2005
@@ -42,7 +42,7 @@
(when *stop*
(princ #\.)(princ #\!)
(return-from c-propagate))
- (trc nil "c-propagate> propping" c (c-value c) (length (c-users c)) c)
+ (trc nil "c-propagate> propping" c (c-value c) :user-ct (length (c-users c)) c)
(when *c-debug*
(when (> *c-prop-depth* 250)
Index: cells/synapse-types.lisp
diff -u cells/synapse-types.lisp:1.1 cells/synapse-types.lisp:1.2
--- cells/synapse-types.lisp:1.1 Fri May 6 23:05:45 2005
+++ cells/synapse-types.lisp Thu May 19 22:17:47 2005
@@ -22,50 +22,72 @@
(in-package :cells)
-(defmacro f-sensitivity ((sensitivity &optional subtypename) &body body)
- `(with-synapse ((prior-fire-value)
- :fire-p (lambda (syn new-value)
- (declare (ignorable syn))
- (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)
+(defmacro f-sensitivity (synapse-id (sensitivity &optional subtypename) &body body)
+ `(call-f-sensitivity ,synapse-id ,sensitivity ,subtypename (lambda () , at body)))
+
+(defun call-f-sensitivity (synapse-id sensitivity subtypename body-fn)
+ (with-synapse synapse-id (prior-fire-value)
+ (let ((new-value (funcall body-fn)))
+ (trc nil "f-sensitivity fire-p decides" prior-fire-value sensitivity)
+ (let ((prop-code (if (or (xor prior-fire-value new-value)
+ (eko ("sens fire-p decides" new-value prior-fire-value sensitivity)
(delta-greater-or-equal
- (delta-abs (delta-diff new-value prior-fire-value ,subtypename)
- ,subtypename)
- (delta-abs ,sensitivity ,subtypename)
- ,subtypename))))
-
- :fire-value (lambda (syn new-value)
- (declare (ignorable syn))
- (eko (nil "fsensitivity relays")
- (setf prior-fire-value new-value))))
- , at body))
-
-(defmacro f-delta ((&key sensitivity (type 'number)) &body body)
- (let ((threshold (gensym)) (tdelta (gensym)))
- `(with-synapse ((last-relay-basis last-bound-p delta-cum)
- :fire-p (lambda (syn new-basis)
- (declare (ignorable syn))
- (let ((,threshold ,sensitivity)
- (,tdelta (delta-diff new-basis
- (if last-bound-p
- last-relay-basis
- (delta-identity new-basis ',type))
- ',type)))
- (trc "tdelta, threshhold" ,tdelta ,threshold)
- (setf delta-cum ,tdelta)
- (eko ("delta fire-p")
- (or (null ,threshold)
- (delta-exceeds ,tdelta ,threshold ',type)))))
-
- :fire-value (lambda (syn new-basis)
- (declare (ignorable syn))
- (trc "f-delta fire-value gets" delta-cum new-basis syn)
- (trc "fdelta > new lastrelay" syn last-relay-basis)
- (setf last-bound-p t)
- (setf last-relay-basis new-basis)
- delta-cum))
- , at body)))
+ (delta-abs (delta-diff new-value prior-fire-value subtypename)
+ subtypename)
+ (delta-abs sensitivity subtypename)
+ subtypename)))
+ :propagate
+ :no-propagate)))
+ (values (if (eq prop-code :propagate)
+ (progn
+ (trc "sense prior fire value now" new-value)
+ (setf prior-fire-value new-value))
+ new-value) prop-code)))))
+
+(defmacro f-delta (synapse-id (&key sensitivity (type 'number)) &body body)
+ `(call-f-delta ,synapse-id ,sensitivity ',type (lambda () , at body)))
+
+(defun call-f-delta (synapse-id sensitivity type body-fn)
+ (with-synapse synapse-id (last-relay-basis last-bound-p delta-cum)
+ (let* ((new-basis (funcall body-fn))
+ (threshold sensitivity)
+ (tdelta (delta-diff new-basis
+ (if last-bound-p
+ last-relay-basis
+ (delta-identity new-basis type))
+ type)))
+ (trc nil "tdelta, threshhold" tdelta threshold)
+ (setf delta-cum tdelta)
+ (let ((propagation-code
+ (when threshold
+ (if (delta-exceeds tdelta threshold type)
+ (progn
+ (setf last-bound-p t)
+ (setf last-relay-basis new-basis)
+ :propagate)
+ :no-propagate))))
+ (trc nil "f-delta returns values" delta-cum propagation-code)
+ (values delta-cum propagation-code)))))
+
+(defmacro f-plusp (key &rest body)
+ `(with-synapse ,key (prior-fire-value)
+ (let ((new-basis (progn , at body)))
+ (values new-basis (if (xor prior-fire-value (plusp new-basis))
+ (progn
+ (setf prior-fire-value (plusp new-basis))
+ :propagate)
+ :no-propagate)))))
+
+(defmacro f-zerop (key &rest body)
+ `(with-synapse ,key (prior-fire-value)
+ (let ((new-basis (progn , at body)))
+ (values new-basis (if (xor prior-fire-value (zerop new-basis))
+ (progn
+ (setf prior-fire-value (zerop new-basis))
+ :propagate)
+ :no-propagate)))))
+
+
;;;(defun f-delta-list (&key (test #'true))
;;; (with-synapse (prior-list)
@@ -101,32 +123,6 @@
;;; (and (not bingobound) ;; don't bother if fire? already looked
;;; (find-if finder-fn new-list))))))
-;;;(defun f-plusp ()
-;;; (mk-synapse (prior-fire-value)
-;;; :fire-p (lambda (syn new-basis)
-;;; (declare (ignorable syn))
-;;; (eko (nil "fPlusp fire-p decides" prior-fire-value sensitivity)
-;;; (xor prior-fire-value (plusp new-basis))))
-;;;
-;;; :fire-value (lambda (syn new-basis)
-;;; (declare (ignorable syn))
-;;; (eko (nil "fPlusp relays")
-;;; (setf prior-fire-value (plusp new-basis))) ;; no modulation of value, but do record for next time
-;;; )))
-
-;;;(defun f-zerop ()
-;;; (mk-synapse (prior-fire-value)
-;;; :fire-p (lambda (syn new-basis)
-;;; (declare (ignorable syn))
-;;; (eko (nil "fZerop fire-p decides")
-;;; (xor prior-fire-value (zerop new-basis))))
-;;;
-;;; :fire-value (lambda (syn new-basis)
-;;; (declare (ignorable syn))
-;;; (eko (nil "fZerop relays")
-;;; (setf prior-fire-value (zerop new-basis)))
-;;; )))
-
;;;(defun fdifferent ()
;;; (mk-synapse (prior-object)
;;; :fire-p (lambda (syn new-object)
Index: cells/synapse.lisp
diff -u cells/synapse.lisp:1.3 cells/synapse.lisp:1.4
--- cells/synapse.lisp:1.3 Wed May 18 23:47:29 2005
+++ cells/synapse.lisp Thu May 19 22:17:47 2005
@@ -25,41 +25,31 @@
(eval-when (:compile-toplevel :load-toplevel :execute)
(export '(mk-synapse f-delta f-sensitivity f-plusp f-zerop fdifferent)))
-(defmacro with-synapse (((&rest closure-vars) &key trcp fire-p fire-value) &body body)
+(defmacro with-synapse (synapse-id (&rest closure-vars) &body body)
(declare (ignorable trcp))
- (let ((lex-loc-key (gensym "synapse-id")))
- `(let ((synapse (or (cdr (assoc ',lex-loc-key
- (cd-useds (car *c-calculators*))))
- (cdar (push (cons ',lex-loc-key
- (let (, at closure-vars)
- (make-synaptic-ruled slot-c (,fire-p ,fire-value)
- , at body)))
- (cd-useds
- (car *c-calculators*)))))))
- (prog1
- (with-integrity (:with-synapse)
- (c-value-ensure-current synapse))
- (when (car *c-calculators*)
- (c-link-ex synapse))))))
+ `(let* ((synapse-user (car *c-calculators*))
+ (synapse (or (bIf (ku (find ,synapse-id (cd-useds synapse-user) :key 'c-slot-name))
+ (progn
+ (trc "withsyn reusing known" ,synapse-id ku)
+ ku))
+ (let ((new-syn
+ (let (, at closure-vars)
+ (trc "withsyn making new syn" ,synapse-id)
+ (make-synaptic-ruled ,synapse-id synapse-user , at body))))
+ (c-link-ex new-syn)
+ new-syn))))
+ (prog1
+ (with-integrity (:with-synapse)
+ (c-value-ensure-current synapse))
+ (c-link-ex synapse))))
-(defmacro make-synaptic-ruled (syn-user (fire-p fire-value) &body body)
- (let ((new-value (gensym))
- (c-var (gensym)))
- `(make-c-dependent
- :model (c-model ,syn-user)
- :slot-name (intern (conc$ "syn-" (string (c-slot-name ,syn-user))))
- :code ',body
- :synaptic t
- :rule (c-lambda-var (,c-var)
- (let ((,new-value (progn , at body)))
- (trc "generic synaptic rule sees body value" ,c-var ,new-value)
- (if ,(if fire-p `(funcall ,fire-p ,c-var ,new-value) t)
- (progn
- (trc "Synapse fire YES!!" ,c-var)
- (funcall ,fire-value ,c-var ,new-value))
- (progn
- (trc "Synapse fire NO!! use cache" .cache)
- .cache)))))))
+(defmacro make-synaptic-ruled (syn-pseudo-slot syn-user &body body)
+ `(make-c-dependent
+ :model (c-model ,syn-user)
+ :slot-name ',syn-pseudo-slot
+ :code ',body
+ :synaptic t
+ :rule (c-lambda , at body)))
;__________________________________________________________________________________
;
Index: cells/test.lisp
diff -u cells/test.lisp:1.4 cells/test.lisp:1.5
--- cells/test.lisp:1.4 Wed May 18 23:47:29 2005
+++ cells/test.lisp Thu May 19 22:17:47 2005
@@ -63,7 +63,7 @@
(in-package :cells)
-(defparameter *cell-tests* nil)
+(defvar *cell-tests* nil)
#+go
@@ -90,7 +90,7 @@
(defmacro ct-assert (form &rest stuff)
`(progn
(print `(attempting ,',form))
- (assert ,form () "Error stuff ~a" (list , at stuff))))
+ (assert ,form () "Error with ~a >> ~a" ',form (list , at stuff))))
(defmodel m-null ()
((aa :initform nil :cell nil :initarg :aa :accessor aa)))
More information about the Cells-cvs
mailing list