From ktilton at common-lisp.net Fri May 6 20:13:15 2005 From: ktilton at common-lisp.net (Kenny Tilton) Date: Fri, 6 May 2005 22:13:15 +0200 (CEST) Subject: [cells-cvs] CVS update: Module imported: cells Message-ID: <20050506201315.56DAF88729@common-lisp.net> Update of /project/cells/cvsroot/cells In directory common-lisp.net:/tmp/cvs-serv9095 Log Message: Status: Vendor Tag: tcvs-vendor Release Tags: tcvs-release No conflicts created by this import Date: Fri May 6 22:13:14 2005 Author: ktilton New module cells added From ktilton at common-lisp.net Fri May 6 20:17:32 2005 From: ktilton at common-lisp.net (Kenny Tilton) Date: Fri, 6 May 2005 22:17:32 +0200 (CEST) Subject: [cells-cvs] CVS update: Directory change: cells/utils-kt Message-ID: <20050506201732.6348D880A4@common-lisp.net> Update of /project/cells/cvsroot/cells/utils-kt In directory common-lisp.net:/tmp/cvs-serv10096/utils-kt Log Message: Directory /project/cells/cvsroot/cells/utils-kt added to the repository Date: Fri May 6 22:17:32 2005 Author: ktilton New directory cells/utils-kt added From ktilton at common-lisp.net Fri May 6 20:25:44 2005 From: ktilton at common-lisp.net (Kenny Tilton) Date: Fri, 6 May 2005 22:25:44 +0200 (CEST) Subject: [cells-cvs] CVS update: cells/README.txt cells/asdf.lisp cells/cell-types.lisp cells/cells-test.asd cells/cells.asd cells/cells.lisp cells/cells.lpr cells/constructors.lisp cells/defmodel.lisp cells/defpackage.lisp cells/family-values.lisp cells/family.lisp cells/fm-utilities.lisp cells/initialize.lisp cells/integrity.lisp cells/link.lisp cells/load.lisp cells/md-slot-value.lisp cells/md-utilities.lisp cells/model-object.lisp cells/optimization.lisp cells/propagate.lisp cells/slot-utilities.lisp cells/synapse-types.lisp cells/synapse.lisp cells/test.lisp Message-ID: <20050506202544.CD3A9880A4@common-lisp.net> Update of /project/cells/cvsroot/cells In directory common-lisp.net:/tmp/cvs-serv10393 Added Files: README.txt asdf.lisp cell-types.lisp cells-test.asd cells.asd cells.lisp cells.lpr constructors.lisp defmodel.lisp defpackage.lisp family-values.lisp family.lisp fm-utilities.lisp initialize.lisp integrity.lisp link.lisp load.lisp md-slot-value.lisp md-utilities.lisp model-object.lisp optimization.lisp propagate.lisp slot-utilities.lisp synapse-types.lisp synapse.lisp test.lisp Log Message: Establish Cells II (aka Cells 2.0, aka Cells) as Cells module in Cells project CVS tree Date: Fri May 6 22:25:39 2005 Author: ktilton From ktilton at common-lisp.net Fri May 6 20:27:50 2005 From: ktilton at common-lisp.net (Kenny Tilton) Date: Fri, 6 May 2005 22:27:50 +0200 (CEST) Subject: [cells-cvs] CVS update: cells/utils-kt/debug.lisp cells/utils-kt/defpackage.lisp cells/utils-kt/detritus.lisp cells/utils-kt/flow-control.lisp cells/utils-kt/quad.lisp cells/utils-kt/strings.lisp cells/utils-kt/utils-kt.asd cells/utils-kt/utils-kt.lpr Message-ID: <20050506202750.88E6D880A4@common-lisp.net> Update of /project/cells/cvsroot/cells/utils-kt In directory common-lisp.net:/tmp/cvs-serv10533/utils-kt Added Files: debug.lisp defpackage.lisp detritus.lisp flow-control.lisp quad.lisp strings.lisp utils-kt.asd utils-kt.lpr Log Message: Establish Cells II (aka Cells 2.0, aka Cells) as Cells module in Cells project CVS tree Date: Fri May 6 22:27:48 2005 Author: ktilton From ktilton at common-lisp.net Fri May 6 21:03:25 2005 From: ktilton at common-lisp.net (Kenny Tilton) Date: Fri, 6 May 2005 23:03:25 +0200 (CEST) Subject: [cells-cvs] CVS update: Module imported: cells Message-ID: <20050506210325.0C662880A4@common-lisp.net> Update of /project/cells/cvsroot/cells In directory common-lisp.net:/tmp/cvs-serv14118 Log Message: Status: Vendor Tag: tcvs-vendor Release Tags: tcvs-release No conflicts created by this import Date: Fri May 6 23:03:24 2005 Author: ktilton New module cells added From ktilton at common-lisp.net Fri May 6 21:04:24 2005 From: ktilton at common-lisp.net (Kenny Tilton) Date: Fri, 6 May 2005 23:04:24 +0200 (CEST) Subject: [cells-cvs] CVS update: Directory change: cells/doc Message-ID: <20050506210424.29A0D88729@common-lisp.net> Update of /project/cells/cvsroot/cells/doc In directory common-lisp.net:/tmp/cvs-serv14166/doc Log Message: Directory /project/cells/cvsroot/cells/doc added to the repository Date: Fri May 6 23:04:23 2005 Author: ktilton New directory cells/doc added From ktilton at common-lisp.net Fri May 6 21:04:23 2005 From: ktilton at common-lisp.net (Kenny Tilton) Date: Fri, 6 May 2005 23:04:23 +0200 (CEST) Subject: [cells-cvs] CVS update: Directory change: cells/cells-test Message-ID: <20050506210423.BCF43880A4@common-lisp.net> Update of /project/cells/cvsroot/cells/cells-test In directory common-lisp.net:/tmp/cvs-serv14166/cells-test Log Message: Directory /project/cells/cvsroot/cells/cells-test added to the repository Date: Fri May 6 23:04:23 2005 Author: ktilton New directory cells/cells-test added From ktilton at common-lisp.net Fri May 6 21:04:24 2005 From: ktilton at common-lisp.net (Kenny Tilton) Date: Fri, 6 May 2005 23:04:24 +0200 (CEST) Subject: [cells-cvs] CVS update: Directory change: cells/utils-kt Message-ID: <20050506210424.446188873A@common-lisp.net> Update of /project/cells/cvsroot/cells/utils-kt In directory common-lisp.net:/tmp/cvs-serv14166/utils-kt Log Message: Directory /project/cells/cvsroot/cells/utils-kt added to the repository Date: Fri May 6 23:04:24 2005 Author: ktilton New directory cells/utils-kt added From ktilton at common-lisp.net Fri May 6 21:05:55 2005 From: ktilton at common-lisp.net (Kenny Tilton) Date: Fri, 6 May 2005 23:05:55 +0200 (CEST) Subject: [cells-cvs] CVS update: cells/cells-test/boiler-examples.lisp cells/cells-test/build-sys.lisp cells/cells-test/cells-test.lpr cells/cells-test/df-interference.lisp cells/cells-test/echo-setf.lisp cells/cells-test/hello-world-q.lisp cells/cells-test/hello-world.lisp cells/cells-test/internal-combustion.lisp cells/cells-test/lazy-propagation.lisp cells/cells-test/output-setf.lisp cells/cells-test/person.lisp cells/cells-test/synapse-testing.lisp cells/cells-test/test-cyclicity.lisp cells/cells-test/test-family.lisp cells/cells-test/test-kid-slotting.lisp cells/cells-test/test-lazy.lisp cells/cells-test/test.lisp Message-ID: <20050506210555.B075F8873C@common-lisp.net> Update of /project/cells/cvsroot/cells/cells-test In directory common-lisp.net:/tmp/cvs-serv14248/cells-test Added Files: boiler-examples.lisp build-sys.lisp cells-test.lpr df-interference.lisp echo-setf.lisp hello-world-q.lisp hello-world.lisp internal-combustion.lisp lazy-propagation.lisp output-setf.lisp person.lisp synapse-testing.lisp test-cyclicity.lisp test-family.lisp test-kid-slotting.lisp test-lazy.lisp test.lisp Log Message: Establish Cells II (aka Cells 2.0, aka Cells) as Cells module in Cells project CVS tree Date: Fri May 6 23:05:52 2005 Author: ktilton From ktilton at common-lisp.net Fri May 6 21:05:52 2005 From: ktilton at common-lisp.net (Kenny Tilton) Date: Fri, 6 May 2005 23:05:52 +0200 (CEST) Subject: [cells-cvs] CVS update: cells/README.txt cells/asdf.lisp cells/cell-types.lisp cells/cells-test.asd cells/cells.asd cells/cells.lisp cells/cells.lpr cells/constructors.lisp cells/defmodel.lisp cells/defpackage.lisp cells/family-values.lisp cells/family.lisp cells/fm-utilities.lisp cells/initialize.lisp cells/integrity.lisp cells/link.lisp cells/load.lisp cells/md-slot-value.lisp cells/md-utilities.lisp cells/model-object.lisp cells/optimization.lisp cells/propagate.lisp cells/slot-utilities.lisp cells/synapse-types.lisp cells/synapse.lisp cells/test.lisp Message-ID: <20050506210552.A545188729@common-lisp.net> Update of /project/cells/cvsroot/cells In directory common-lisp.net:/tmp/cvs-serv14248 Added Files: README.txt asdf.lisp cell-types.lisp cells-test.asd cells.asd cells.lisp cells.lpr constructors.lisp defmodel.lisp defpackage.lisp family-values.lisp family.lisp fm-utilities.lisp initialize.lisp integrity.lisp link.lisp load.lisp md-slot-value.lisp md-utilities.lisp model-object.lisp optimization.lisp propagate.lisp slot-utilities.lisp synapse-types.lisp synapse.lisp test.lisp Log Message: Establish Cells II (aka Cells 2.0, aka Cells) as Cells module in Cells project CVS tree Date: Fri May 6 23:05:45 2005 Author: ktilton From ktilton at common-lisp.net Fri May 6 21:05:57 2005 From: ktilton at common-lisp.net (Kenny Tilton) Date: Fri, 6 May 2005 23:05:57 +0200 (CEST) Subject: [cells-cvs] CVS update: cells/doc/01-Cell-basics.lisp cells/doc/cell-doc.lisp cells/doc/hw.lisp Message-ID: <20050506210557.C63E78873E@common-lisp.net> Update of /project/cells/cvsroot/cells/doc In directory common-lisp.net:/tmp/cvs-serv14248/doc Added Files: 01-Cell-basics.lisp cell-doc.lisp hw.lisp Log Message: Establish Cells II (aka Cells 2.0, aka Cells) as Cells module in Cells project CVS tree Date: Fri May 6 23:05:55 2005 Author: ktilton From ktilton at common-lisp.net Fri May 6 21:05:58 2005 From: ktilton at common-lisp.net (Kenny Tilton) Date: Fri, 6 May 2005 23:05:58 +0200 (CEST) Subject: [cells-cvs] CVS update: cells/utils-kt/debug.lisp cells/utils-kt/defpackage.lisp cells/utils-kt/detritus.lisp cells/utils-kt/flow-control.lisp cells/utils-kt/quad.lisp cells/utils-kt/strings.lisp cells/utils-kt/utils-kt.asd cells/utils-kt/utils-kt.lpr Message-ID: <20050506210558.ECADC8873F@common-lisp.net> Update of /project/cells/cvsroot/cells/utils-kt In directory common-lisp.net:/tmp/cvs-serv14248/utils-kt Added Files: debug.lisp defpackage.lisp detritus.lisp flow-control.lisp quad.lisp strings.lisp utils-kt.asd utils-kt.lpr Log Message: Establish Cells II (aka Cells 2.0, aka Cells) as Cells module in Cells project CVS tree Date: Fri May 6 23:05:56 2005 Author: ktilton From ktilton at common-lisp.net Fri May 6 21:18:14 2005 From: ktilton at common-lisp.net (Kenny Tilton) Date: Fri, 6 May 2005 23:18:14 +0200 (CEST) Subject: [cells-cvs] CVS update: cell-cultures/cello/cello-magick.lisp cell-cultures/cello/cello.lpr cell-cultures/cello/image.lisp cell-cultures/cello/window-callbacks.lisp cell-cultures/cello/window.lisp Message-ID: <20050506211814.D21F188729@common-lisp.net> Update of /project/cells/cvsroot/cell-cultures/cello In directory common-lisp.net:/tmp/cvs-serv15540/cello Modified Files: cello-magick.lisp cello.lpr image.lisp window-callbacks.lisp window.lisp Log Message: Establish Cells II (aka Cells 2.0, aka Cells) as Cells module in Cells project CVS tree Date: Fri May 6 23:18:12 2005 Author: ktilton Index: cell-cultures/cello/cello-magick.lisp diff -u cell-cultures/cello/cello-magick.lisp:1.3 cell-cultures/cello/cello-magick.lisp:1.4 --- cell-cultures/cello/cello-magick.lisp:1.3 Fri Oct 15 05:37:21 2004 +++ cell-cultures/cello/cello-magick.lisp Fri May 6 23:18:12 2005 @@ -84,7 +84,7 @@ (defun ix-render-wand (wand l-box) (if wand (apply 'wand-render wand (r-bounds l-box)) - (trc "ix-render-wand sees no wand" l-box))) + (trc nil "ix-render-wand sees no wand" l-box))) ;;;(defun wand-centered-bounds (wand size) ;;; (let* ((raw-w (magick-get-image-width (^mgk-wand))) Index: cell-cultures/cello/cello.lpr diff -u cell-cultures/cello/cello.lpr:1.3 cell-cultures/cello/cello.lpr:1.4 --- cell-cultures/cello/cello.lpr:1.3 Fri Oct 15 05:37:21 2004 +++ cell-cultures/cello/cello.lpr Fri May 6 23:18:12 2005 @@ -1,11 +1,10 @@ -;; -*- lisp-version: "6.2 [Windows] (Sep 3, 2004 12:04)"; common-graphics: "1.389.2.105.2.14"; -*- +;; -*- lisp-version: "7.0 [Windows] (Apr 6, 2005 17:03)"; cg: "1.54.2.17"; -*- -(in-package :common-graphics-user) +(in-package :cg-user) -(defpackage :cello (:export)) +(defpackage :CELLO) (define-project :name :cello - :application-type (intern "Standard EXE" (find-package :keyword)) :modules (list (make-instance 'module :name "cello.lisp") (make-instance 'module :name "datetime.lisp") (make-instance 'module :name "window-macros.lisp") @@ -50,7 +49,7 @@ (make-instance 'module :name "cello-magick.lisp") (make-instance 'module :name "cello-openal.lisp")) :projects (list (make-instance 'project-module :name - "..\\cells\\cells") + "c:\\0dev\\cells_2.0\\cells") (make-instance 'project-module :name "..\\cl-opengl\\cl-opengl") (make-instance 'project-module :name @@ -61,28 +60,20 @@ "..\\cl-openal\\cl-openal")) :libraries nil :distributed-files nil + :internally-loaded-files nil :project-package-name :cello :main-form 'cello::form3 :compilation-unit t :verbose nil - :runtime-modules '(:cg :drag-and-drop :lisp-widget - :multi-picture-button :common-control - :edit-in-place :outline :grid :group-box - :header-control :progress-indicator-control - :common-status-bar :tab-control :trackbar-control - :up-down-control :dde :mci :carets :hotspots - :menu-selection :choose-list :directory-list - :color-dialog :find-dialog :font-dialog - :string-dialog :yes-no-list-dialog - :list-view-control :rich-edit :drawable :ole :www - :aclwin302) + :runtime-modules nil :splash-file-module (make-instance 'build-module :name "") :icon-file-module (make-instance 'build-module :name "") - :include-flags '(:compiler :top-level :local-name-info) + :include-flags '(:local-name-info) :build-flags '(:allow-debug :purify) :autoload-warning t :full-recompile-for-runtime-conditionalizations nil :default-command-line-arguments "+cx +t \"Initializing\"" + :additional-build-lisp-image-arguments '(:read-init-files nil) :old-space-size 256000 :new-space-size 6144 :runtime-build-option :standard Index: cell-cultures/cello/image.lisp diff -u cell-cultures/cello/image.lisp:1.8 cell-cultures/cello/image.lisp:1.9 --- cell-cultures/cello/image.lisp:1.8 Sun Dec 5 05:49:59 2004 +++ cell-cultures/cello/image.lisp Fri May 6 23:18:12 2005 @@ -65,7 +65,10 @@ (progn (ogl-dsp-list-prep self) (when (every 'dsp-list (kids self)) - (let ((display-list-name (or .cache (gl-gen-lists 1))) + (let ((display-list-name (or .cache + (eko ("new disp list" + (mod (get-internal-real-time) 1000)) + (gl-gen-lists 1)))) (*ogl-shared-resource-tender* (ogl-shared-resource-tender self))) (gl-new-list display-list-name gl_compile) @@ -80,6 +83,10 @@ display-list-name))))) (gl-name :initarg :gl-name :initform nil :accessor gl-name) (renderer :initarg :renderer :initform nil :accessor renderer))) + +;;;(def-c-output dsp-list () +;;; (when old-value +;;; (gl-delete-lists old-value 1))) (defmethod not-to-be :after ((self ogl-node)) (bwhen (dl (^dsp-list)) Index: cell-cultures/cello/window-callbacks.lisp diff -u cell-cultures/cello/window-callbacks.lisp:1.5 cell-cultures/cello/window-callbacks.lisp:1.6 --- cell-cultures/cello/window-callbacks.lisp:1.5 Fri Apr 8 11:11:07 2005 +++ cell-cultures/cello/window-callbacks.lisp Fri May 6 23:18:12 2005 @@ -105,7 +105,7 @@ (trc nil "window-display > rendered w " self (glutgetwindow)) (incf (frame-ct self)) - (when (display-continuous self) + #+not (when (display-continuous self) (trc nil "window-display > continuous specified so posting redisplay" self) (glut-post-redisplay))) Index: cell-cultures/cello/window.lisp diff -u cell-cultures/cello/window.lisp:1.6 cell-cultures/cello/window.lisp:1.7 --- cell-cultures/cello/window.lisp:1.6 Fri Apr 8 11:11:07 2005 +++ cell-cultures/cello/window.lisp Fri May 6 23:18:12 2005 @@ -24,6 +24,8 @@ ;------------- Window --------------- ; + + (defmodel window (focuser ix-lit-scene control ogl-shared-resource-tender) ( (glutw :initarg :glutw :accessor glutw @@ -415,9 +417,11 @@ ((or (c-stopped) (zerop (glut-get-window)))) ;;(format t "before main loop ~a | ~&" (glut-get-window)) - (glutmainloopevent) + (progn ;; time + (glutmainloopevent)) (setf (tick-count new-window) (os-tickcount)) - (sleep 0.05))))) + (sleep 0.05) + )))) (defmethod ix-paint :around ((self window)) (flet ((projection () From ktilton at common-lisp.net Fri May 6 21:18:16 2005 From: ktilton at common-lisp.net (Kenny Tilton) Date: Fri, 6 May 2005 23:18:16 +0200 (CEST) Subject: [cells-cvs] CVS update: cell-cultures/cellodemo/cellodemo.lisp cell-cultures/cellodemo/cellodemo.lpr cell-cultures/cellodemo/demo-window.lisp Message-ID: <20050506211816.60AA988729@common-lisp.net> Update of /project/cells/cvsroot/cell-cultures/cellodemo In directory common-lisp.net:/tmp/cvs-serv15540/cellodemo Modified Files: cellodemo.lisp cellodemo.lpr demo-window.lisp Log Message: Establish Cells II (aka Cells 2.0, aka Cells) as Cells module in Cells project CVS tree Date: Fri May 6 23:18:14 2005 Author: ktilton Index: cell-cultures/cellodemo/cellodemo.lisp diff -u cell-cultures/cellodemo/cellodemo.lisp:1.4 cell-cultures/cellodemo/cellodemo.lisp:1.5 --- cell-cultures/cellodemo/cellodemo.lisp:1.4 Thu Oct 28 02:09:03 2004 +++ cell-cultures/cellodemo/cellodemo.lisp Fri May 6 23:18:14 2005 @@ -22,9 +22,16 @@ (in-package :cello) -(defun demo-image-subdir (subdir) - (merge-pathnames (make-pathname :directory `(:relative ,(string subdir))) - cl-user::*cell-cultures-graphics-directory*)) + +#+test +(list + (demo-image-subdir "shapers") + (demo-image-subdir)) + +(defun demo-image-subdir (&optional subdir) + (make-pathname :directory + (append '(:absolute "cell-cultures" "cell-cultures-user" "graphics") + (when subdir (list subdir))))) (defun demo-image-file (subdir file) (merge-pathnames file Index: cell-cultures/cellodemo/cellodemo.lpr diff -u cell-cultures/cellodemo/cellodemo.lpr:1.5 cell-cultures/cellodemo/cellodemo.lpr:1.6 --- cell-cultures/cellodemo/cellodemo.lpr:1.5 Fri Apr 8 11:11:08 2005 +++ cell-cultures/cellodemo/cellodemo.lpr Fri May 6 23:18:14 2005 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "7.0 [Windows] (Dec 28, 2004 17:34)"; cg: "1.54.2.17"; -*- +;; -*- lisp-version: "7.0 [Windows] (Apr 6, 2005 17:03)"; cg: "1.54.2.17"; -*- (in-package :cg-user) @@ -21,58 +21,10 @@ :main-form nil :compilation-unit t :verbose nil - :runtime-modules '(:cg-dde-utils :cg.base :cg.bitmap-pane - :cg.bitmap-pane.clipboard :cg.bitmap-stream - :cg.button :cg.caret :cg.check-box :cg.choice-list - :cg.choose-printer :cg.clipboard - :cg.clipboard-stack :cg.clipboard.pixmap - :cg.color-dialog :cg.combo-box :cg.common-control - :cg.comtab :cg.cursor-pixmap :cg.curve - :cg.dialog-item :cg.directory-dialog - :cg.directory-dialog-os :cg.drag-and-drop - :cg.drag-and-drop-image :cg.drawable - :cg.drawable.clipboard :cg.dropping-outline - :cg.edit-in-place :cg.editable-text - :cg.file-dialog :cg.fill-texture - :cg.find-string-dialog :cg.font-dialog - :cg.gesture-emulation :cg.get-pixmap - :cg.get-position :cg.graphics-context - :cg.grid-widget :cg.grid-widget.drag-and-drop - :cg.group-box :cg.header-control :cg.hotspot - :cg.icon :cg.icon-pixmap :cg.item-list - :cg.keyboard-shortcuts :cg.lettered-menu - :cg.lisp-edit-pane :cg.lisp-text :cg.lisp-widget - :cg.list-view :cg.mci :cg.menu :cg.menu.tooltip - :cg.message-dialog :cg.multi-line-editable-text - :cg.multi-line-lisp-text :cg.multi-picture-button - :cg.multi-picture-button.drag-and-drop - :cg.multi-picture-button.tooltip :cg.os-widget - :cg.os-window :cg.outline - :cg.outline.drag-and-drop - :cg.outline.edit-in-place :cg.palette - :cg.paren-matching :cg.picture-widget - :cg.picture-widget.palette :cg.pixmap - :cg.pixmap-widget :cg.pixmap.file-io - :cg.pixmap.printing :cg.pixmap.rotate :cg.printing - :cg.progress-indicator :cg.project-window - :cg.property :cg.radio-button :cg.rich-edit - :cg.rich-edit-pane :cg.rich-edit-pane.clipboard - :cg.rich-edit-pane.printing :cg.sample-file-menu - :cg.scaling-stream :cg.scroll-bar - :cg.scroll-bar-mixin :cg.selected-object - :cg.shortcut-menu :cg.static-text :cg.status-bar - :cg.string-dialog :cg.tab-control - :cg.template-string :cg.text-edit-pane - :cg.text-edit-pane.file-io :cg.text-edit-pane.mark - :cg.text-or-combo :cg.text-widget :cg.timer - :cg.toggling-widget :cg.toolbar :cg.tooltip - :cg.trackbar :cg.tray :cg.up-down-control - :cg.utility-dialog :cg.web-browser - :cg.web-browser.dde :cg.wrap-string - :cg.yes-no-list :cg.yes-no-string :dde) + :runtime-modules '(:cg-dde-utils :cg.base) :splash-file-module (make-instance 'build-module :name "") :icon-file-module (make-instance 'build-module :name "") - :include-flags '(:compiler :top-level :local-name-info) + :include-flags '(:local-name-info) :build-flags '(:allow-debug :purify) :autoload-warning t :full-recompile-for-runtime-conditionalizations nil Index: cell-cultures/cellodemo/demo-window.lisp diff -u cell-cultures/cellodemo/demo-window.lisp:1.6 cell-cultures/cellodemo/demo-window.lisp:1.7 --- cell-cultures/cellodemo/demo-window.lisp:1.6 Thu Oct 28 02:09:03 2004 +++ cell-cultures/cellodemo/demo-window.lisp Fri May 6 23:18:14 2005 @@ -45,7 +45,7 @@ (make-pathname :name "brushdmtl" :type "jpg") - cl-user::*cell-cultures-graphics-directory*))) + (demo-image-subdir)))) :pre-layer (c? (let ((tx-name (texture-name (^skin))) (tx-size (image-size (^skin)))) (with-layers :on +white+ @@ -72,17 +72,15 @@ (defun run-demos (demo-names start-at &rest iargs) (declare (ignorable start-at)) (run-window (apply 'make-instance 'demo-window - :md-value (c-in (list start-at)) - ;:idler 'mg-glut-idle - :content demo-names - iargs) + :md-value (c-in (list start-at)) + ;:idler 'mg-glut-idle + :content demo-names + iargs) (lambda () ;;; -- not sure how much of this new reset stuff is necessary --- (cl-ftgl-reset) (cl-ftgl-init) - (wands-clear) - ;; (ogl::xfg) - ))) + (wands-clear)))) (defun run-stylish-demos (demo-names start-at &rest iargs) (with-styles ( @@ -148,12 +146,11 @@ (list (md-value lm)))) :snapshot-pathnamer (lambda (self) - (merge-pathnames - (make-pathname - :name (format nil "snap-me-~3,,,'0 at A" - (snapshot-release-id self)) - :type "jpg") - cl-user::*cell-cultures-output-directory*)) + (make-pathname + :directory '(:absolute "cell-cultures" "cell-cultures-user" "output") + :name (format nil "snap-me-~3,,,'0 at A" + (snapshot-release-id self)) + :type "jpg")) :pre-layer (c? (with-layers +white+ From ktilton at common-lisp.net Fri May 6 21:18:26 2005 From: ktilton at common-lisp.net (Kenny Tilton) Date: Fri, 6 May 2005 23:18:26 +0200 (CEST) Subject: [cells-cvs] CVS update: cell-cultures/cells/cells.lpr cell-cultures/cells/defmodel.lisp cell-cultures/cells/md-slot-value.lisp cell-cultures/cells/optimization.lisp cell-cultures/cells/synapse-types.lisp cell-cultures/cells/synapse.lisp Message-ID: <20050506211826.5C7488873B@common-lisp.net> Update of /project/cells/cvsroot/cell-cultures/cells In directory common-lisp.net:/tmp/cvs-serv15540/cells Modified Files: cells.lpr defmodel.lisp md-slot-value.lisp optimization.lisp synapse-types.lisp synapse.lisp Log Message: Establish Cells II (aka Cells 2.0, aka Cells) as Cells module in Cells project CVS tree Date: Fri May 6 23:18:16 2005 Author: ktilton Index: cell-cultures/cells/cells.lpr diff -u cell-cultures/cells/cells.lpr:1.3 cell-cultures/cells/cells.lpr:1.4 --- cell-cultures/cells/cells.lpr:1.3 Fri Apr 8 11:11:12 2005 +++ cell-cultures/cells/cells.lpr Fri May 6 23:18:15 2005 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "7.0 [Windows] (Dec 28, 2004 17:34)"; cg: "1.54.2.17"; -*- +;; -*- lisp-version: "7.0 [Windows] (May 6, 2005 8:25)"; cg: "1.54.2.17"; -*- (in-package :cg-user) Index: cell-cultures/cells/defmodel.lisp diff -u cell-cultures/cells/defmodel.lisp:1.3 cell-cultures/cells/defmodel.lisp:1.4 --- cell-cultures/cells/defmodel.lisp:1.3 Wed Sep 29 04:50:13 2004 +++ cell-cultures/cells/defmodel.lisp Fri May 6 23:18:15 2005 @@ -22,6 +22,7 @@ (in-package :cells) + (defmacro defmodel (class directsupers slotspecs &rest options) ;;(print `(defmodel sees directsupers ,directsupers using ,(or directsupers :model-object))) `(progn @@ -59,7 +60,7 @@ ; ------- defclass --------------- (^slot-value ,model ',',slotname) ; - (prog1 + (progn (defclass ,class ,(or directsupers '(model-object));; now we can def the class ,(mapcar (lambda (s) (list* (car s) @@ -121,5 +122,6 @@ ) )) )) - slotspecs)))) + slotspecs) + (find-class ',class)))) Index: cell-cultures/cells/md-slot-value.lisp diff -u cell-cultures/cells/md-slot-value.lisp:1.6 cell-cultures/cells/md-slot-value.lisp:1.7 --- cell-cultures/cells/md-slot-value.lisp:1.6 Fri Apr 8 11:11:12 2005 +++ cell-cultures/cells/md-slot-value.lisp Fri May 6 23:18:15 2005 @@ -56,7 +56,7 @@ (defun c-influenced-by-pulse (c); &aux (ip *data-pulse-id*)) (unless (c-currentp c) (count-it :c-influenced-by-pulse) - (trc c "c-influenced-by-pulse> " c (c-useds c)) + (trc nil "c-influenced-by-pulse> " c (c-useds c)) (some (lambda (used) (c-value-ensure-current used) (when (and (c-changed used) (> (c-pulse used)(c-pulse c))) Index: cell-cultures/cells/optimization.lisp diff -u cell-cultures/cells/optimization.lisp:1.2 cell-cultures/cells/optimization.lisp:1.3 --- cell-cultures/cells/optimization.lisp:1.2 Sun Dec 5 05:50:32 2004 +++ cell-cultures/cells/optimization.lisp Fri May 6 23:18:15 2005 @@ -34,6 +34,7 @@ (not (c-optimized-away-p c)) ;; c-streams come this way repeatedly even if optimized away (c-validp c) (not (c-synaptic c)) ;; no slot to cache invariant result, so they have to stay around) + (every (lambda (syn) (null (cd-useds syn))) (cd-synapses c)) (null (cd-useds c))) (progn Index: cell-cultures/cells/synapse-types.lisp diff -u cell-cultures/cells/synapse-types.lisp:1.2 cell-cultures/cells/synapse-types.lisp:1.3 --- cell-cultures/cells/synapse-types.lisp:1.2 Wed Sep 29 04:50:13 2004 +++ cell-cultures/cells/synapse-types.lisp Fri May 6 23:18:15 2005 @@ -52,16 +52,17 @@ last-relay-basis (delta-identity new-basis ',type)) ',type))) - (trc "tdelta, threshhold" ,tdelta ,threshold) + (trc nil "tdelta, threshhold" ,tdelta ,threshold) (setf delta-cum ,tdelta) - (eko ("delta fire-p") + (eko (nil "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) + (trc nil "f-delta fire-value gets" delta-cum new-basis syn) + (trc nil "fdelta > new lastrelay" syn last-relay-basis) + (trc "f-delta fire-value" delta-cum) (setf last-bound-p t) (setf last-relay-basis new-basis) delta-cum)) Index: cell-cultures/cells/synapse.lisp diff -u cell-cultures/cells/synapse.lisp:1.3 cell-cultures/cells/synapse.lisp:1.4 --- cell-cultures/cells/synapse.lisp:1.3 Wed Sep 29 04:50:13 2004 +++ cell-cultures/cells/synapse.lisp Fri May 6 23:18:16 2005 @@ -31,11 +31,11 @@ `(let ((synapse (or (cdr (assoc ',lex-loc-key (cd-synapses (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-synapses - (car *c-calculators*))))))) + (let (, at closure-vars) + (make-synaptic-ruled slot-c (,fire-p ,fire-value) + , at body))) + (cd-synapses + (car *c-calculators*))))))) (c-value-ensure-current synapse)))) (defmacro make-synaptic-ruled (syn-user (fire-p fire-value) &body body) @@ -48,12 +48,14 @@ :synaptic t :rule (c-lambda-var (,c-var) (let ((,new-value (progn , at body))) - (trc nil "generic synaptic rule sees body value" ,c-var ,new-value) + (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 nil "Synapse fire YES!!" ,c-var) + (trc "Synapse fire YES!!" ,c-var) (funcall ,fire-value ,c-var ,new-value)) - .cache)))))) + (progn + (trc "Synapse fire NO!! use cache" .cache) + .cache))))))) ;__________________________________________________________________________________ ; From ktilton at common-lisp.net Fri May 6 21:18:30 2005 From: ktilton at common-lisp.net (Kenny Tilton) Date: Fri, 6 May 2005 23:18:30 +0200 (CEST) Subject: [cells-cvs] CVS update: cell-cultures/cl-openal/cl-openal-demo.lisp cell-cultures/cl-openal/cl-openal.lisp cell-cultures/cl-openal/cl-openal.lpr Message-ID: <20050506211830.3518188735@common-lisp.net> Update of /project/cells/cvsroot/cell-cultures/cl-openal In directory common-lisp.net:/tmp/cvs-serv15540/cl-openal Modified Files: cl-openal-demo.lisp cl-openal.lisp cl-openal.lpr Log Message: Establish Cells II (aka Cells 2.0, aka Cells) as Cells module in Cells project CVS tree Date: Fri May 6 23:18:23 2005 Author: ktilton Index: cell-cultures/cl-openal/cl-openal-demo.lisp diff -u cell-cultures/cl-openal/cl-openal-demo.lisp:1.1 cell-cultures/cl-openal/cl-openal-demo.lisp:1.2 --- cell-cultures/cl-openal/cl-openal-demo.lisp:1.1 Sat Jun 26 20:38:40 2004 +++ cell-cultures/cl-openal/cl-openal-demo.lisp Fri May 6 23:18:23 2005 @@ -4,7 +4,7 @@ (defparameter g-buffers (fgn-alloc 'al-uint num_buffers)) (defun cl-openal-test () - (let ((w$ (list "/dvl/sounds/click2.wav" ))) + (let ((w$ (list "/cell-cultures/cell-cultures-user/sounds/click2.wav" ))) (apply 'wav-play-till-end (lambda (dur sources) (loop for source in sources Index: cell-cultures/cl-openal/cl-openal.lisp diff -u cell-cultures/cl-openal/cl-openal.lisp:1.2 cell-cultures/cl-openal/cl-openal.lisp:1.3 --- cell-cultures/cl-openal/cl-openal.lisp:1.2 Thu Oct 28 02:09:25 2004 +++ cell-cultures/cl-openal/cl-openal.lisp Fri May 6 23:18:23 2005 @@ -41,14 +41,6 @@ (in-package :cl-openal) -(defparameter *al-dynamic-lib* :unconfigured) -(defparameter *alut-dynamic-lib* :unconfigured) -(defparameter *audio-files* :unconfigured) - -(eval-when (compile load) - (load (merge-pathnames "cl-openal-config" - cl-user::*cell-cultures-config*))) - #+doit (xoa) Index: cell-cultures/cl-openal/cl-openal.lpr diff -u cell-cultures/cl-openal/cl-openal.lpr:1.2 cell-cultures/cl-openal/cl-openal.lpr:1.3 --- cell-cultures/cl-openal/cl-openal.lpr:1.2 Fri Apr 8 11:11:18 2005 +++ cell-cultures/cl-openal/cl-openal.lpr Fri May 6 23:18:23 2005 @@ -1,11 +1,12 @@ -;; -*- lisp-version: "7.0 [Windows] (Dec 28, 2004 17:34)"; cg: "1.54.2.17"; -*- +;; -*- lisp-version: "7.0 [Windows] (Apr 6, 2005 17:03)"; cg: "1.54.2.17"; -*- (in-package :cg-user) (defpackage :CL-OPENAL) (define-project :name :cl-openal - :modules (list (make-instance 'module :name "cl-openal.lisp") + :modules (list (make-instance 'module :name "cl-openal-config.lisp") + (make-instance 'module :name "cl-openal.lisp") (make-instance 'module :name "altypes.lisp") (make-instance 'module :name "al.lisp") (make-instance 'module :name "alctypes.lisp") From ktilton at common-lisp.net Fri May 6 21:18:31 2005 From: ktilton at common-lisp.net (Kenny Tilton) Date: Fri, 6 May 2005 23:18:31 +0200 (CEST) Subject: [cells-cvs] CVS update: cell-cultures/hello-c/hello-c.lpr Message-ID: <20050506211831.C66D188729@common-lisp.net> Update of /project/cells/cvsroot/cell-cultures/hello-c In directory common-lisp.net:/tmp/cvs-serv15540/hello-c Modified Files: hello-c.lpr Log Message: Establish Cells II (aka Cells 2.0, aka Cells) as Cells module in Cells project CVS tree Date: Fri May 6 23:18:30 2005 Author: ktilton Index: cell-cultures/hello-c/hello-c.lpr diff -u cell-cultures/hello-c/hello-c.lpr:1.2 cell-cultures/hello-c/hello-c.lpr:1.3 --- cell-cultures/hello-c/hello-c.lpr:1.2 Wed Apr 6 20:06:22 2005 +++ cell-cultures/hello-c/hello-c.lpr Fri May 6 23:18:30 2005 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "7.0 [Windows] (Dec 28, 2004 17:34)"; cg: "1.54.2.17"; -*- +;; -*- lisp-version: "7.0 [Windows] (Apr 6, 2005 17:03)"; cg: "1.54.2.17"; -*- (in-package :cg-user) From ktilton at common-lisp.net Fri May 6 21:18:44 2005 From: ktilton at common-lisp.net (Kenny Tilton) Date: Fri, 6 May 2005 23:18:44 +0200 (CEST) Subject: [cells-cvs] CVS update: cell-cultures/utils-kt/debug.lisp cell-cultures/utils-kt/defpackage.lisp cell-cultures/utils-kt/detritus.lisp cell-cultures/utils-kt/flow-control.lisp cell-cultures/utils-kt/quad.lisp cell-cultures/utils-kt/strings.lisp cell-cultures/utils-kt/utils-kt.asd cell-cultures/utils-kt/utils-kt.lpr Message-ID: <20050506211844.A11DE88729@common-lisp.net> Update of /project/cells/cvsroot/cell-cultures/utils-kt In directory common-lisp.net:/tmp/cvs-serv15540/utils-kt Removed Files: debug.lisp defpackage.lisp detritus.lisp flow-control.lisp quad.lisp strings.lisp utils-kt.asd utils-kt.lpr Log Message: Establish Cells II (aka Cells 2.0, aka Cells) as Cells module in Cells project CVS tree Date: Fri May 6 23:18:36 2005 Author: ktilton From ktilton at common-lisp.net Sat May 7 23:12:45 2005 From: ktilton at common-lisp.net (Kenny Tilton) Date: Sun, 8 May 2005 01:12:45 +0200 (CEST) Subject: [cells-cvs] CVS update: cells/utils-kt/utils-kt.lpr Message-ID: <20050507231245.7989E88729@common-lisp.net> Update of /project/cells/cvsroot/cells/utils-kt In directory common-lisp.net:/tmp/cvs-serv14384/utils-kt Modified Files: utils-kt.lpr Log Message: Have slot-value reset to nil as well as c-value, on c-ephemeral-reset Date: Sun May 8 01:12:44 2005 Author: ktilton Index: cells/utils-kt/utils-kt.lpr diff -u cells/utils-kt/utils-kt.lpr:1.1 cells/utils-kt/utils-kt.lpr:1.2 --- cells/utils-kt/utils-kt.lpr:1.1 Fri May 6 23:05:56 2005 +++ cells/utils-kt/utils-kt.lpr Sun May 8 01:12:44 2005 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "7.0 [Windows] (Apr 6, 2005 17:03)"; cg: "1.54.2.17"; -*- +;; -*- lisp-version: "7.0 [Windows] (May 6, 2005 8:25)"; cg: "1.54.2.17"; -*- (in-package :cg-user) From ktilton at common-lisp.net Sat May 7 23:12:44 2005 From: ktilton at common-lisp.net (Kenny Tilton) Date: Sun, 8 May 2005 01:12:44 +0200 (CEST) Subject: [cells-cvs] CVS update: cells/cell-types.lisp cells/cells.lpr cells/defmodel.lisp cells/md-slot-value.lisp cells/optimization.lisp cells/propagate.lisp cells/synapse.lisp cells/test.lisp Message-ID: <20050507231244.2180888704@common-lisp.net> Update of /project/cells/cvsroot/cells In directory common-lisp.net:/tmp/cvs-serv14384 Modified Files: cell-types.lisp cells.lpr defmodel.lisp md-slot-value.lisp optimization.lisp propagate.lisp synapse.lisp test.lisp Log Message: Have slot-value reset to nil as well as c-value, on c-ephemeral-reset Date: Sun May 8 01:12:41 2005 Author: ktilton Index: cells/cell-types.lisp diff -u cells/cell-types.lisp:1.1 cells/cell-types.lisp:1.2 --- cells/cell-types.lisp:1.1 Fri May 6 23:05:45 2005 +++ cells/cell-types.lisp Sun May 8 01:12:40 2005 @@ -136,8 +136,6 @@ (defmethod c-useds (other) (declare (ignore other))) (defmethod c-useds ((c c-dependent)) (cd-useds c)) - - (defun c-validp (c) (eql (c-value-state c) :valid)) Index: cells/cells.lpr diff -u cells/cells.lpr:1.1 cells/cells.lpr:1.2 --- cells/cells.lpr:1.1 Fri May 6 23:05:45 2005 +++ cells/cells.lpr Sun May 8 01:12:40 2005 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "7.0 [Windows] (Dec 28, 2004 17:34)"; cg: "1.54.2.17"; -*- +;; -*- lisp-version: "7.0 [Windows] (May 6, 2005 8:25)"; cg: "1.54.2.17"; -*- (in-package :cg-user) @@ -46,7 +46,7 @@ :old-space-size 256000 :new-space-size 6144 :runtime-build-option :standard - :on-initialization 'cells::cv-test + :on-initialization 'cells::test-cells :on-restart 'do-default-restart) ;; End of Project Definition Index: cells/defmodel.lisp diff -u cells/defmodel.lisp:1.1 cells/defmodel.lisp:1.2 --- cells/defmodel.lisp:1.1 Fri May 6 23:05:45 2005 +++ cells/defmodel.lisp Sun May 8 01:12:40 2005 @@ -60,7 +60,7 @@ ; ------- defclass --------------- (^slot-value ,model ',',slotname) ; - (prog1 + (progn (defclass ,class ,(or directsupers '(model-object));; now we can def the class ,(mapcar (lambda (s) (list* (car s) @@ -123,5 +123,5 @@ ) )) )) - slotspecs)))) - + slotspecs) + (find-class ',class)))) Index: cells/md-slot-value.lisp diff -u cells/md-slot-value.lisp:1.1 cells/md-slot-value.lisp:1.2 --- cells/md-slot-value.lisp:1.1 Fri May 6 23:05:45 2005 +++ cells/md-slot-value.lisp Sun May 8 01:12:40 2005 @@ -56,7 +56,7 @@ (defun c-influenced-by-pulse (c); &aux (ip *data-pulse-id*)) (unless (c-currentp c) (count-it :c-influenced-by-pulse) - (trc c "c-influenced-by-pulse> " c (c-useds c)) + (trc nil "c-influenced-by-pulse> " c (c-useds c)) (some (lambda (used) (c-value-ensure-current used) (when (and (c-changed used) (> (c-pulse used)(c-pulse c))) @@ -209,4 +209,4 @@ absorbed-value))) - \ No newline at end of file + Index: cells/optimization.lisp diff -u cells/optimization.lisp:1.1 cells/optimization.lisp:1.2 --- cells/optimization.lisp:1.1 Fri May 6 23:05:45 2005 +++ cells/optimization.lisp Sun May 8 01:12:40 2005 @@ -34,6 +34,7 @@ (not (c-optimized-away-p c)) ;; c-streams come this way repeatedly even if optimized away (c-validp c) (not (c-synaptic c)) ;; no slot to cache invariant result, so they have to stay around) + (every (lambda (syn) (null (cd-useds syn))) (cd-synapses c)) (null (cd-useds c))) (progn Index: cells/propagate.lisp diff -u cells/propagate.lisp:1.1 cells/propagate.lisp:1.2 --- cells/propagate.lisp:1.1 Fri May 6 23:05:45 2005 +++ cells/propagate.lisp Sun May 8 01:12:40 2005 @@ -99,6 +99,7 @@ (when c (when (c-ephemeral-p c) (trc nil "!!!!!!!!!!!!!! c-ephemeral-reset resetting:" c) + (md-slot-value-store (c-model c) (c-slot-name c) nil) (setf (c-value c) nil)))) ;; good q: what does (setf 'x) return? historically nil, but...? ;----------------- change detection --------------------------------- Index: cells/synapse.lisp diff -u cells/synapse.lisp:1.1 cells/synapse.lisp:1.2 --- cells/synapse.lisp:1.1 Fri May 6 23:05:45 2005 +++ cells/synapse.lisp Sun May 8 01:12:40 2005 @@ -48,12 +48,14 @@ :synaptic t :rule (c-lambda-var (,c-var) (let ((,new-value (progn , at body))) - (trc nil "generic synaptic rule sees body value" ,c-var ,new-value) + (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 nil "Synapse fire YES!!" ,c-var) + (trc "Synapse fire YES!!" ,c-var) (funcall ,fire-value ,c-var ,new-value)) - .cache)))))) + (progn + (trc "Synapse fire NO!! use cache" .cache) + .cache))))))) ;__________________________________________________________________________________ ; Index: cells/test.lisp diff -u cells/test.lisp:1.1 cells/test.lisp:1.2 --- cells/test.lisp:1.1 Fri May 6 23:05:45 2005 +++ cells/test.lisp Sun May 8 01:12:41 2005 @@ -71,6 +71,36 @@ (ct-assert (= 21 (aa m))) :okay-m-null)) +(defmodel m-ephem () + ((m-ephem-a :cell :ephemeral :initform nil :initarg :m-ephem-a :accessor m-ephem-a) + (m-test-a :cell nil :initform nil :initarg :m-test-a :accessor m-test-a) + (m-ephem-b :cell :ephemeral :initform nil :initarg :m-ephem-b :accessor m-ephem-b) + (m-test-b :cell nil :initform nil :initarg :m-test-b :accessor m-test-b))) + +(def-c-output m-ephem-a () + (setf (m-test-a self) new-value)) + +(def-c-output m-ephem-b () + (setf (m-test-b self) new-value)) + +(def-cell-test m-ephem + (let ((m (make-be 'm-ephem :m-ephem-a (c-in nil) :m-ephem-b (c? (* 2 (or (^m-ephem-a) 0)))))) + (ct-assert (null (slot-value m 'm-ephem-a))) + (ct-assert (null (m-ephem-a m))) + (ct-assert (null (m-test-a m))) + (ct-assert (null (slot-value m 'm-ephem-b))) + (ct-assert (null (m-ephem-b m))) + (ct-assert (zerop (m-test-b m))) + (setf (m-ephem-a m) 3) + (ct-assert (null (slot-value m 'm-ephem-a))) + (ct-assert (null (m-ephem-a m))) + (ct-assert (eql 3 (m-test-a m))) + ; + (ct-assert (null (slot-value m 'm-ephem-b))) + (ct-assert (null (m-ephem-b m))) + (ct-assert (eql 6 (m-test-b m))) + )) + (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))) From ktilton at common-lisp.net Sun May 8 12:42:15 2005 From: ktilton at common-lisp.net (Kenny Tilton) Date: Sun, 8 May 2005 14:42:15 +0200 (CEST) Subject: [cells-cvs] CVS update: cells/cells.lisp cells/constructors.lisp cells/defpackage.lisp cells/integrity.lisp cells/md-slot-value.lisp cells/optimization.lisp cells/propagate.lisp cells/test.lisp Message-ID: <20050508124215.905FA880A4@common-lisp.net> Update of /project/cells/cvsroot/cells In directory common-lisp.net:/tmp/cvs-serv15583 Modified Files: cells.lisp constructors.lisp defpackage.lisp integrity.lisp md-slot-value.lisp optimization.lisp propagate.lisp test.lisp Log Message: Test for *stop*ped Cells. Eliminate *causation*, auto-detection of causal looping. Date: Sun May 8 14:42:13 2005 Author: ktilton Index: cells/cells.lisp diff -u cells/cells.lisp:1.1 cells/cells.lisp:1.2 --- cells/cells.lisp:1.1 Fri May 6 23:05:45 2005 +++ cells/cells.lisp Sun May 8 14:42:12 2005 @@ -30,7 +30,6 @@ (define-constant *c-optimizep* t) (defparameter *c-prop-depth* 0) -(defparameter *causation* nil) (defparameter *data-pulse-id* 0) (defparameter *data-pulses* nil) @@ -88,9 +87,6 @@ (defmacro without-c-dependency (&body body) `(let (*c-calculators*) , at body)) - -(define-symbol-macro .cause - (car *causation*)) (define-condition unbound-cell (unbound-slot) ()) Index: cells/constructors.lisp diff -u cells/constructors.lisp:1.1 cells/constructors.lisp:1.2 --- cells/constructors.lisp:1.1 Fri May 6 23:05:45 2005 +++ cells/constructors.lisp Sun May 8 14:42:12 2005 @@ -62,7 +62,7 @@ :lazy t :rule (c-lambda , at body))) -(defmacro c?? ((&key (tagp nil) (in nil) (trigger nil) (out t))&body body) +(defmacro c?? ((&key (tagp nil) (in nil) (out t))&body body) (let ((result (copy-symbol 'result)) (thetag (gensym))) `(make-c-dependent @@ -75,7 +75,6 @@ (declare (ignorable self ,thetag)) ,(when in `(trc "c??> entry" (c-slot-name c) (c-model c) (when ,tagp ,thetag))) - ,(when trigger `(trc "c??> trigger" .cause c)) (count-it :c?? (c-slot-name c) (md-name (c-model c))) (let ((,result (progn , at body))) ,(when out `(trc "c?? result:" ,result (c-slot-name c) (when ,tagp ,thetag))) Index: cells/defpackage.lisp diff -u cells/defpackage.lisp:1.1 cells/defpackage.lisp:1.2 --- cells/defpackage.lisp:1.1 Fri May 6 23:05:45 2005 +++ cells/defpackage.lisp Sun May 8 14:42:12 2005 @@ -47,7 +47,7 @@ (:export #:cell #:c-input #:c-in #:c-in8 #:c-formula #:c? #:c?8 #:c?_ #:c?? #:with-integrity #:with-deference #:without-c-dependency #:self - #:.cache #:c-lambda #:.cause + #:.cache #:c-lambda #:defmodel #:c-awaken #:def-c-output #:def-c-unchanged-test #:new-value #:old-value #:old-value-boundp #:c... #:make-be Index: cells/integrity.lisp diff -u cells/integrity.lisp:1.1 cells/integrity.lisp:1.2 --- cells/integrity.lisp:1.1 Fri May 6 23:05:45 2005 +++ cells/integrity.lisp Sun May 8 14:42:12 2005 @@ -106,7 +106,7 @@ -(defun finish-business (&aux task some-output setfs (setf-ct 0)) +(defun finish-business (&aux task some-output setfs) (declare (ignorable setfs)) (assert (ufb-queue :user-notify)) (assert (consp (ufb-queue :user-notify))) @@ -141,16 +141,11 @@ ; --- do deferred setfs ------------------------ (setf task (fifo-pop (ufb-queue :setf))) (when task - (incf setf-ct) (destructuring-bind ((c new-value) . task-fn) task (trc nil "finbiz: deferred setf" c new-value) - (if (find c *causation*) - (break "setf looping setting ~a to ~a with history ~a" - c new-value *causation*) - (progn - (push c setfs) - (data-pulse-next (list :finbiz c new-value)) - (funcall task-fn)))) + (push c setfs) + (data-pulse-next (list :finbiz c new-value)) + (funcall task-fn)) (go notify-users)) ; --- do finalizations ------------------------ Index: cells/md-slot-value.lisp diff -u cells/md-slot-value.lisp:1.2 cells/md-slot-value.lisp:1.3 --- cells/md-slot-value.lisp:1.2 Sun May 8 01:12:40 2005 +++ cells/md-slot-value.lisp Sun May 8 14:42:12 2005 @@ -22,19 +22,34 @@ (in-package :cells) +(defparameter *ide-app-hard-to-kill* nil) (defun md-slot-value (self slot-name &aux (c (md-slot-cell self slot-name))) - (when *stop* - (princ #\.) - (return-from md-slot-value)) - ;; (count-it :md-slot-value slot-name) - (if c - (prog1 - (with-integrity (:md-slot-value) - (c-value-ensure-current c)) - (when (car *c-calculators*) - (c-link-ex c))) - (values (bd-slot-value self slot-name) nil))) + (tagbody + retry + (when *stop* + (if *ide-app-hard-to-kill* + (progn + (princ #\.) + (return-from md-slot-value)) + (restart-case + (error "Cells is stopped due to a prior error.") + (continue () + :report "Return a slot value of nil." + (return-from md-slot-value nil)) + (reset-cells () + :report "Reset cells and retry getting the slot value." + (cell-reset) + (go retry))))) + + ;; (count-it :md-slot-value slot-name) + (if c + (prog1 + (with-integrity (:md-slot-value) + (c-value-ensure-current c)) + (when (car *c-calculators*) + (c-link-ex c))) + (values (bd-slot-value self slot-name) nil)))) (defun c-value-ensure-current (c) (count-it :c-value-ensure-current) @@ -123,10 +138,8 @@ (when (eql '.kids (c-slot-name c)) (md-kids-change (c-model c) nil prior-value :makunbound)) - (let ((causation *causation*)) - (with-integrity (:makunbound :makunbound c) - (let ((*causation* causation)) - (c-propagate c prior-value t))))))) + (with-integrity (:makunbound :makunbound c) + (c-propagate c prior-value t))))) (defun (setf md-slot-value) (new-value self slot-name @@ -137,26 +150,13 @@ (when *c-debug* (c-setting-debug self slot-name c new-value)) - (if c - (when (find c *causation*) - (case (c-cyclicp c) - (:run-on (trc "cyclicity running on" c)) - ((t) - (progn - (trc "cyclicity handled gracefully" c) - (c-pulse-update c :cyclicity-1) - (return-from md-slot-value new-value))) - (otherwise - (c-break "(setf md-slot-value) setf looping ~a ~a" c *causation*)))) - (progn - (c-break "(setf md-slot-value)> cellular slot ~a of ~a cannot be setf unless initialized as inputp" - slot-name self))) + (unless c + (c-break "(setf md-slot-value)> cellular slot ~a of ~a cannot be setf unless initialized as inputp" + slot-name self)) - (let ((causation *causation*)) - (with-integrity (:setf :setf c new-value) - (let ((*causation* causation)) - (trc nil "(setf md-slot-value) calling assume" c new-value) - (md-slot-value-assume c new-value)))) + (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)) new-value) @@ -164,13 +164,6 @@ (defmethod md-slot-value-assume (c raw-value) (assert c) - (bif (c-pos (position c *causation*)) - (bif (cyclic-pos (position-if 'c-cyclicp *causation* :end c-pos)) - (progn - (c-pulse-update c :cyclicity-0) - (return-from md-slot-value-assume raw-value)) - (c-break "md-slot-value-assume looping ~a ~a" c *causation*))) - (without-c-dependency (let ((prior-state (c-value-state c)) (prior-value (c-value c)) Index: cells/optimization.lisp diff -u cells/optimization.lisp:1.2 cells/optimization.lisp:1.3 --- cells/optimization.lisp:1.2 Sun May 8 01:12:40 2005 +++ cells/optimization.lisp Sun May 8 14:42:12 2005 @@ -34,7 +34,7 @@ (not (c-optimized-away-p c)) ;; c-streams come this way repeatedly even if optimized away (c-validp c) (not (c-synaptic c)) ;; no slot to cache invariant result, so they have to stay around) - (every (lambda (syn) (null (cd-useds syn))) (cd-synapses c)) + (every (lambda (lbl-syn) (null (cd-useds (cdr lbl-syn)))) (cd-synapses c)) (null (cd-useds c))) (progn Index: cells/propagate.lisp diff -u cells/propagate.lisp:1.2 cells/propagate.lisp:1.3 --- cells/propagate.lisp:1.2 Sun May 8 01:12:40 2005 +++ cells/propagate.lisp Sun May 8 14:42:12 2005 @@ -57,11 +57,10 @@ (c-value c) prior-value prior-value-supplied))) (defun c-propagate-to-users (c) - (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) + (trc nil "c-propagate-to-users > queueing" c) + (with-integrity (:user-notify :user-notify c) (assert (null *c-calculators*)) - (let ((*causation* causation)) + (progn (trc nil "c-propagate-to-users > notifying users of" c) (dolist (user (c-users c)) (bwhen (dead (catch :mdead @@ -72,7 +71,7 @@ (when (eq dead (c-model c)) (trc nil "!!! aborting further user prop of dead" dead) (return-from c-propagate-to-users)) - (trc nil "!!! continuing user prop following: user => dead" user dead))))))) + (trc nil "!!! continuing user prop following: user => dead" user dead)))))) (defun c-user-cares (c) (not (or (c-currentp c) @@ -82,18 +81,15 @@ (getf (symbol-plist slot-name) :output-defined)) (defun c-output-slot (c slot-name self new-value prior-value prior-value-supplied) - (let ((causation *causation*)) ;; in case deferred - (with-integrity (:c-output-slot :output c) - (let ((*causation* causation)) - (trc nil "c-output-slot > causation" c *causation* causation) - (trc nil "c-output-slot > now!!" self slot-name new-value prior-value) - (count-it :output slot-name) - (c-output-slot-name slot-name - self - new-value - prior-value - prior-value-supplied) - (c-ephemeral-reset c))))) + (with-integrity (:c-output-slot :output c) + (trc nil "c-output-slot > now!!" self slot-name new-value prior-value) + (count-it :output slot-name) + (c-output-slot-name slot-name + self + new-value + prior-value + prior-value-supplied) + (c-ephemeral-reset c))) (defun c-ephemeral-reset (c) (when c Index: cells/test.lisp diff -u cells/test.lisp:1.2 cells/test.lisp:1.3 --- cells/test.lisp:1.2 Sun May 8 01:12:41 2005 +++ cells/test.lisp Sun May 8 14:42:12 2005 @@ -54,6 +54,7 @@ `(progn (pushnew ',name *cell-tests*) (defun ,name () + (cell-reset) , at body))) (defmacro ct-assert (form &rest stuff) @@ -100,6 +101,56 @@ (ct-assert (null (m-ephem-b m))) (ct-assert (eql 6 (m-test-b m))) )) + +(defmodel m-cyc () + ((m-cyc-a :initform (c-in nil) :initarg :m-cyc-a :accessor m-cyc-a) + (m-cyc-b :initform (c-in nil) :initarg :m-cyc-b :accessor m-cyc-b))) + +(def-c-output m-cyc-a () + (print `(output m-cyc-a ,self ,new-value ,old-value)) + (setf (m-cyc-b self) new-value)) + +(def-c-output m-cyc-b () + (print `(output m-cyc-b ,self ,new-value ,old-value)) + (setf (m-cyc-a self) new-value)) + +(defun m-cyc () ;;def-cell-test m-cyc + (let ((m (make-be 'm-cyc))) + (print `(start ,(m-cyc-a m))) + (setf (m-cyc-a m) 42) + (assert (= (m-cyc-a m) 42)) + (assert (= (m-cyc-b m) 42)))) + +#+test +(m-cyc) + +(defmodel m-cyc2 () + ((m-cyc2-a :initform (c-in 0) :initarg :m-cyc2-a :accessor m-cyc2-a) + (m-cyc2-b :initform (c? (1+ (^m-cyc2-a))) + :initarg :m-cyc2-b :accessor m-cyc2-b))) + +(def-c-output m-cyc2-a () + (print `(output m-cyc2-a ,self ,new-value ,old-value)) + #+not (when (< new-value 45) + (setf (m-cyc2-b self) (1+ new-value)))) + +(def-c-output m-cyc2-b () + (print `(output m-cyc2-b ,self ,new-value ,old-value)) + (when (< new-value 45) + (setf (m-cyc2-a self) (1+ new-value)))) + +(def-cell-test m-cyc2 + (cell-reset) + (let ((m (make-be 'm-cyc2))) + (print '(start)) + (setf (m-cyc2-a m) 42) + (describe m) + (assert (= (m-cyc2-a m) 44)) + (assert (= (m-cyc2-b m) 45)) + )) + +#+test +(m-cyc2) (defmodel m-var () ((m-var-a :initform nil :initarg :m-var-a :accessor m-var-a) From ktilton at common-lisp.net Sun May 8 12:45:05 2005 From: ktilton at common-lisp.net (Kenny Tilton) Date: Sun, 8 May 2005 14:45:05 +0200 (CEST) Subject: [cells-cvs] CVS update: Module imported: cl-6502 Message-ID: <20050508124505.15424880A4@common-lisp.net> Update of /project/cells/cvsroot/cl-6502 In directory common-lisp.net:/tmp/cvs-serv15693 Log Message: James Bielman's 6502 Assembler with Cells Inside(tm). Status: Vendor Tag: tcvs-vendor Release Tags: tcvs-release No conflicts created by this import Date: Sun May 8 14:45:03 2005 Author: ktilton New module cl-6502 added From ktilton at common-lisp.net Sun May 8 12:46:57 2005 From: ktilton at common-lisp.net (Kenny Tilton) Date: Sun, 8 May 2005 14:46:57 +0200 (CEST) Subject: [cells-cvs] CVS update: cl-6502/assembler.lisp cl-6502/cl-6502.lpr cl-6502/hello-165.lisp cl-6502/hello.l65 cl-6502/instructions.lisp cl-6502/package.lisp Message-ID: <20050508124657.40E38880A4@common-lisp.net> Update of /project/cells/cvsroot/cl-6502 In directory common-lisp.net:/tmp/cvs-serv16583 Added Files: assembler.lisp cl-6502.lpr hello-165.lisp hello.l65 instructions.lisp package.lisp Log Message: Introducing James Bielman's 6502 Assembler with Cells Inside(tm). Date: Sun May 8 14:46:56 2005 Author: ktilton From ktilton at common-lisp.net Sun May 8 16:47:21 2005 From: ktilton at common-lisp.net (Kenny Tilton) Date: Sun, 8 May 2005 18:47:21 +0200 (CEST) Subject: [cells-cvs] CVS update: cells/md-slot-value.lisp Message-ID: <20050508164721.0A40E880A4@common-lisp.net> Update of /project/cells/cvsroot/cells In directory common-lisp.net:/tmp/cvs-serv3918 Modified Files: md-slot-value.lisp Log Message: Fix great honking bug in md-slot-value, introduced earlier today. Date: Sun May 8 18:47:21 2005 Author: ktilton Index: cells/md-slot-value.lisp diff -u cells/md-slot-value.lisp:1.3 cells/md-slot-value.lisp:1.4 --- cells/md-slot-value.lisp:1.3 Sun May 8 14:42:12 2005 +++ cells/md-slot-value.lisp Sun May 8 18:47:20 2005 @@ -40,16 +40,16 @@ (reset-cells () :report "Reset cells and retry getting the slot value." (cell-reset) - (go retry))))) - - ;; (count-it :md-slot-value slot-name) - (if c - (prog1 - (with-integrity (:md-slot-value) - (c-value-ensure-current c)) - (when (car *c-calculators*) - (c-link-ex c))) - (values (bd-slot-value self slot-name) nil)))) + (go retry)))))) + + ;; (count-it :md-slot-value slot-name) + (if c + (prog1 + (with-integrity (:md-slot-value) + (c-value-ensure-current c)) + (when (car *c-calculators*) + (c-link-ex c))) + (values (bd-slot-value self slot-name) nil))) (defun c-value-ensure-current (c) (count-it :c-value-ensure-current) From ktilton at common-lisp.net Wed May 18 21:43:09 2005 From: ktilton at common-lisp.net (Kenny Tilton) Date: Wed, 18 May 2005 23:43:09 +0200 (CEST) Subject: [cells-cvs] CVS update: Directory change: cells/Use Cases Message-ID: <20050518214309.284688873F@common-lisp.net> Update of /project/cells/cvsroot/cells/Use Cases In directory common-lisp.net:/tmp/cvs-serv28945/Use Cases Log Message: Directory /project/cells/cvsroot/cells/Use Cases added to the repository Date: Wed May 18 23:43:08 2005 Author: ktilton New directory cells/Use Cases added From ktilton at common-lisp.net Wed May 18 21:46:29 2005 From: ktilton at common-lisp.net (Kenny Tilton) Date: Wed, 18 May 2005 23:46:29 +0200 (CEST) Subject: [cells-cvs] CVS update: Directory change: cells/Use Cases/dow-jones Message-ID: <20050518214629.197498873F@common-lisp.net> Update of /project/cells/cvsroot/cells/Use Cases/dow-jones In directory common-lisp.net:/tmp/cvs-serv29796/dow-jones Log Message: Directory /project/cells/cvsroot/cells/Use Cases/dow-jones added to the repository Date: Wed May 18 23:46:28 2005 Author: ktilton New directory cells/Use Cases/dow-jones added From ktilton at common-lisp.net Wed May 18 21:47:32 2005 From: ktilton at common-lisp.net (Kenny Tilton) Date: Wed, 18 May 2005 23:47:32 +0200 (CEST) Subject: [cells-cvs] CVS update: cells/cell-types.lisp cells/cells.lisp cells/constructors.lisp cells/defpackage.lisp cells/family.lisp cells/integrity.lisp cells/link.lisp cells/md-slot-value.lisp cells/model-object.lisp cells/optimization.lisp cells/propagate.lisp cells/synapse.lisp cells/test.lisp Message-ID: <20050518214732.9577D8873F@common-lisp.net> Update of /project/cells/cvsroot/cells In directory common-lisp.net:/tmp/cvs-serv29834 Modified Files: cell-types.lisp cells.lisp constructors.lisp defpackage.lisp family.lisp integrity.lisp link.lisp md-slot-value.lisp model-object.lisp optimization.lisp propagate.lisp synapse.lisp test.lisp Log Message: Speed up c-link-ex a little Date: Wed May 18 23:47:29 2005 Author: ktilton Index: cells/cell-types.lisp diff -u cells/cell-types.lisp:1.2 cells/cell-types.lisp:1.3 --- cells/cell-types.lisp:1.2 Sun May 8 01:12:40 2005 +++ cells/cell-types.lisp Wed May 18 23:47:29 2005 @@ -28,7 +28,6 @@ value inputp ;; t for old c-variable class - cyclicp ;; t if OK for setf to cycle back (ending cycle) synaptic changed (users nil :type list) @@ -73,7 +72,7 @@ (defstruct (c-dependent (:include c-ruled) (:conc-name cd-)) - (synapses nil :type list) + ;; chop (synapses nil :type list) (useds nil :type list) (usage (make-array *cd-usagect* :element-type 'bit :initial-element 0) :type vector)) @@ -99,10 +98,10 @@ (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)) + then (bif (stepper (streamer-stepper s)) (funcall stepper c) (incf slot-value)) - until (bIf (to (streamer-to s)) + until (bif (to (streamer-to s)) (> slot-value to) (bwhen (donep-test (streamer-donep s)) (funcall donep-test c))) Index: cells/cells.lisp diff -u cells/cells.lisp:1.2 cells/cells.lisp:1.3 --- cells/cells.lisp:1.2 Sun May 8 14:42:12 2005 +++ cells/cells.lisp Wed May 18 23:47:29 2005 @@ -57,7 +57,8 @@ *stop*) (defmacro c-assert (assertion &optional places fmt$ &rest fmt-args) - (declare (ignore places)) + (declare (ignorable assertion places fmt$ fmt-args)) + `(progn) #+not `(unless *stop* (unless ,assertion ,(if fmt$ Index: cells/constructors.lisp diff -u cells/constructors.lisp:1.2 cells/constructors.lisp:1.3 --- cells/constructors.lisp:1.2 Sun May 8 14:42:12 2005 +++ cells/constructors.lisp Wed May 18 23:47:29 2005 @@ -33,6 +33,12 @@ (declare (ignorable .cache self)) , at body)) +(defmacro with-c-cache ((fn) &body body) + (let ((new (gensym))) + `(or (bwhen (,new (progn , at body)) + (funcall ,fn ,new .cache)) + .cache))) + ;----------------------------------------- (defmacro c? (&body body) @@ -41,12 +47,6 @@ :value-state :unevaluated :rule (c-lambda , at body))) -(defmacro c?8 (&body body) - `(make-c-dependent - :code ',body - :cyclicp t - :value-state :unevaluated - :rule (c-lambda , at body))) (defmacro c?dbg (&body body) `(make-c-dependent @@ -98,13 +98,6 @@ (defmacro c-in (value) `(make-cell :inputp t - :value-state :valid - :value ,value)) - -(defmacro c-in8 (value) - `(make-cell - :inputp t - :cyclicp t :value-state :valid :value ,value)) Index: cells/defpackage.lisp diff -u cells/defpackage.lisp:1.2 cells/defpackage.lisp:1.3 --- cells/defpackage.lisp:1.2 Sun May 8 14:42:12 2005 +++ cells/defpackage.lisp Wed May 18 23:47:29 2005 @@ -47,7 +47,7 @@ (:export #:cell #:c-input #:c-in #:c-in8 #:c-formula #:c? #:c?8 #:c?_ #:c?? #:with-integrity #:with-deference #:without-c-dependency #:self - #:.cache #:c-lambda + #:.cache #:.with-c-cache #:c-lambda #:defmodel #:c-awaken #:def-c-output #:def-c-unchanged-test #:new-value #:old-value #:old-value-boundp #:c... #:make-be Index: cells/family.lisp diff -u cells/family.lisp:1.1 cells/family.lisp:1.2 --- cells/family.lisp:1.1 Fri May 6 23:05:45 2005 +++ cells/family.lisp Wed May 18 23:47:29 2005 @@ -67,18 +67,7 @@ )) (defmacro the-kids (&rest kids) - `(packed-flat! ,@(mapcar (lambda (kid) - (typecase kid - (keyword `(make-instance ',(intern$ (symbol-name kid)))) - (t `,kid))) - kids))) - -(defmacro the-kids-2 (&rest kids) - `(packed-flat! ,@(mapcar (lambda (kid) - (typecase kid - (keyword `(make-instance ',(intern$ (symbol-name kid)))) - (t `,kid))) - kids))) + `(packed-flat! , at kids)) (defun kid1 (self) (car (kids self))) (defun last-kid (self) (last1 (kids self))) @@ -120,6 +109,7 @@ (let ((curr-parent (fm-parent self)) (selftype (type-of self))) + (declare (ignorable curr-parent)) (c-assert (or (null curr-parent) (eql fm-parent curr-parent))) (when (plusp (adopt-ct self)) Index: cells/integrity.lisp diff -u cells/integrity.lisp:1.2 cells/integrity.lisp:1.3 --- cells/integrity.lisp:1.2 Sun May 8 14:42:12 2005 +++ cells/integrity.lisp Wed May 18 23:47:29 2005 @@ -118,7 +118,7 @@ (when user-q-item (destructuring-bind (defer-info . task) user-q-item (declare (ignorable defer-info)) - (trc nil "finbiz notifying users of cell" (car defer-info)) + (trc nil "finbiz notifying users of cell" (car defer-info) (cd-users (car defer-info))) (funcall task) (go notify-users)))) @@ -127,13 +127,13 @@ next-output (when *stop* (return-from finish-business)) ;--- do c-output-slot-name ----------------------- - (setf task (cdr (fifo-pop (ufb-queue :output)))) + (setf task (fifo-pop (ufb-queue :output))) (cond (task (setf some-output t) - (trc nil "finish-business outputting------------------------") - (funcall task) + (trc nil "finish-business outputting--------" (car task)) + (funcall (cdr task)) (go next-output)) (some-output (go notify-users))) Index: cells/link.lisp diff -u cells/link.lisp:1.1 cells/link.lisp:1.2 --- cells/link.lisp:1.1 Fri May 6 23:05:45 2005 +++ cells/link.lisp Wed May 18 23:47:29 2005 @@ -22,9 +22,6 @@ (in-package :cells) - - - (defun c-link-ex (used &aux (user (car *c-calculators*))) (c-assert user) (assert used) @@ -46,15 +43,33 @@ (c-assert (not (eq :eternal-rest (md-state (c-model used))))) (count-it :c-link-entry) - - (unless (find used (c-useds user)) - (trc nil "c-link > new user,used " user used) - (c-add-user used user) - (c-add-used user used)) - - (let ((mapn (- *cd-usagect* - (- (length (cd-useds user)) - (or (position used (cd-useds user)) 0))))) +;;; (loop for ku in (c-usesds user) +;;; for posn upfrom 0 +;;; wh + +;;; (loop with prior-used = 0 +;;; and found = nil +;;; for known-used in (c-useds user) +;;; when (eq known-used used) +;;; do (progn +;;; (setf found t) +;;; (loop-finish)) +;;; finally (return (- *cd-usagect* +;;; (- (length (cd-useds user)) +;;; (or (position used (cd-useds user)) 0))))) + + (if (find used (c-useds user)) + (count-it :known-used) + (progn + (trc nil "c-link > new user,used " user used) + (count-it :new-used) + (push user (c-users used)) + (push used (cd-useds user)))) + + (let ((mapn (get-mapn used (cd-useds user)) + #+not (- *cd-usagect* + (- (length (cd-useds user)) + (or (position used (cd-useds user)) 0))))) ;; (trc user "c-link> setting usage bit" user mapn used) (if (minusp mapn) (c-break "whoa. more than ~d used by ~a? i see ~d" @@ -62,6 +77,20 @@ (cd-usage-set user mapn))) used) +#+TEST +(dotimes (n 3) + (trc "mapn" n (get-mapn n '(0 1 2)))) + +(defun get-mapn (seek map) + (- *cd-usagect* + (loop with seek-pos = nil + for m in map + for pos upfrom 0 + counting m into m-len + when (eql seek m) + do (setf seek-pos pos) + finally (return (- m-len seek-pos))))) + ;--- c-unlink-unused -------------------------------- (defun c-unlink-unused (c &aux (usage (cd-usage c))) @@ -74,33 +103,17 @@ (c-assert (< mapn *cd-usagect*)) (trc nil "dropping unused" used :mapn-usage mapn usage) + (count-it :unlink-unused) (c-unlink-user used c) (rplaca useds nil)) (setf (cd-useds c) (delete-if #'null (cd-useds c)))) -(defun c-add-user (used user) - (count-it :c-adduser) - (pushnew user (c-users used)) - used) - (defun c-user-path-exists-p (from-used to-user) (count-it :user-path-exists-p) (or (find to-user (c-users from-used)) (find-if (lambda (from-used-user) (c-user-path-exists-p from-used-user to-user)) (c-users from-used)))) - -; ----------- - -(defun c-add-used (user used) - (count-it :c-used) - #+ucount (unless (member used (cd-useds user)) - (incf *cd-useds*) - (when (zerop (mod *cd-useds* 100)) - (trc "useds count = " *cd-useds*))) - (pushnew used (cd-useds user)) - (trc nil "c-add-used> user <= used" user used (length (cd-useds user))) - (cd-useds user)) ; --------------------------------------------- Index: cells/md-slot-value.lisp diff -u cells/md-slot-value.lisp:1.4 cells/md-slot-value.lisp:1.5 --- cells/md-slot-value.lisp:1.4 Sun May 8 18:47:20 2005 +++ cells/md-slot-value.lisp Wed May 18 23:47:29 2005 @@ -139,8 +139,7 @@ (md-kids-change (c-model c) nil prior-value :makunbound)) (with-integrity (:makunbound :makunbound c) - (c-propagate c prior-value t))))) - + (c-propagate c prior-value t))))) (defun (setf md-slot-value) (new-value self slot-name &aux (c (md-slot-cell self slot-name))) @@ -186,11 +185,12 @@ ; --- 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)) (progn - (trc nil "(setf md-slot-value) >no-news" prior-state (c-no-news c absorbed-value prior-value)) - (count-it :no-news)) + (trc nil "(setf md-slot-value) >no news" prior-state (c-no-news c absorbed-value prior-value)) + (count-it :nonews)) (progn (setf (c-changed c) t) (trc nil "sv-assume: flagging as changed" c absorbed-value prior-value prior-state) Index: cells/model-object.lisp diff -u cells/model-object.lisp:1.1 cells/model-object.lisp:1.2 --- cells/model-object.lisp:1.1 Fri May 6 23:05:45 2005 +++ cells/model-object.lisp Wed May 18 23:47:29 2005 @@ -52,6 +52,7 @@ (push (cons slot-name new-type) (get class-name :cell-types))))) (defmethod md-slot-value-store ((self model-object) slot-name new-value) + (trc nil "md-slot-value-store" slot-name new-value) (setf (slot-value self slot-name) new-value)) (defun md-slot-cell-flushed (self slot-name) @@ -73,6 +74,7 @@ (defun (setf md-slot-cell) (new-cell self slot-name) (bif (entry (assoc slot-name (cells self))) (let ((old (cdr entry))) ;; s/b being supplanted by kid-slotter + (declare (ignorable old)) (c-assert (null (c-users old))) (c-assert (null (cd-useds old))) (trc nil "replacing in model .cells" old new-cell self) Index: cells/optimization.lisp diff -u cells/optimization.lisp:1.3 cells/optimization.lisp:1.4 --- cells/optimization.lisp:1.3 Sun May 8 14:42:12 2005 +++ cells/optimization.lisp Wed May 18 23:47:29 2005 @@ -34,7 +34,7 @@ (not (c-optimized-away-p c)) ;; c-streams come this way repeatedly even if optimized away (c-validp c) (not (c-synaptic c)) ;; no slot to cache invariant result, so they have to stay around) - (every (lambda (lbl-syn) (null (cd-useds (cdr lbl-syn)))) (cd-synapses c)) + ;; chop (every (lambda (lbl-syn) (null (cd-useds (cdr lbl-syn)))) (cd-synapses c)) (null (cd-useds c))) (progn @@ -50,9 +50,8 @@ (dolist (user (c-users c)) (setf (cd-useds user) (delete c (cd-useds user))) - (trc nil "checking opti2" c :user> user) - (when (c-optimize-away?! user) - (trc "Wow!!! optimizing chain reaction, first:" c :then user))) + (c-optimize-away?! user) ;; rare but it happens when rule says (or .cache ...) + ) t) (progn Index: cells/propagate.lisp diff -u cells/propagate.lisp:1.3 cells/propagate.lisp:1.4 --- cells/propagate.lisp:1.3 Sun May 8 14:42:12 2005 +++ cells/propagate.lisp Wed May 18 23:47:29 2005 @@ -59,13 +59,13 @@ (defun c-propagate-to-users (c) (trc nil "c-propagate-to-users > queueing" c) (with-integrity (:user-notify :user-notify c) - (assert (null *c-calculators*)) (progn (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) + (trc nil "c=prop updating" user :used c) (c-value-ensure-current user)) nil)) (when (eq dead (c-model c)) @@ -83,7 +83,7 @@ (defun c-output-slot (c slot-name self new-value prior-value prior-value-supplied) (with-integrity (:c-output-slot :output c) (trc nil "c-output-slot > now!!" self slot-name new-value prior-value) - (count-it :output slot-name) + ;; (count-it :output slot-name) (c-output-slot-name slot-name self new-value Index: cells/synapse.lisp diff -u cells/synapse.lisp:1.2 cells/synapse.lisp:1.3 --- cells/synapse.lisp:1.2 Sun May 8 01:12:40 2005 +++ cells/synapse.lisp Wed May 18 23:47:29 2005 @@ -28,15 +28,19 @@ (defmacro with-synapse (((&rest closure-vars) &key trcp fire-p fire-value) &body body) (declare (ignorable trcp)) (let ((lex-loc-key (gensym "synapse-id"))) - `(let ((synapse (or (cdr (assoc ',lex-loc-key (cd-synapses - (car *c-calculators*)))) + `(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-synapses + (cd-useds (car *c-calculators*))))))) - (c-value-ensure-current synapse)))) + (prog1 + (with-integrity (:with-synapse) + (c-value-ensure-current synapse)) + (when (car *c-calculators*) + (c-link-ex synapse)))))) (defmacro make-synaptic-ruled (syn-user (fire-p fire-value) &body body) (let ((new-value (gensym)) Index: cells/test.lisp diff -u cells/test.lisp:1.3 cells/test.lisp:1.4 --- cells/test.lisp:1.3 Sun May 8 14:42:12 2005 +++ cells/test.lisp Wed May 18 23:47:29 2005 @@ -20,6 +20,35 @@ ;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS ;;; IN THE SOFTWARE. +#| Synapse Cell Unification Notes + +- start by making Cells synapse-y + +- make sure outputs show right old and new values +- make sure outputs fire when they should + +- wow: test the Cells II dictates: no output callback sees stale data, no rule +sees stale data, etc etc + +- test a lot of different synapses + +- 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 +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 + +- does SETF honor not propagating, as well as a c-ruled after re-calcing + +- do diff unchanged tests such as string-equal work + +|# + #| do list -- can we lose the special handling of the .kids slot? @@ -36,6 +65,7 @@ (defparameter *cell-tests* nil) + #+go (test-cells) @@ -69,88 +99,22 @@ (let ((m (make-be 'm-null :aa 42))) (ct-assert (= 42 (aa m))) (ct-assert (= 21 (decf (aa m) 21))) - (ct-assert (= 21 (aa m))) :okay-m-null)) -(defmodel m-ephem () - ((m-ephem-a :cell :ephemeral :initform nil :initarg :m-ephem-a :accessor m-ephem-a) - (m-test-a :cell nil :initform nil :initarg :m-test-a :accessor m-test-a) - (m-ephem-b :cell :ephemeral :initform nil :initarg :m-ephem-b :accessor m-ephem-b) - (m-test-b :cell nil :initform nil :initarg :m-test-b :accessor m-test-b))) - -(def-c-output m-ephem-a () - (setf (m-test-a self) new-value)) - -(def-c-output m-ephem-b () - (setf (m-test-b self) new-value)) - -(def-cell-test m-ephem - (let ((m (make-be 'm-ephem :m-ephem-a (c-in nil) :m-ephem-b (c? (* 2 (or (^m-ephem-a) 0)))))) - (ct-assert (null (slot-value m 'm-ephem-a))) - (ct-assert (null (m-ephem-a m))) - (ct-assert (null (m-test-a m))) - (ct-assert (null (slot-value m 'm-ephem-b))) - (ct-assert (null (m-ephem-b m))) - (ct-assert (zerop (m-test-b m))) - (setf (m-ephem-a m) 3) - (ct-assert (null (slot-value m 'm-ephem-a))) - (ct-assert (null (m-ephem-a m))) - (ct-assert (eql 3 (m-test-a m))) - ; - (ct-assert (null (slot-value m 'm-ephem-b))) - (ct-assert (null (m-ephem-b m))) - (ct-assert (eql 6 (m-test-b m))) - )) - -(defmodel m-cyc () - ((m-cyc-a :initform (c-in nil) :initarg :m-cyc-a :accessor m-cyc-a) - (m-cyc-b :initform (c-in nil) :initarg :m-cyc-b :accessor m-cyc-b))) - -(def-c-output m-cyc-a () - (print `(output m-cyc-a ,self ,new-value ,old-value)) - (setf (m-cyc-b self) new-value)) - -(def-c-output m-cyc-b () - (print `(output m-cyc-b ,self ,new-value ,old-value)) - (setf (m-cyc-a self) new-value)) - -(defun m-cyc () ;;def-cell-test m-cyc - (let ((m (make-be 'm-cyc))) - (print `(start ,(m-cyc-a m))) - (setf (m-cyc-a m) 42) - (assert (= (m-cyc-a m) 42)) - (assert (= (m-cyc-b m) 42)))) - -#+test -(m-cyc) - -(defmodel m-cyc2 () - ((m-cyc2-a :initform (c-in 0) :initarg :m-cyc2-a :accessor m-cyc2-a) - (m-cyc2-b :initform (c? (1+ (^m-cyc2-a))) - :initarg :m-cyc2-b :accessor m-cyc2-b))) - -(def-c-output m-cyc2-a () - (print `(output m-cyc2-a ,self ,new-value ,old-value)) - #+not (when (< new-value 45) - (setf (m-cyc2-b self) (1+ new-value)))) - -(def-c-output m-cyc2-b () - (print `(output m-cyc2-b ,self ,new-value ,old-value)) - (when (< new-value 45) - (setf (m-cyc2-a self) (1+ new-value)))) - -(def-cell-test m-cyc2 - (cell-reset) - (let ((m (make-be 'm-cyc2))) - (print '(start)) - (setf (m-cyc2-a m) 42) - (describe m) - (assert (= (m-cyc2-a m) 44)) - (assert (= (m-cyc2-b m) 45)) - )) - -#+test -(m-cyc2) +(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))) + +(def-cell-test m-solo + (let ((m (make-be 'm-solo + :m-solo-a (c-in 42) + :m-solo-b (c? (* 2 (^m-solo-a)))))) + (ct-assert (= 42 (m-solo-a m))) + (ct-assert (= 84 (m-solo-b m))) + (decf (m-solo-a m)) + (ct-assert (= 41 (m-solo-a m))) + (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) From ktilton at common-lisp.net Wed May 18 21:47:35 2005 From: ktilton at common-lisp.net (Kenny Tilton) Date: Wed, 18 May 2005 23:47:35 +0200 (CEST) Subject: [cells-cvs] CVS update: cells/utils-kt/debug.lisp cells/utils-kt/flow-control.lisp Message-ID: <20050518214735.968508873F@common-lisp.net> Update of /project/cells/cvsroot/cells/utils-kt In directory common-lisp.net:/tmp/cvs-serv29834/utils-kt Modified Files: debug.lisp flow-control.lisp Log Message: Speed up c-link-ex a little Date: Wed May 18 23:47:33 2005 Author: ktilton Index: cells/utils-kt/debug.lisp diff -u cells/utils-kt/debug.lisp:1.1 cells/utils-kt/debug.lisp:1.2 --- cells/utils-kt/debug.lisp:1.1 Fri May 6 23:05:56 2005 +++ cells/utils-kt/debug.lisp Wed May 18 23:47:32 2005 @@ -157,6 +157,8 @@ (setf *count* nil)) (defmacro count-it (&rest keys) + (declare (ignorable keys)) + #+not `(progn) `(when *counting* (call-count-it , at keys))) Index: cells/utils-kt/flow-control.lisp diff -u cells/utils-kt/flow-control.lisp:1.1 cells/utils-kt/flow-control.lisp:1.2 --- cells/utils-kt/flow-control.lisp:1.1 Fri May 6 23:05:56 2005 +++ cells/utils-kt/flow-control.lisp Wed May 18 23:47:32 2005 @@ -67,7 +67,7 @@ , at body)) (defun intern$ (&rest strings) - (intern (apply #'concatenate 'string (mapcar #'string-upcase strings)))) + (intern (apply #'concatenate 'string strings))) #-allegro (defmacro until (test &body body) From ktilton at common-lisp.net Thu May 19 20:17:50 2005 From: ktilton at common-lisp.net (Kenny Tilton) Date: Thu, 19 May 2005 22:17:50 +0200 (CEST) Subject: [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 Message-ID: <20050519201750.1A8C08873A@common-lisp.net> 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))) From ktilton at common-lisp.net Sat May 21 01:40:55 2005 From: ktilton at common-lisp.net (Kenny Tilton) Date: Sat, 21 May 2005 03:40:55 +0200 (CEST) Subject: [cells-cvs] CVS update: cells/cell-types.lisp cells/fm-utilities.lisp cells/md-slot-value.lisp cells/propagate.lisp Message-ID: <20050521014055.2DAAA88759@common-lisp.net> Update of /project/cells/cvsroot/cells In directory common-lisp.net:/tmp/cvs-serv26948 Modified Files: cell-types.lisp fm-utilities.lisp md-slot-value.lisp propagate.lisp Log Message: Dow-Jones use case: Use new :no-propagate rule option to suppress processing of trades at unchanged price. Date: Sat May 21 03:40:54 2005 Author: ktilton Index: cells/cell-types.lisp diff -u cells/cell-types.lisp:1.4 cells/cell-types.lisp:1.5 --- cells/cell-types.lisp:1.4 Thu May 19 22:17:47 2005 +++ cells/cell-types.lisp Sat May 21 03:40:53 2005 @@ -38,6 +38,10 @@ debug md-info) +(defmethod trcp ((c cell)) + nil #+not (and (typep (c-model c) 'index) + (eql 'state (c-slot-name c)))) + (defun c-unboundp (c) (eql :unbound (c-value-state c))) Index: cells/fm-utilities.lisp diff -u cells/fm-utilities.lisp:1.1 cells/fm-utilities.lisp:1.2 --- cells/fm-utilities.lisp:1.1 Fri May 6 23:05:45 2005 +++ cells/fm-utilities.lisp Sat May 21 03:40:53 2005 @@ -123,26 +123,25 @@ (defun fm-traverse (family applied-fn &key skip-node skip-tree global-search (opaque nil)) ;;(when *fmdbg* (trc "fm-traverse" family skipTree skipNode global-search)) + (without-c-dependency (when family - (labels ((tv-family (fm) - (when (and (typep fm 'model-object) - (not (eql fm skip-tree))) - (let ((outcome (and (not (eql skip-node fm)) ;; skipnode new 990310 kt - (funcall applied-fn fm)))) - (unless (and outcome opaque) - (dolist (kid (kids fm)) - (tv-family kid)) - ;(tv-family (mdValue fm)) - ))))) - (tv-family family) - (when global-search - (fm-traverse (fm-parent family) applied-fn - :global-search t - :skip-tree family - :skip-node skip-node) - ) - ) - nil)) + (labels ((tv-family (fm) + (when (and (typep fm 'model-object) + (not (eql fm skip-tree))) + (let ((outcome (and (not (eql skip-node fm)) ;; skipnode new 990310 kt + (funcall applied-fn fm)))) + (unless (and outcome opaque) + (dolist (kid (kids fm)) + (tv-family kid)) + ;(tv-family (mdValue fm)) + ))))) + (tv-family family) + (when global-search + (fm-traverse (fm-parent family) applied-fn + :global-search t + :skip-tree family + :skip-node skip-node)))) + nil)) (defmethod sub-nodes (other) (declare (ignore other))) @@ -423,10 +422,11 @@ :global-search global-search)) (defmacro fm^ (md-name &key (skip-tree 'self)) - `(fm-find-one (fm-parent self) ,md-name - :skip-tree ,skip-tree - :must-find t - :global-search t)) + `(without-c-dependency + (fm-find-one (fm-parent self) ,md-name + :skip-tree ,skip-tree + :must-find t + :global-search t))) (defmacro fm? (md-name &optional (starting 'self) (global-search t)) `(fm-find-one ,starting ,(if (consp md-name) Index: cells/md-slot-value.lisp diff -u cells/md-slot-value.lisp:1.6 cells/md-slot-value.lisp:1.7 --- cells/md-slot-value.lisp:1.6 Thu May 19 22:17:47 2005 +++ cells/md-slot-value.lisp Sat May 21 03:40:53 2005 @@ -184,7 +184,7 @@ ; --- data flow propagation ----------- ; - (trc nil "md-sv comparing" c prior-state absorbed-value prior-value) + (trc nil "md-sv comparing no-prop" c prior-state absorbed-value prior-value) (if (or (eq propagation-code :no-propagate) (and (null propagation-code) (eql prior-state :valid) @@ -194,7 +194,7 @@ (count-it :nonews)) (progn (setf (c-changed c) t) - (trc nil "sv-assume: flagging as changed" c absorbed-value prior-value prior-state) + (trc nil "sv-assume: propagating changed as changed" c) ;; absorbed-value prior-value prior-state) (when (eql '.kids (c-slot-name c)) (md-kids-change (c-model c) absorbed-value prior-value :mdslotvalueassume)) Index: cells/propagate.lisp diff -u cells/propagate.lisp:1.5 cells/propagate.lisp:1.6 --- cells/propagate.lisp:1.5 Thu May 19 22:17:47 2005 +++ cells/propagate.lisp Sat May 21 03:40:53 2005 @@ -65,7 +65,7 @@ (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) - (trc nil "c=prop updating" user :used c) + (trc user "propagating to user is (used,user):" c user) (c-value-ensure-current user)) nil)) (when (eq dead (c-model c)) From ktilton at common-lisp.net Sat May 21 15:13:13 2005 From: ktilton at common-lisp.net (Kenny Tilton) Date: Sat, 21 May 2005 17:13:13 +0200 (CEST) Subject: [cells-cvs] CVS update: cells/link.lisp cells/md-slot-value.lisp Message-ID: <20050521151313.17B2588743@common-lisp.net> Update of /project/cells/cvsroot/cells In directory common-lisp.net:/tmp/cvs-serv10097 Modified Files: link.lisp md-slot-value.lisp Log Message: Mo' better tuning, esp. of c-link-ex Date: Sat May 21 17:13:12 2005 Author: ktilton Index: cells/link.lisp diff -u cells/link.lisp:1.3 cells/link.lisp:1.4 --- cells/link.lisp:1.3 Thu May 19 22:17:47 2005 +++ cells/link.lisp Sat May 21 17:13:12 2005 @@ -22,11 +22,14 @@ (in-package :cells) +(eval-when (compile load) + (proclaim '(optimize (speed 3) (safety 0) (space 0) (debug 0)))) + + (defun c-link-ex (used &aux (user (car *c-calculators*))) (c-assert user) - (assert used) - (when (or (c-optimized-away-p used) - (not (typep used 'cell))) + (c-assert used) + (when (c-optimized-away-p used) ;; 2005-05-21 removed slow type check that used is cell (return-from c-link-ex nil)) @@ -43,51 +46,55 @@ (c-assert (not (eq :eternal-rest (md-state (c-model used))))) (count-it :c-link-entry) -;;; (loop for ku in (c-usesds user) -;;; for posn upfrom 0 -;;; wh - -;;; (loop with prior-used = 0 -;;; and found = nil -;;; for known-used in (c-useds user) -;;; when (eq known-used used) -;;; do (progn -;;; (setf found t) -;;; (loop-finish)) -;;; finally (return (- *cd-usagect* -;;; (- (length (cd-useds user)) -;;; (or (position used (cd-useds user)) 0))))) - - (if (find used (c-useds user)) - (count-it :known-used) - (progn + (multiple-value-bind (used-pos useds-len) + (loop with u-pos + for known in (cd-useds user) + counting known into length + ;; do (print (list :data known length)) + when (eq used known) + do + (count-it :known-used) + (setf u-pos (1- length)) + finally (return (values u-pos length))) + + (when (null used-pos) (trc nil "c-link > new user,used " user used) (count-it :new-used) + (incf useds-len) + (setf used-pos 0) (push user (c-users used)) - (push used (cd-useds user)))) + (push used (cd-useds user))) - (let ((mapn (get-mapn used (cd-useds user)) - #+not (- *cd-usagect* - (- (length (cd-useds user)) - (or (position used (cd-useds user)) 0))))) - ;; (trc user "c-link> setting usage bit" user mapn used) - (if (minusp mapn) - (c-break "whoa. more than ~d used by ~a? i see ~d" - *cd-usagect* user (length (cd-useds user))) - (cd-usage-set user mapn))) + (let ((mapn (- *cd-usagect* + (- useds-len used-pos)))) + ;; (trc user "c-link> setting usage bit" user mapn used) + (if (minusp mapn) + (c-break "whoa. more than ~d used by ~a? i see ~d" + *cd-usagect* user (length (cd-useds user))) + (cd-usage-set user mapn)))) used) - +#+test +(dotimes (used 3) + (print (multiple-value-bind (p l) + (loop with u-pos + for known in '(0 2) + counting known into length + ;; do (print (list :data known length)) + when (eql used known) do (setf u-pos (1- length)) + finally (return (values u-pos length))) + (list p l)))) #+TEST (dotimes (n 3) (trc "mapn" n (get-mapn n '(0 1 2)))) (defun get-mapn (seek map) + (declare (fixnum *cd-usagect*)) (- *cd-usagect* (loop with seek-pos = nil for m in map - for pos upfrom 0 - counting m into m-len - when (eql seek m) + for pos fixnum upfrom 0 + counting m into m-len fixnum + when (eq seek m) do (setf seek-pos pos) finally (return (- m-len seek-pos))))) Index: cells/md-slot-value.lisp diff -u cells/md-slot-value.lisp:1.7 cells/md-slot-value.lisp:1.8 --- cells/md-slot-value.lisp:1.7 Sat May 21 03:40:53 2005 +++ cells/md-slot-value.lisp Sat May 21 17:13:12 2005 @@ -58,7 +58,13 @@ ((c-inputp c)) ((c-currentp c)) ((or (not (c-validp c)) - (c-influenced-by-pulse c)) + (some (lambda (used) + (c-value-ensure-current used) + (when (and (c-changed used) (> (c-pulse used)(c-pulse c))) + #+chya (trc nil "used changed" used :asker c + :inpulse ip :pulse *data-pulse-id*) + t)) + (cd-useds c))) (c-calculate-and-set c)) (t (c-pulse-update c :valid-uninfluenced))) @@ -67,18 +73,7 @@ (error 'unbound-cell :instance (c-model c) :name (c-slot-name c))) (c-value c)) - -(defun c-influenced-by-pulse (c); &aux (ip *data-pulse-id*)) - (unless (c-currentp c) - (count-it :c-influenced-by-pulse) - (trc nil "c-influenced-by-pulse> " c (c-useds c)) - (some (lambda (used) - (c-value-ensure-current used) - (when (and (c-changed used) (> (c-pulse used)(c-pulse c))) - #+chya (trc nil "used changed" used :asker c - :inpulse ip :pulse *data-pulse-id*) - t)) - (c-useds c)))) + ;; 2005-05-21 was c-useds, but I think these are c-dependents (defun c-calculate-and-set (c) (flet ((body () From ktilton at common-lisp.net Wed May 25 05:04:50 2005 From: ktilton at common-lisp.net (Kenny Tilton) Date: Wed, 25 May 2005 07:04:50 +0200 (CEST) Subject: [cells-cvs] CVS update: cells/utils-kt/debug.lisp Message-ID: <20050525050450.3F9FF8873D@common-lisp.net> Update of /project/cells/cvsroot/cells/utils-kt In directory common-lisp.net:/tmp/cvs-serv29610/utils-kt Modified Files: debug.lisp Log Message: Fix make-synaptic-ruled to evaluate synapse ID Date: Wed May 25 07:04:47 2005 Author: ktilton Index: cells/utils-kt/debug.lisp diff -u cells/utils-kt/debug.lisp:1.2 cells/utils-kt/debug.lisp:1.3 --- cells/utils-kt/debug.lisp:1.2 Wed May 18 23:47:32 2005 +++ cells/utils-kt/debug.lisp Wed May 25 07:04:47 2005 @@ -55,7 +55,7 @@ (assert (stringp ,(car os))) (call-trc t , at os)) ;;,(car os) ,tgt ,@(cdr os))) (progn - ;;(break "trcfailed") + (break "trcfailed") (count-it :trcfailed))) (count-it :tgtnileval))))))) From ktilton at common-lisp.net Wed May 25 05:04:50 2005 From: ktilton at common-lisp.net (Kenny Tilton) Date: Wed, 25 May 2005 07:04:50 +0200 (CEST) Subject: [cells-cvs] CVS update: cells/propagate.lisp cells/synapse-types.lisp cells/synapse.lisp Message-ID: <20050525050450.5FABD88766@common-lisp.net> Update of /project/cells/cvsroot/cells In directory common-lisp.net:/tmp/cvs-serv29610 Modified Files: propagate.lisp synapse-types.lisp synapse.lisp Log Message: Fix make-synaptic-ruled to evaluate synapse ID Date: Wed May 25 07:04:46 2005 Author: ktilton Index: cells/propagate.lisp diff -u cells/propagate.lisp:1.6 cells/propagate.lisp:1.7 --- cells/propagate.lisp:1.6 Sat May 21 03:40:53 2005 +++ cells/propagate.lisp Wed May 25 07:04:46 2005 @@ -65,7 +65,7 @@ (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) - (trc user "propagating to user is (used,user):" c user) + (trc nil "propagating to user is (used,user):" c user) (c-value-ensure-current user)) nil)) (when (eq dead (c-model c)) Index: cells/synapse-types.lisp diff -u cells/synapse-types.lisp:1.2 cells/synapse-types.lisp:1.3 --- cells/synapse-types.lisp:1.2 Thu May 19 22:17:47 2005 +++ cells/synapse-types.lisp Wed May 25 07:04:46 2005 @@ -40,7 +40,7 @@ :no-propagate))) (values (if (eq prop-code :propagate) (progn - (trc "sense prior fire value now" new-value) + (trc nil "sense prior fire value now" new-value) (setf prior-fire-value new-value)) new-value) prop-code))))) Index: cells/synapse.lisp diff -u cells/synapse.lisp:1.4 cells/synapse.lisp:1.5 --- cells/synapse.lisp:1.4 Thu May 19 22:17:47 2005 +++ cells/synapse.lisp Wed May 25 07:04:46 2005 @@ -27,26 +27,29 @@ (defmacro with-synapse (synapse-id (&rest closure-vars) &body body) (declare (ignorable trcp)) - `(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)))) + (let ((syn-id (gensym))) + `(let* ((,syn-id (eko ("!!! syn-id =") ,synapse-id)) + (synapse-user (car *c-calculators*)) + (synapse (or (bIf (ku (find ,syn-id (cd-useds synapse-user) :key 'c-slot-name)) + (progn + (trc "withsyn reusing known" ,syn-id ku) + ku)) + (let ((new-syn + (let (, at closure-vars) + (trc "withsyn making new syn" ,syn-id + :known (mapcar 'c-slot-name (cd-useds synapse-user))) + (make-synaptic-ruled ,syn-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-pseudo-slot syn-user &body body) `(make-c-dependent :model (c-model ,syn-user) - :slot-name ',syn-pseudo-slot + :slot-name ,syn-pseudo-slot :code ',body :synaptic t :rule (c-lambda , at body))) From ktilton at common-lisp.net Thu May 26 01:15:52 2005 From: ktilton at common-lisp.net (Kenny Tilton) Date: Thu, 26 May 2005 03:15:52 +0200 (CEST) Subject: [cells-cvs] CVS update: cells/cells.lisp cells/link.lisp cells/md-slot-value.lisp cells/propagate.lisp cells/synapse.lisp Message-ID: <20050526011552.2B583880DD@common-lisp.net> Update of /project/cells/cvsroot/cells In directory common-lisp.net:/tmp/cvs-serv3722 Modified Files: cells.lisp link.lisp md-slot-value.lisp propagate.lisp synapse.lisp Log Message: Restore rough tracking of propagation (search for *cause*) Date: Thu May 26 03:15:50 2005 Author: ktilton Index: cells/cells.lisp diff -u cells/cells.lisp:1.3 cells/cells.lisp:1.4 --- cells/cells.lisp:1.3 Wed May 18 23:47:29 2005 +++ cells/cells.lisp Thu May 26 03:15:50 2005 @@ -30,6 +30,7 @@ (define-constant *c-optimizep* t) (defparameter *c-prop-depth* 0) +(defparameter *causation* nil) (defparameter *data-pulse-id* 0) (defparameter *data-pulses* nil) @@ -88,6 +89,9 @@ (defmacro without-c-dependency (&body body) `(let (*c-calculators*) , at body)) + +(define-symbol-macro .cause + (car *causation*)) (define-condition unbound-cell (unbound-slot) ()) Index: cells/link.lisp diff -u cells/link.lisp:1.4 cells/link.lisp:1.5 --- cells/link.lisp:1.4 Sat May 21 17:13:12 2005 +++ cells/link.lisp Thu May 26 03:15:50 2005 @@ -62,7 +62,7 @@ (count-it :new-used) (incf useds-len) (setf used-pos 0) - (push user (c-users used)) + ;; 050525kt - wait till eval completes (push user (c-users used)) (push used (cd-useds user))) (let ((mapn (- *cd-usagect* @@ -104,7 +104,7 @@ (loop for useds on (cd-useds c) for used = (car useds) for mapn upfrom (- *cd-usagect* (length (cd-useds c))) - when (zerop (sbit usage mapn)) + if (zerop (sbit usage mapn)) do (c-assert (not (minusp mapn))) (c-assert (< mapn *cd-usagect*)) @@ -112,7 +112,9 @@ (trc nil "dropping unused" used :mapn-usage mapn usage) (count-it :unlink-unused) (c-unlink-user used c) - (rplaca useds nil)) + (rplaca useds nil) + else do (pushnew c (c-users used)) ;; 050525 deferred from c-link-ex + ) (setf (cd-useds c) (delete-if #'null (cd-useds c)))) (defun c-user-path-exists-p (from-used to-user) Index: cells/md-slot-value.lisp diff -u cells/md-slot-value.lisp:1.8 cells/md-slot-value.lisp:1.9 --- cells/md-slot-value.lisp:1.8 Sat May 21 17:13:12 2005 +++ cells/md-slot-value.lisp Thu May 26 03:15:50 2005 @@ -132,8 +132,10 @@ (when (eql '.kids (c-slot-name c)) (md-kids-change (c-model c) nil prior-value :makunbound)) - (with-integrity (:makunbound :makunbound c) - (c-propagate c prior-value t))))) + (let ((causation *causation*)) + (with-integrity (:makunbound :makunbound c) + (let ((*causation* causation)) + (c-propagate c prior-value t))))))) (defun (setf md-slot-value) (new-value self slot-name &aux (c (md-slot-cell self slot-name))) @@ -147,11 +149,13 @@ (c-break "(setf md-slot-value)> cellular slot ~a of ~a cannot be setf unless initialized as inputp" slot-name self)) - (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 nil)) + (let ((causation *causation*)) + (with-integrity (:setf :setf c new-value) + (let ((*causation* causation)) + (trc nil "(setf md-slot-value) calling assume" c new-value) + (md-slot-value-assume c new-value nil)) - new-value) + new-value))) Index: cells/propagate.lisp diff -u cells/propagate.lisp:1.7 cells/propagate.lisp:1.8 --- cells/propagate.lisp:1.7 Wed May 25 07:04:46 2005 +++ cells/propagate.lisp Thu May 26 03:15:50 2005 @@ -58,8 +58,10 @@ (defun c-propagate-to-users (c) (trc nil "c-propagate-to-users > queueing" c) - (with-integrity (:user-notify :user-notify c) - (progn + (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 @@ -71,7 +73,7 @@ (when (eq dead (c-model c)) (trc nil "!!! aborting further user prop of dead" dead) (return-from c-propagate-to-users)) - (trc nil "!!! continuing user prop following: user => dead" user dead)))))) + (trc nil "!!! continuing user prop following: user => dead" user dead))))))) (defun c-user-cares (c) (not (or (c-currentp c) @@ -81,15 +83,17 @@ (getf (symbol-plist slot-name) :output-defined)) (defun c-output-slot (c slot-name self new-value prior-value prior-value-supplied) - (with-integrity (:c-output-slot :output c) - (trc nil "c-output-slot > now!!" self slot-name new-value prior-value) - ;; (count-it :output slot-name) - (c-output-slot-name slot-name - self - new-value - prior-value - prior-value-supplied) - (c-ephemeral-reset c))) + (let ((causation *causation*)) ;; in case deferred + (with-integrity (:c-output-slot :output c) + (let ((*causation* causation)) + (trc nil "c-output-slot > now!!" self slot-name new-value prior-value) + ;; (count-it :output slot-name) + (c-output-slot-name slot-name + self + new-value + prior-value + prior-value-supplied) + (c-ephemeral-reset c))))) (defun c-ephemeral-reset (c) (when c Index: cells/synapse.lisp diff -u cells/synapse.lisp:1.5 cells/synapse.lisp:1.6 --- cells/synapse.lisp:1.5 Wed May 25 07:04:46 2005 +++ cells/synapse.lisp Thu May 26 03:15:50 2005 @@ -27,18 +27,20 @@ (defmacro with-synapse (synapse-id (&rest closure-vars) &body body) (declare (ignorable trcp)) - (let ((syn-id (gensym))) + (let ((syn-id (gensym))(syn-user (gensym))) `(let* ((,syn-id (eko ("!!! syn-id =") ,synapse-id)) - (synapse-user (car *c-calculators*)) - (synapse (or (bIf (ku (find ,syn-id (cd-useds synapse-user) :key 'c-slot-name)) - (progn - (trc "withsyn reusing known" ,syn-id ku) - ku)) + (,syn-user (car *c-calculators*)) + (synapse (or (find ,syn-id (cd-useds ,syn-user) :key 'c-slot-name) (let ((new-syn (let (, at closure-vars) (trc "withsyn making new syn" ,syn-id - :known (mapcar 'c-slot-name (cd-useds synapse-user))) - (make-synaptic-ruled ,syn-id synapse-user , at body)))) + :known (mapcar 'c-slot-name (cd-useds ,syn-user))) + (make-c-dependent + :model (c-model ,syn-user) + :slot-name ,syn-id + :code ',body + :synaptic t + :rule (c-lambda , at body))))) (c-link-ex new-syn) new-syn)))) (prog1 From ktilton at common-lisp.net Fri May 27 01:34:36 2005 From: ktilton at common-lisp.net (Kenny Tilton) Date: Fri, 27 May 2005 03:34:36 +0200 (CEST) Subject: [cells-cvs] CVS update: cells/cell-types.lisp cells/link.lisp cells/synapse.lisp cells/test.lisp Message-ID: <20050527013436.E20E588743@common-lisp.net> Update of /project/cells/cvsroot/cells In directory common-lisp.net:/tmp/cvs-serv26417 Modified Files: cell-types.lisp link.lisp synapse.lisp test.lisp Log Message: Remove limitation on number of dependencies one cell can have. Date: Fri May 27 03:34:35 2005 Author: ktilton Index: cells/cell-types.lisp diff -u cells/cell-types.lisp:1.5 cells/cell-types.lisp:1.6 --- cells/cell-types.lisp:1.5 Sat May 21 03:40:53 2005 +++ cells/cell-types.lisp Fri May 27 03:34:34 2005 @@ -78,8 +78,9 @@ (:conc-name cd-)) ;; chop (synapses nil :type list) (useds nil :type list) - (usage (make-array *cd-usagect* :element-type 'bit - :initial-element 0) :type vector)) + (usage (make-array 16 :element-type 'bit + :initial-element 0) :type simple-bit-vector)) + (defstruct (c-stream (:include c-dependent) Index: cells/link.lisp diff -u cells/link.lisp:1.5 cells/link.lisp:1.6 --- cells/link.lisp:1.5 Thu May 26 03:15:50 2005 +++ cells/link.lisp Fri May 27 03:34:34 2005 @@ -22,6 +22,7 @@ (in-package :cells) +#+not (eval-when (compile load) (proclaim '(optimize (speed 3) (safety 0) (space 0) (debug 0)))) @@ -54,68 +55,47 @@ when (eq used known) do (count-it :known-used) - (setf u-pos (1- length)) - finally (return (values u-pos length))) + (setf u-pos length) + finally (return (values (when u-pos (- length u-pos)) length))) (when (null used-pos) (trc nil "c-link > new user,used " user used) (count-it :new-used) - (incf useds-len) - (setf used-pos 0) + (setf used-pos useds-len) ;; 050525kt - wait till eval completes (push user (c-users used)) (push used (cd-useds user))) - (let ((mapn (- *cd-usagect* - (- useds-len used-pos)))) - ;; (trc user "c-link> setting usage bit" user mapn used) - (if (minusp mapn) - (c-break "whoa. more than ~d used by ~a? i see ~d" - *cd-usagect* user (length (cd-useds user))) - (cd-usage-set user mapn)))) + (handler-case + (setf (sbit (cd-usage user) used-pos) 1) + (type-error (error) + (declare (ignorable error)) + (setf (cd-usage user) + (adjust-array (cd-usage user) (+ used-pos 16) :initial-element 0)) + (setf (sbit (cd-usage user) used-pos) 1)))) used) -#+test -(dotimes (used 3) - (print (multiple-value-bind (p l) - (loop with u-pos - for known in '(0 2) - counting known into length - ;; do (print (list :data known length)) - when (eql used known) do (setf u-pos (1- length)) - finally (return (values u-pos length))) - (list p l)))) -#+TEST -(dotimes (n 3) - (trc "mapn" n (get-mapn n '(0 1 2)))) - -(defun get-mapn (seek map) - (declare (fixnum *cd-usagect*)) - (- *cd-usagect* - (loop with seek-pos = nil - for m in map - for pos fixnum upfrom 0 - counting m into m-len fixnum - when (eq seek m) - do (setf seek-pos pos) - finally (return (- m-len seek-pos))))) + + ;--- c-unlink-unused -------------------------------- (defun c-unlink-unused (c &aux (usage (cd-usage c))) - (loop for useds on (cd-useds c) - for used = (car useds) - for mapn upfrom (- *cd-usagect* (length (cd-useds c))) - if (zerop (sbit usage mapn)) - do - (c-assert (not (minusp mapn))) - (c-assert (< mapn *cd-usagect*)) - - (trc nil "dropping unused" used :mapn-usage mapn usage) - (count-it :unlink-unused) - (c-unlink-user used c) - (rplaca useds nil) - else do (pushnew c (c-users used)) ;; 050525 deferred from c-link-ex - ) - (setf (cd-useds c) (delete-if #'null (cd-useds c)))) + (when (cd-useds c) + (let (rev-pos) + (labels ((nail-unused (useds) + (flet ((handle-used (rpos) + (if (zerop (sbit usage rpos)) + (progn + (count-it :unlink-unused) + (c-unlink-user (car useds) c) + (rplaca useds nil)) + (pushnew c (c-users (car useds)))))) + (if (cdr useds) + (progn + (nail-unused (cdr useds)) + (handle-used (incf rev-pos))) + (handle-used (setf rev-pos 0)))))) + (nail-unused (cd-useds c)) + (setf (cd-useds c) (delete-if #'null (cd-useds c))))))) (defun c-user-path-exists-p (from-used to-user) (count-it :user-path-exists-p) @@ -126,13 +106,12 @@ ; --------------------------------------------- -(defun cd-usage-set (c mapn) - (setf (sbit (cd-usage c) mapn) 1)) (defun cd-usage-clear-all (c) - (bit-and (cd-usage c) - #*0000000000000000000000000000000000000000000000000000000000000000 - t)) + (loop with a = (cd-usage c) + for bitn below (array-dimension a 0) + do (setf (sbit a bitn) 0))) + ;--- unlink from used ---------------------- Index: cells/synapse.lisp diff -u cells/synapse.lisp:1.6 cells/synapse.lisp:1.7 --- cells/synapse.lisp:1.6 Thu May 26 03:15:50 2005 +++ cells/synapse.lisp Fri May 27 03:34:34 2005 @@ -48,13 +48,6 @@ (c-value-ensure-current synapse)) (c-link-ex synapse))))) -(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.5 cells/test.lisp:1.6 --- cells/test.lisp:1.5 Thu May 19 22:17:47 2005 +++ cells/test.lisp Fri May 27 03:34:34 2005 @@ -92,6 +92,37 @@ (print `(attempting ,',form)) (assert ,form () "Error with ~a >> ~a" ',form (list , at stuff)))) +;; test huge number of useds by one rule + +(defmodel m-index (family) + () + (:default-initargs + :md-value (c? (bwhen (ks (^kids)) + (apply '+ (mapcar 'md-value ks)))))) + +(def-cell-test many-useds + (let ((i (make-instance 'm-index))) + (loop for n below 100 + do (push (make-instance 'model + :md-value (c-in n)) + (kids i))) + (trc "index total" (md-value i)))) + +#+test +(let* ((a (make-array 16 :element-type 'bit + ;;:adjustable t + :initial-element 0)) + (asz (array-dimension a 0))) + (DESCRIBE A) + (inspect a) + (print a) + (dotimes (n 20) + (print n) + #+not (unless (< n asz) + (adjust-array a (incf asz 16) :initial-element 0)) + (setf (sbit a n) 1)) + a) + (defmodel m-null () ((aa :initform nil :cell nil :initarg :aa :accessor aa)))