Update of /project/cells/cvsroot/cells In directory common-lisp.net:/tmp/cvs-serv6620

Modified Files: build.lisp calc-n-set.lisp cell-types.lisp cells.asd cells.lisp dataflow-management.lisp debug.lisp defmodel.lisp detritus.lisp family-values.lisp family.lisp flow-control.lisp fm-utilities.lisp initialize.lisp link.lisp md-slot-value.lisp md-utilities.lisp model-object.lisp optimization.lisp propagate.lisp qells.lisp qrock.lisp slot-utilities.lisp strings.lisp strudel-object.lisp synapse.lisp Added Files: build-sys.lisp Removed Files: buildold.lisp cells-read-me.txt datetime.lisp Log Message: Preparing for first CVS of Cello Date: Tue Dec 16 10:02:59 2003 Author: ktilton

Index: cells/build.lisp diff -u cells/build.lisp:1.1.1.1 cells/build.lisp:1.2 --- cells/build.lisp:1.1.1.1 Sat Nov 8 18:43:38 2003 +++ cells/build.lisp Tue Dec 16 10:02:58 2003 @@ -1,102 +1,71 @@ -;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cl-user; -*- -;;; -;;; Copyright © 1995,2003 by Kenneth William Tilton. -;;; -;;; Permission is hereby granted, free of charge, to any person obtaining a copy -;;; of this software and associated documentation files (the "Software"), to deal -;;; in the Software without restriction, including without limitation the rights -;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell -;;; copies of the Software, and to permit persons to whom the Software is furnished -;;; to do so, subject to the following conditions: -;;; -;;; The above copyright notice and this permission notice shall be included in -;;; all copies or substantial portions of the Software. -;;; -;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING -;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS -;;; IN THE SOFTWARE. - -(defpackage #:cells-build-package - (:use #:cl)) -(in-package :cl-user) ;;#:cells-build-package) - -;;; *********************************************************************** -;;; Begin configuration section -;;; -;;; Step 1 -;;; ------ -;;; Edit the definition of *CELLS-SOURCE-DIRECTORY* so the build script -;;; knows where to find its source. For example: -;;; -;;; Unix: -;;; (defvar *cells-source-directory* #p"/usr/local/src/cells/") -;;; -;;; Windows: -;;; -;;;(defparameter *cells-source-directory* -;;; (make-pathname #+lispworks :host #-lispworks :device "C" -;;; :directory "/dev/cells")) - -;;; Validation of *cells-source-directory* -;;; -(unless (boundp '*cells-source-directory*) - (error "*CELLS-SOURCE-DIRECTORY* not supplied, please edit build.lisp to specify the location of the source.")) - -(unless (probe-file (merge-pathnames "cells.asd" *cells-source-directory*)) - (error "cells.asd not found in:~& *CELLS-SOURCE-DIRECTORY* => ~a" - *cells-source-directory*)) - -;;; Step 2 -;;; ------ -;;; Help the build script find ASDF if not already loaded -#-asdf -(load (merge-pathnames (make-pathname :name "asdf" :type "lisp") - *cells-source-directory*)) - -;;; Step 3 -;;; ------ -;;; Decide if you want to run the Cells regression test suite [optional] -(defparameter *test-cells* t) - -;;; Yer done -;;; -;;; End configuration section -;;; *********************************************************************** - - -(defparameter *cells-test-directory* - (merge-pathnames (make-pathname :directory '(:relative "cells-test")) - *cells-source-directory*)) - -;;; -;;; Implementation-specific weirdness goes here -;;; - -(let (;; Let's assume this is fixed in CMUCL 19a, and fix it later if need be. - #+cmu18 - (ext:*derive-function-types* nil) - - #+lispworks - (hcl::*handle-existing-defpackage* (list :add)) - ) - -;;; -;;; Now, build the system -;;; - - (push *cells-source-directory* asdf:*central-registry*) - (asdf:operate 'asdf:load-op :cells) - - (when *test-cells* - (push *cells-test-directory* asdf:*central-registry*) - (asdf:operate 'asdf:load-op :cells-test) - (format t "~&~%Warning on refined c-echo-slot-name is expected because") - (format t "~&cells-test is loaded. To run the test suite, evaluate:") - (format t "~&~% (cells::cv-test)") - (format t "~&~%and simply confirm it runs to completion."))) - -(delete-package '#:cells-build-package) \ No newline at end of file +;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cl-user; -*- + +(in-package :cl-user) + +;;; *********************************************************************** +;;; Begin configuration section +;;; +;;; Before building Cells, review and customize the following settings: +;;; +(let ( + ;; Step 1 + ;; ------ + ;; The path to ASDF. This is only necessary if it's not already loaded. + ;; + ;; Examples: + ;; Unix: (asdf-path (pathname "/usr/local/src/asdf.lisp")) + ;; Windows: (asdf-path (pathname "C:\dev\asdf.lisp")) + ;; Windows: (asdf-path (make-pathname :directory '(:absolute "dev") + ;; :name "asdf" :type "lisp")) + (asdf-path nil) + + ;; Step 2 + ;; ------ + ;; The path to the Cells source directory. + ;; + ;; Examples: + ;; Unix: (cells-path (pathname "/usr/local/src/cells/")) + ;; Windows: (cells-path (pathname "C:\dev\cells\")) + ;; Windows: (cells-path (make-pathname + ;; :directory '(:absolute "dev" "cells") + ;; #+lispworks :host #-lispworks :device + ;; "C")) + (cells-path nil) + + ;; Step 3 + ;; ------ + ;; Decide if you want to load and run the regression test suite. + ;; If you want to validate the system or explore the test suite, + ;; some of which is heavily annotated, set TESTP to T + (testp t) + ) + +;;; Yer done +;;; +;;; End configuration section +;;; *********************************************************************** + + + ;; Ensure ASDF is loaded + #-asdf + (progn (assert (not (null asdf-path)) + (asdf-path) + "ASDF is not loaded, and ASDF-PATH was not supplied. Please edit build.lisp") + (load asdf-path)) + + ;; Build Cells. + (load (merge-pathnames "build-sys.lisp" cells-path)) + (funcall (intern "BUILD-SYS" "CELLS-BUILD-PACKAGE") + :force t :source-directory cells-path) + + ;; Load and run the test suite, if requested. + (when testp + (funcall (intern "BUILD-SYS" "CELLS-BUILD-PACKAGE") + :force t + :source-directory (merge-pathnames + (make-pathname :directory '(:wild "cells-test")) + cells-path)) + (funcall (intern "CV-TEST" "CELLS"))) + + ;; Remove build package + (delete-package "CELLS-BUILD-PACKAGE"))

Index: cells/calc-n-set.lisp diff -u cells/calc-n-set.lisp:1.1.1.1 cells/calc-n-set.lisp:1.2 --- cells/calc-n-set.lisp:1.1.1.1 Sat Nov 8 18:43:48 2003 +++ cells/calc-n-set.lisp Tue Dec 16 10:02:58 2003 @@ -1,108 +1,103 @@ -;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- -;;; -;;; Copyright © 1995,2003 by Kenneth William Tilton. -;;; -;;; Permission is hereby granted, free of charge, to any person obtaining a copy -;;; of this software and associated documentation files (the "Software"), to deal -;;; in the Software without restriction, including without limitation the rights -;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell -;;; copies of the Software, and to permit persons to whom the Software is furnished -;;; to do so, subject to the following conditions: -;;; -;;; The above copyright notice and this permission notice shall be included in -;;; all copies or substantial portions of the Software. -;;; -;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING -;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS -;;; IN THE SOFTWARE. - -(in-package :cells) - -;____________________________ cell calculate and set ___________________ -; - -(defun c-calculate-and-set (c) - (when *stop* - (princ #.) - (return-from c-calculate-and-set)) - - (assert (not (cmdead c))) - - (when (find c *c-calculators*) ;; circularity - (if (unst-cyclic-p c) - (progn - (trc "md-slot-value cyclic defaulting" c (unst-cyclic-value c)) - (return-from c-calculate-and-set (unst-cyclic-value c))) - (progn - (setf *stop* t) - (trc "md-slot-value breaking on circularity" c *c-calculators*) - (break ;; problem when testing cells on some CLs - "cell ~a midst askers: ~a" c *c-calculators*)))) - - (count-it :c-calculate-and-set ) - ;;; (count-it :c-calculate-and-set (type-of (c-model c))) ;; (c-slot-name c)) - - ;;(with-metrics (nil nil () "calc n set" (c-slot-name c) (c-model c)) - (progn ;; wtrc (0 200 "calc n set" (c-slot-name c) (c-model c)) - (cd-usage-clear-all c) - - (let ((mycalc (incf (cr-rethinking c) 1)) - (newvalue (let ((*c-calculators* (cons c *c-calculators*)) - *synapse-factory* ;; clear, then if desired each access to potential other cell must estab. *synapse-factory* - ) - (assert (c-model c)) - #+not (when (plusp *trcdepth*) - (format t "ccalcnset> calcing ~a calcers ~a" c *c-calculators*)) - (funcall (cr-rule c) c)))) - - #+notso (assert (not (typep newvalue 'cell)) () - "new value for cell ~s is itself a cell: ~s. probably nested (c? ... (c? ))" - c newvalue) - (when (and *c-debug* (typep newvalue 'cell)) - (trc "new value for cell ~s is itself a cell: ~s. probably nested (c? ... (c? ))" - c newvalue)) - (when (< mycalc (cr-rethinking c)) - ;; - ;; means we re-entered rule and managed to compute without re-entering under new circumstances - ;; of later entry. use later calculation result.. - (trc nil "calc-n-set > breaking off, not lg" c) - ;; - (assert (c-validp c)) - (return-from c-calculate-and-set (c-value c))) - - (c-unlink-unused c) - - (md-slot-value-assume (c-model c) - (c-slot-spec c) - (c-absorb-value c newvalue))))) - -#+test -(loop for useds on '(1 2 3 4 5) - for used = (car useds) - for mapn upfrom 5 - when (oddp used) - do (print (list useds mapn))(print used)) - -(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))) - when (zerop (sbit usage mapn)) - do - (assert (not (minusp mapn))) - (assert (< mapn *cd-usagect*)) - (if (typep used 'synapse) - (progn - (setf (syn-relevant used) nil) ;; 030826synfix - ) - (progn - (trc nil "dropping unused" used :mapn-usage mapn usage) - (c-unlink-user used c) - (rplaca useds nil)))) - (setf (cd-useds c) (delete-if #'null (cd-useds c)))) - - +;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- +;;; +;;; Copyright (c) 1995,2003 by Kenneth William Tilton. +;;; +;;; Permission is hereby granted, free of charge, to any person obtaining a copy +;;; of this software and associated documentation files (the "Software"), to deal +;;; in the Software without restriction, including without limitation the rights +;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +;;; copies of the Software, and to permit persons to whom the Software is furnished +;;; to do so, subject to the following conditions: +;;; +;;; The above copyright notice and this permission notice shall be included in +;;; all copies or substantial portions of the Software. +;;; +;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS +;;; IN THE SOFTWARE. + +(in-package :cells) + +;____________________________ cell calculate and set ___________________ +; + +(defun c-calculate-and-set (c) + (when (c-stopped) + (princ #.) + (return-from c-calculate-and-set)) + + (c-assert (not (cmdead c))) + + (when (find c *c-calculators*) ;; circularity + (c-stop :c-calculate-and-set-circ-ask) + (trc "md-slot-value breaking on circularity" c *c-calculators*) + (break ;; problem when testing cells on some CLs + "cell ~a midst askers: ~a" c *c-calculators*)) + + (count-it :c-calculate-and-set ) + ;;; (count-it :c-calculate-and-set (type-of (c-model c))) ;; (c-slot-name c)) + + ;;(with-metrics (nil nil () "calc n set" (c-slot-name c) (c-model c)) + (progn ;; wtrc (0 200 "calc n set" (c-slot-name c) (c-model c)) + (cd-usage-clear-all c) + + (let ((mycalc (incf (cr-rethinking c) 1)) + (newvalue (let ((*c-calculators* (cons c *c-calculators*)) + *synapse-factory* ;; clear, then if desired each access to potential other cell must estab. *synapse-factory* + ) + (c-assert (c-model c)) + #+not (when (plusp *trcdepth*) + (format t "ccalcnset> calcing ~a calcers ~a" c *c-calculators*)) + (funcall (cr-rule c) c)))) + + #+notso (c-assert (not (typep newvalue 'cell)) () + "new value for cell ~s is itself a cell: ~s. probably nested (c? ... (c? ))" + c newvalue) + (when (and *c-debug* (typep newvalue 'cell)) + (trc "new value for cell ~s is itself a cell: ~s. probably nested (c? ... (c? ))" + c newvalue)) + (when (< mycalc (cr-rethinking c)) + ;; + ;; means we re-entered rule and managed to compute without re-entering under new circumstances + ;; of later entry. use later calculation result.. + (trc nil "calc-n-set > breaking off, not lg" c) + ;; + (c-assert (c-validp c)) + (return-from c-calculate-and-set (c-value c))) + + (c-unlink-unused c) + + (md-slot-value-assume (c-model c) + (c-slot-spec c) + (c-absorb-value c newvalue))))) + +#+test +(loop for useds on '(1 2 3 4 5) + for used = (car useds) + for mapn upfrom 5 + when (oddp used) + do (print (list useds mapn))(print used)) + +(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))) + when (zerop (sbit usage mapn)) + do + (c-assert (not (minusp mapn))) + (c-assert (< mapn *cd-usagect*)) + (if (typep used 'synapse) + (progn + (setf (syn-relevant used) nil) ;; 030826synfix + ) + (progn + (trc nil "dropping unused" used :mapn-usage mapn usage) + (c-unlink-user used c) + (rplaca useds nil)))) + (setf (cd-useds c) (delete-if #'null (cd-useds c)))) + +

Index: cells/cell-types.lisp diff -u cells/cell-types.lisp:1.1.1.1 cells/cell-types.lisp:1.2 --- cells/cell-types.lisp:1.1.1.1 Sat Nov 8 18:43:48 2003 +++ cells/cell-types.lisp Tue Dec 16 10:02:58 2003 @@ -1,293 +1,257 @@ -;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- -;;; -;;; Copyright © 1995,2003 by Kenneth William Tilton. -;;; -;;; Permission is hereby granted, free of charge, to any person obtaining a copy -;;; of this software and associated documentation files (the "Software"), to deal -;;; in the Software without restriction, including without limitation the rights -;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell -;;; copies of the Software, and to permit persons to whom the Software is furnished -;;; to do so, subject to the following conditions: -;;; -;;; The above copyright notice and this permission notice shall be included in -;;; all copies or substantial portions of the Software. -;;; -;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING -;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS -;;; IN THE SOFTWARE. - -(in-package :cells) - -(defun slot-spec-name (slot-spec) - slot-spec) - -(cc-defstruct (cell (:conc-name c-)) - waking-state - model - slot-spec - value - ) - -(defun c-slot-name (c) - (slot-spec-name (c-slot-spec c))) - -(defun c-validate (self c) - (when (not (and (c-slot-spec c) (c-model c))) -;;; (setf *stop* t) - (format t "~&unadopted cell: ~s md:~s, awake:~s" c self (c-waking-state self)) - (error 'c-unadopted :cell c))) - -(defmethod c-when (other) - (declare (ignorable other)) nil) ;; /// needs work - -(cc-defstruct (synapse - (:include cell) - (:conc-name syn-)) - user - used - (relevant t) ;; not if unused during subsequent eval. but keep to preserve likely state - fire-p - relay-value) - -(defmacro mksynapse ((&rest closeovervars) &key trcp fire-p relay-value) - (let ((used (copy-symbol 'used)) (user (copy-symbol 'user))) - `(lambda (,used ,user) - ,(when trcp - `(trc "making synapse between user" ',trcp ,user :and :used ,used)) - (let (,@closeovervars) - (make-synapse - :used ,used - ;;; 210207kt why? use (c-model (syn-used <syn>)) :c-model (c-model ,used) - :user ,user - :fire-p ,fire-p - :relay-value ,relay-value))))) - -(defmethod print-object ((syn synapse) stream) - (format stream "{syn ~s ==> ~s" (syn-used syn) (syn-user syn))) - - -(defmethod c-true-stalep ((syn synapse)) - (cd-stale-p (syn-user syn))) - -(cc-defstruct (c-user-notifying - (:include cell) - (:conc-name un-)) - (users nil :type list)) - -(cc-defstruct (c-unsteady - (:include c-user-notifying) - (:conc-name unst-)) - cyclic-p - cyclic-value - delta-p - setting-p) - -(cc-defstruct (c-variable - (:include c-unsteady))) - -(cc-defstruct (c-ruled - (:include c-unsteady) - (:conc-name cr-)) - (state :unbound :type symbol) - (rethinking 0 :type number) - lazy - rule) - -(defmethod c-lazy-p ((c c-ruled)) (cr-lazy c)) -(defmethod c-lazy-p (c) (declare (ignore c)) nil) - -(defun c-optimized-away-p (c) - (eql :optimized-away (c-state c))) - -;---------------------------- - - -(defmethod c-true-stalep (c) - (declare (ignore c))) - -(cc-defstruct (c-independent - ;; - ;; these do not optimize away, because also these can be set after initial evaluation of the rule, - ;; so users better stay tuned. - ;; the whole idea here is that the old idea of having cv bodies evaluated immediately finally - ;; broke down when we wanted to say :kids (cv (list (fm-other vertex))) - ;; - (:include c-ruled))) - -(defmethod trcp-slot (self slot-name) - (declare (ignore self slot-name))) - -(defconstant *cd-usagect* 64) - -(cc-defstruct (c-dependent - (:include c-ruled) - (:conc-name cd-)) - (useds nil :type list) - (code nil :type list) ;; /// feature this out on production build - (usage (make-array *cd-usagect* :element-type 'bit - :initial-element 0) :type vector) - stale-p - ) - -;;;(defmethod trcp ((c c-dependent)) -;;; (or (trcp-slot (c-model c) (c-slot-name c)) -;;; ;;(c-lazy-p c) -;;; nil)) - -(defmethod c-true-stalep ((c c-dependent)) - (cd-stale-p c)) - -(cc-defstruct (c-stream - (:include c-ruled) - (:conc-name cs-)) - values) - -;;; (defmacro cell~ (&body body) -;;; `(make-c-stream -;;; :rule (lambda ,@*c-lambda* -;;; ,@body))) - -(cc-defstruct (c-drifter - (:include c-dependent))) - -(cc-defstruct (c-drifter-absolute - (:include c-drifter))) - -;_____________________ accessors __________________________________ - - -(defun (setf c-state) (new-value c) - (if (typep c 'c-ruled) - (setf (cr-state c) new-value) - new-value)) - -(defun c-state (c) - (if (typep c 'c-ruled) - (cr-state c) - :valid)) - -(defun c-unboundp (c) - (eql :unbound (c-state c))) - -(defun c-validp (c) - (find (c-state c) '(:valid :optimized-away))) - -;_____________________ print __________________________________ - -(defmethod print-object :before ((c c-variable) stream) - (declare (ignorable c)) - (format stream "[var:")) - -(defmethod print-object :before ((c c-dependent) stream) - (declare (ignorable c)) - (format stream "[dep~a:" (cond - ((null (c-model c)) #\0) - ((eq :eternal-rest (md-state (c-model c))) #_) - ((cd-stale-p c) ##) - ((sw-pending c) #?) - (t #\space)))) - -(defmethod print-object :before ((c c-independent) stream) - (declare (ignorable c)) - (format stream "[ind:")) - -(defmethod print-object ((c cell) stream) - (c-print-value c stream) - (format stream "=~a/~a]" - (symbol-name (or (c-slot-name c) :anoncell)) - (or (c-model c) :anonmd)) -;;; #+dfdbg (unless *stop* -;;; (assert (find c (cells (c-model c)) :key #'cdr))) - ) - -;__________________ - -(defmethod c-print-value ((c c-ruled) stream) - (format stream "~a" (cond ((unst-setting-p c) "<^^^>") - ((c-validp c) "<vld>") - ((c-unboundp c) "<unb>") - ((cd-stale-p c) "<obs>") - (t "<err>")))) - -(defmethod c-print-value (c stream) - (declare (ignore c stream))) - -;____________________ constructors _______________________________ - -(defmacro c-lambda (&body body) - (let ((c (gensym))) - `(lambda (,c &aux (self (c-model ,c)) - (.cache (c-value ,c))) - (declare (ignorable .cache self)) - (assert (not (cmdead ,c))() "cell dead entering rule ~a" ,c) - ,@body))) - -(defmacro c? (&body body) - `(make-c-dependent - :code ',body - :rule (c-lambda ,@body))) - -(defmacro c?_ (&body body) - `(make-c-dependent - :code ',body - :lazy t - :rule (c-lambda ,@body))) - -(defmacro c?? ((&key (tagp nil) (in nil) (trigger nil) (out t))&body body) - (let ((result (copy-symbol 'result)) - (thetag (gensym))) - `(make-c-dependent - :code ',body - :rule (c-lambda - (let ((,thetag (gensym "tag")) - (*trcdepth* (1+ *trcdepth*)) - ) - (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 ,@body))) - ,(when out `(trc "c?? result:" ,result (c-slot-name c) (when ,tagp ,thetag))) - ,result)))))) - -(defmacro cv (defn) - `(make-c-variable - :value ,defn)) ;; use c-independent if need deferred execution - -(defmacro cv8 (defn) - `(make-c-variable - :cyclic-p t - :value ,defn)) ;; use c-independent if need deferred execution - -(defmacro c... ((value) &body body) - `(make-c-drifter - :code ',body - :value ,value - :rule (c-lambda ,@body))) - -(defmacro c-abs (value &body body) - `(make-c-drifter-absolute - :code ',body - :value ,value - :rule (lambda (c &aux (self (c-model c))) - (declare (ignorable self c)) - ,@body))) - - -(defmacro c-envalue (&body body) - `(make-c-envaluer - :envaluerule (lambda (self) - (declare (ignorable self)) - ,@body))) - -(defmacro c8 ((&optional cyclic-value) &body body) - `(make-c-dependent - :code ',body - :cyclic-p t - :cyclic-value ,cyclic-value - :rule (c-lambda ,@body))) +;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- +;;; +;;; Copyright (c) 1995,2003 by Kenneth William Tilton. +;;; +;;; Permission is hereby granted, free of charge, to any person obtaining a copy +;;; of this software and associated documentation files (the "Software"), to deal +;;; in the Software without restriction, including without limitation the rights +;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +;;; copies of the Software, and to permit persons to whom the Software is furnished +;;; to do so, subject to the following conditions: +;;; +;;; The above copyright notice and this permission notice shall be included in +;;; all copies or substantial portions of the Software. +;;; +;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS +;;; IN THE SOFTWARE. + +(in-package :cells) + +(defun slot-spec-name (slot-spec) + slot-spec) + + +(defstruct (cell (:conc-name c-)) + waking-state + model + slot-spec + value + (users nil :type list)) + +(defun test () + (let (x) + (makunbound x) + x)) + +(defun c-slot-name (c) + (slot-spec-name (c-slot-spec c))) + +(defun c-validate (self c) + (when (not (and (c-slot-spec c) (c-model c))) + (format t "~&unadopted cell: ~s md:~s, awake:~s" c self (c-waking-state self)) + (c-break "unadopted cell ~a ~a" self c) + (error 'c-unadopted :cell c))) + +(defmethod c-when (other) + (declare (ignorable other)) nil) ;; /// needs work + +(defstruct (synapse + (:conc-name syn-)) + user + used + (relevant t) ;; not if unused during subsequent eval. but keep to preserve any state + fire-p + relay-value) + +(defmacro mksynapse ((&rest closeovervars) &key trcp fire-p relay-value) + (let ((used (copy-symbol 'used)) (user (copy-symbol 'user))) + `(lambda (,used ,user) + ,(when trcp + `(trc "making synapse between user" ',trcp ,user :and :used ,used)) + (let (,@closeovervars) + (make-synapse + :used ,used + :user ,user + :fire-p ,fire-p + :relay-value ,relay-value))))) + +(defmethod print-object ((syn synapse) stream) + (format stream "{syn ~s ==> ~s" (syn-used syn) (syn-user syn))) + +(defmethod c-true-stalep ((syn synapse)) + (cd-stale-p (syn-user syn))) + +(defstruct (c-variable + (:include cell) + (:conc-name cv-)) + cyclic-p + setting-p) + +(defstruct (c-ruled + (:include cell) + (:conc-name cr-)) + (state :unbound :type symbol) + (rethinking 0 :type number) + lazy + rule) + +(defmethod c-lazy-p ((c c-ruled)) (cr-lazy c)) +(defmethod c-lazy-p (c) (declare (ignore c)) nil) + +(defun c-optimized-away-p (c) + (eql :optimized-away (c-state c))) + +;---------------------------- + +(defmethod c-true-stalep (c) + (declare (ignore c))) + +(defmethod trcp-slot (self slot-name) + (declare (ignore self slot-name))) + +(defconstant *cd-usagect* 64) + +(defstruct (c-dependent + (:include c-ruled) + (:conc-name cd-)) + (useds nil :type list) + (code nil :type list) ;; /// feature this out on production build + (usage (make-array *cd-usagect* :element-type 'bit + :initial-element 0) :type vector) + stale-p + ) + +;;;(defmethod trcp ((c c-dependent)) +;;; (or (trcp-slot (c-model c) (c-slot-name c)) +;;; ;;(c-lazy-p c) +;;; nil)) + +(defmethod c-true-stalep ((c c-dependent)) + (cd-stale-p c)) + +(defstruct (c-stream + (:include c-ruled) + (:conc-name cs-)) + values) + +;;; (defmacro cell~ (&body body) +;;; `(make-c-stream +;;; :rule (lambda ,@*c-lambda* +;;; ,@body))) + +(defstruct (c-drifter + (:include c-dependent))) + +(defstruct (c-drifter-absolute + (:include c-drifter))) + +;_____________________ accessors __________________________________ + + +(defun (setf c-state) (new-value c) + (if (typep c 'c-ruled) + (setf (cr-state c) new-value) + new-value)) + +(defun c-state (c) + (if (typep c 'c-ruled) + (cr-state c) + :valid)) + +(defun c-unboundp (c) + (eql :unbound (c-state c))) + +(defun c-validp (c) + (find (c-state c) '(:valid :optimized-away))) + +;_____________________ print __________________________________ + +(defmethod print-object :before ((c c-variable) stream) + (declare (ignorable c)) + (format stream "[var:")) + +(defmethod print-object :before ((c c-dependent) stream) + (declare (ignorable c)) + (format stream "[dep~a:" (cond + ((null (c-model c)) #\0) + ((eq :eternal-rest (md-state (c-model c))) #_) + ((cd-stale-p c) ##) + ((sw-pending c) #?) + (t #\space)))) + +(defmethod print-object ((c cell) stream) + (c-print-value c stream) + (format stream "=~a/~a]" + (symbol-name (or (c-slot-name c) :anoncell)) + (or (c-model c) :anonmd))) + +;__________________ + +(defmethod c-print-value ((c c-ruled) stream) + (format stream "~a" (cond ((c-validp c) "<vld>") + ((c-unboundp c) "<unb>") + ((cd-stale-p c) "<obs>") + (t "<err>")))) + +(defmethod c-print-value (c stream) + (declare (ignore c stream))) + +;____________________ constructors _______________________________ + +(defmacro c-lambda (&body body) + (let ((c (gensym))) + `(lambda (,c &aux (self (c-model ,c)) + (.cache (c-value ,c))) + (declare (ignorable .cache self)) + (c-assert (not (cmdead ,c)) "cell dead entering rule ~a" ,c) + ,@body))) + +(defmacro c? (&body body) + `(make-c-dependent + :code ',body + :rule (c-lambda ,@body))) + +(defmacro c?_ (&body body) + `(make-c-dependent + :code ',body + :lazy t + :rule (c-lambda ,@body))) + +(defmacro c?? ((&key (tagp nil) (in nil) (trigger nil) (out t))&body body) + (let ((result (copy-symbol 'result)) + (thetag (gensym))) + `(make-c-dependent + :code ',body + :rule (c-lambda + (let ((,thetag (gensym "tag")) + (*trcdepth* (1+ *trcdepth*)) + ) + (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 ,@body))) + ,(when out `(trc "c?? result:" ,result (c-slot-name c) (when ,tagp ,thetag))) + ,result)))))) + +(defmacro cv (defn) + `(make-c-variable + :value ,defn)) + +(defmacro cv8 (defn) + `(make-c-variable + :cyclic-p t + :value ,defn)) + +(defmacro c... ((value) &body body) + `(make-c-drifter + :code ',body + :value ,value + :rule (c-lambda ,@body))) + +(defmacro c-abs (value &body body) + `(make-c-drifter-absolute + :code ',body + :value ,value + :rule (c-lambda ,@body))) + + +(defmacro c-envalue (&body body) + `(make-c-envaluer + :envaluerule (c-lambda ,@body)))

Index: cells/cells.asd diff -u cells/cells.asd:1.1.1.1 cells/cells.asd:1.2 --- cells/cells.asd:1.1.1.1 Sat Nov 8 18:43:48 2003 +++ cells/cells.asd Tue Dec 16 10:02:58 2003 @@ -1,36 +1,36 @@ -;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- - -(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) - -#+(or allegro lispworks cmu mcl cormanlisp sbcl scl) - -(asdf:defsystem :cells - :name "cells" - :author "Kenny Tilton ktilton@nyc.rr.com" - :version "05-Nov-2003" - :maintainer "Kenny Tilton ktilton@nyc.rr.com" - :licence "MIT Style" - :description "Cells" - :long-description "The Cells dataflow extension to CLOS." - :components - ((:file "cells") - (:file "flow-control" :depends-on ("cells")) - (:file "strings" :depends-on ("flow-control")) - (:file "detritus" :depends-on ("flow-control")) - (:file "cell-types" :depends-on ("cells")) - (:file "debug" :depends-on ("cells")) - (:file "initialize" :depends-on ("debug")) - (:file "dataflow-management" :depends-on ("debug")) - (:file "md-slot-value" :depends-on ("debug")) - (:file "calc-n-set" :depends-on ("debug")) - (:file "slot-utilities" :depends-on ("debug")) - (:file "optimization" :depends-on ("debug")) - (:file "link" :depends-on ("debug")) - (:file "propagate" :depends-on ("debug")) - (:file "synapse" :depends-on ("debug" "cell-types")) - (:file "model-object" :depends-on ("debug")) - (:file "defmodel" :depends-on ("model-object")) - (:file "md-utilities" :depends-on ("defmodel")) - (:file "family" :depends-on ("propagate" "model-object" "defmodel")) - (:file "fm-utilities" :depends-on ("family")) - (:file "family-values" :depends-on ("fm-utilities")))) +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- + +(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) + +#+(or allegro lispworks cmu mcl clisp cormanlisp sbcl scl) + +(asdf:defsystem :cells + :name "cells" + :author "Kenny Tilton ktilton@nyc.rr.com" + :version "05-Nov-2003" + :maintainer "Kenny Tilton ktilton@nyc.rr.com" + :licence "MIT Style" + :description "Cells" + :long-description "The Cells dataflow extension to CLOS." + :components + ((:file "cells") + (:file "flow-control" :depends-on ("cells")) + (:file "strings" :depends-on ("flow-control")) + (:file "detritus" :depends-on ("flow-control")) + (:file "cell-types" :depends-on ("cells")) + (:file "debug" :depends-on ("cells")) + (:file "initialize" :depends-on ("debug")) + (:file "dataflow-management" :depends-on ("debug")) + (:file "md-slot-value" :depends-on ("debug")) + (:file "calc-n-set" :depends-on ("debug")) + (:file "slot-utilities" :depends-on ("debug")) + (:file "optimization" :depends-on ("debug")) + (:file "link" :depends-on ("debug")) + (:file "propagate" :depends-on ("debug")) + (:file "synapse" :depends-on ("debug" "cell-types")) + (:file "model-object" :depends-on ("debug")) + (:file "defmodel" :depends-on ("model-object")) + (:file "md-utilities" :depends-on ("defmodel")) + (:file "family" :depends-on ("propagate" "model-object" "defmodel")) + (:file "fm-utilities" :depends-on ("family")) + (:file "family-values" :depends-on ("fm-utilities"))))

Index: cells/cells.lisp diff -u cells/cells.lisp:1.2 cells/cells.lisp:1.3 --- cells/cells.lisp:1.2 Thu Nov 13 00:54:53 2003 +++ cells/cells.lisp Tue Dec 16 10:02:58 2003 @@ -1,111 +1,128 @@ -;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- -;;; -;;; Copyright © 1995,2003 by Kenneth William Tilton. -;;; -;;; Permission is hereby granted, free of charge, to any person obtaining a copy -;;; of this software and associated documentation files (the "Software"), to deal -;;; in the Software without restriction, including without limitation the rights -;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell -;;; copies of the Software, and to permit persons to whom the Software is furnished -;;; to do so, subject to the following conditions: -;;; -;;; The above copyright notice and this permission notice shall be included in -;;; all copies or substantial portions of the Software. -;;; -;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING -;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS -;;; IN THE SOFTWARE. - -(eval-when (compile load) - (proclaim '(optimize (speed 2) (safety 1) (space 1) (debug 3)))) - -(defpackage :cells - (:use "COMMON-LISP" - #+allegro "EXCL" - #-(or cormanlisp cmu sbcl) "CLOS" - #+sbcl "SB-MOP" - #+mcl "CCL" - ) - #+clisp (:import-from #:clos "CLASS-SLOTS" "CLASS-PRECEDENCE-LIST") - #+cmu (:import-from "PCL" "CLASS-PRECEDENCE-LIST" "CLASS-SLOTS" - "SLOT-DEFINITION-NAME") - (:export "CELL" "CV" "C?" "C?_" "C??" "WITHOUT-C-DEPENDENCY" "SELF" "*SYNAPSE-FACTORY*" - ".CACHE" "C-LAMBDA" ".CAUSE" - "DEFMODEL" "CELLBRK" "C-AWAKEN" "DEF-C-ECHO" "DEF-C-UNCHANGED-TEST" - "NEW-VALUE" "OLD-VALUE" "C..." - "MKPART" "THEKIDS" "NSIB" "MDVALUE" "^MDVALUE" ".MDVALUE" "KIDS" "^KIDS" ".KIDS" - "CELL-RESET" "UPPER" "FM-MAX" "NEAREST" "^FM-MIN-KID" "^FM-MAX-KID" "MK-KID-SLOT" - "DEF-KID-SLOTS" "FIND-PRIOR" "FM-POS" "KIDNO" "FM-INCLUDES" "FM-ASCENDANT-COMMON" - "FM-KID-CONTAINING" "FM-FIND-IF" "FM-ASCENDANT-IF" "C-ABS" "FM-COLLECT-IF" "CV8" "PSIB" - "TO-BE" "NOT-TO-BE" "SSIBNO" "MD-AWAKEN" - #:delta-diff - ) - #+allegro (:shadowing-import-from #:excl #:fasl-write #:fasl-read #:gc) - ) - -(in-package :cells) - -(defconstant *c-optimizep* t) -(defvar *c-prop-depth* 0) -(defvar *cause* nil) -(defvar *rethink-deferred* nil) -(defvar *synapse-factory* nil) -(defvar *sw-looping* nil) -(defparameter *to-be-awakened* nil) -(defvar *trcdepth* 0) - -(defparameter *c-debug* - #+runtime-system nil - #-runtime-system t) - -(defvar *stop* nil) - -(defun stop () - (setf *stop* t)) - -(defvar *c-calculators* nil) - -(defmacro ssibno () `(position self (^kids .parent))) - -(defmacro gpar () - `(fm-grandparent self)) - -(defmacro nearest (selfform type) - (let ((self (gensym))) - `(bwhen (,self ,selfform) - (if (typep ,self ',type) ,self (upper ,self ,type))))) - -(defmacro def-c-trace (model-type &optional slot cell-type) - `(defmethod trcp ((self ,(case cell-type - (:c? 'c-dependent) - (otherwise 'cell)))) - (and (typep (c-model self) ',model-type) - ,(if slot - `(eq (c-slot-name self) ',slot) - `t)))) - -(defmacro with-dataflow-management ((c-originating) &body body) - (let ((fn (gensym))) - `(let ((,fn (lambda () ,@body))) - (declare (dynamic-extent ,fn)) - (call-with-dataflow-management ,c-originating ,fn)))) - -(defmacro without-c-dependency (&body body) - `(let (*c-calculators*) ,@body)) - -(defmacro without-propagating ((slotname objxpr) &body body) - (let ((c (gensym)) - (c-delta (gensym))) - `(let ((,c (slot-value ,objxpr ',slotname))) - (push (cons ,c nil) *c-noprop*) - (progn ,@body) - (let ((,c-delta (assoc ,c *c-noprop*))) - (assert ,c-delta) - (setf *c-noprop* (delete ,c-delta *c-noprop*)) - (when (cdr ,c-delta) ;; if changed, will be set to /list/ containing priorvalue - (,c (cadr ,c-delta) (caddr ,c-delta))))))) - +;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- +;;; +;;; Copyright (c) 1995,2003 by Kenneth William Tilton. +;;; +;;; Permission is hereby granted, free of charge, to any person obtaining a copy +;;; of this software and associated documentation files (the "Software"), to deal +;;; in the Software without restriction, including without limitation the rights +;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +;;; copies of the Software, and to permit persons to whom the Software is furnished +;;; to do so, subject to the following conditions: +;;; +;;; The above copyright notice and this permission notice shall be included in +;;; all copies or substantial portions of the Software. +;;; +;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS +;;; IN THE SOFTWARE. + +(eval-when (compile load) + (proclaim '(optimize (speed 2) (safety 3) (space 1) (debug 3)))) + +(defpackage :cells + (:use "COMMON-LISP" + #+allegro "EXCL" + #-(or cormanlisp cmu sbcl) "CLOS" + #+sbcl "SB-MOP" + #+mcl "CCL" + ) + #+clisp (:import-from #:clos "CLASS-SLOTS" "CLASS-PRECEDENCE-LIST") + #+cmu (:import-from "PCL" "CLASS-PRECEDENCE-LIST" "CLASS-SLOTS" + "SLOT-DEFINITION-NAME" "TRUE") + (:export "CELL" "CV" "C?" "C?_" "C??" "WITHOUT-C-DEPENDENCY" "SELF" "*SYNAPSE-FACTORY*" + ".CACHE" "C-LAMBDA" ".CAUSE" + "DEFMODEL" "CELLBRK" "C-AWAKEN" "DEF-C-ECHO" "DEF-C-UNCHANGED-TEST" + "NEW-VALUE" "OLD-VALUE" "C..." + "MKPART" "THEKIDS" "NSIB" "MD-VALUE" "^MD-VALUE" ".MD-VALUE" "KIDS" "^KIDS" ".KIDS" + "CELL-RESET" "UPPER" "FM-MAX" "NEAREST" "^FM-MIN-KID" "^FM-MAX-KID" "MK-KID-SLOT" + "DEF-KID-SLOTS" "FIND-PRIOR" "FM-POS" "KID-NO" "FM-INCLUDES" "FM-ASCENDANT-COMMON" + "FM-KID-CONTAINING" "FM-FIND-IF" "FM-ASCENDANT-IF" "C-ABS" "FM-COLLECT-IF" "CV8" "PSIB" + "TO-BE" "NOT-TO-BE" "SSIBNO" "MD-AWAKEN" + "C-BREAK" "C-ASSERT" "C-STOP" "C-STOPPED" "C-ASSERT" + #:delta-diff + ) + #+allegro (:shadowing-import-from #:excl #:fasl-write #:fasl-read #:gc) + ) + +(in-package :cells) + +(defconstant *c-optimizep* t) +(defvar *c-prop-depth* 0) +(defvar *cause* nil) +(defvar *rethink-deferred* nil) +(defvar *synapse-factory* nil) +(defvar *sw-looping* nil) +(defparameter *to-be-awakened* nil) +(defvar *trcdepth* 0) + +(defparameter *c-debug* + #+runtime-system nil + #-runtime-system t) + +(defvar *stop* nil) + +(defun c-stop (why) + (format t "~&C-STOP> stopping because ~a" why) + (setf *stop* t)) + +(defun c-stopped () + *stop*) + +(defmacro c-assert (assertion &optional places fmt$ &rest fmtargs) + (declare (ignore places)) + + `(unless *stop* + (unless ,assertion + (setf *stop* t) + ,(if fmt$ + `(c-break ,fmt$ ,@fmtargs) + `(c-break "failed assertion:" ',assertion))))) + +(defvar *c-calculators* nil) + +(defmacro ssibno () `(position self (^kids .parent))) + +(defmacro gpar () + `(fm-grandparent self)) + +(defmacro nearest (selfform type) + (let ((self (gensym))) + `(bwhen (,self ,selfform) + (if (typep ,self ',type) ,self (upper ,self ,type))))) + +(defmacro def-c-trace (model-type &optional slot cell-type) + `(defmethod trcp ((self ,(case cell-type + (:c? 'c-dependent) + (otherwise 'cell)))) + (and (typep (c-model self) ',model-type) + ,(if slot + `(eq (c-slot-name self) ',slot) + `t)))) + +(defmacro with-dataflow-management ((c-originating) &body body) + (let ((fn (gensym))) + `(let ((,fn (lambda () ,@body))) + (declare (dynamic-extent ,fn)) + (call-with-dataflow-management ,c-originating ,fn)))) + +(defmacro without-c-dependency (&body body) + `(let (*c-calculators*) ,@body)) + +(defmacro without-propagating ((slotname objxpr) &body body) + (let ((c (gensym)) + (c-delta (gensym))) + `(let ((,c (slot-value ,objxpr ',slotname))) + (push (cons ,c nil) *c-noprop*) + (progn ,@body) + (let ((,c-delta (assoc ,c *c-noprop*))) + (c-assert ,c-delta) + (setf *c-noprop* (delete ,c-delta *c-noprop*)) + (when (cdr ,c-delta) ;; if changed, will be set to /list/ containing priorvalue + (,c (cadr ,c-delta) (caddr ,c-delta))))))) + +(define-symbol-macro .cause + *cause*)

Index: cells/dataflow-management.lisp diff -u cells/dataflow-management.lisp:1.1.1.1 cells/dataflow-management.lisp:1.2 --- cells/dataflow-management.lisp:1.1.1.1 Sat Nov 8 18:44:00 2003 +++ cells/dataflow-management.lisp Tue Dec 16 10:02:58 2003 @@ -1,223 +1,229 @@ -;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- -;;; -;;; Copyright © 1995,2003 by Kenneth William Tilton. -;;; -;;; Permission is hereby granted, free of charge, to any person obtaining a copy -;;; of this software and associated documentation files (the "Software"), to deal -;;; in the Software without restriction, including without limitation the rights -;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell -;;; copies of the Software, and to permit persons to whom the Software is furnished -;;; to do so, subject to the following conditions: -;;; -;;; The above copyright notice and this permission notice shall be included in -;;; all copies or substantial portions of the Software. -;;; -;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING -;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS -;;; IN THE SOFTWARE. - -(in-package :cells) - -(defparameter *df-interference-detection* t) - -(eval-when (compile eval load) - (export '(*df-interference-detection*))) - -(defmethod sw-detect-interference (user trigger) - (declare (ignorable trigger)) - (when #+runtime-system t #-runtime-system *df-interference-detection* - (trc nil "detect entry" user (cd-useds user)) - (dolist (used (cd-useds user)) - (do ((deep-stale (cd-deep-stale used)(cd-deep-stale used))) - ((null deep-stale)) - ;;(trc nil "sw-detect-interference trying deep stale" deep-stale) - (c-rethink deep-stale) - (cond - ((c-true-stalep deep-stale) - (trc "!! true deep stalep: user>" user) - (trc "!! true deep stalep: used>" used) - (trc "!! true deep stalep: deepstale>" deep-stale) - (return-from sw-detect-interference deep-stale #+debugging (list user used deep-stale))) - - ((not (c-true-stalep user)) - (return-from sw-detect-interference nil))))))) - -(defmethod sw-detect-interference ((user c-variable) trigger) - (declare (ignore trigger))) - -(defmethod sw-detect-interference ((user synapse) trigger) - (sw-detect-interference (syn-used user) trigger)) - -(defmethod cd-deep-stale ((c c-dependent)) - (trc nil "cd-deep-stale entry" c) - (if (cd-stale-p c) - c ;; (eko ("deep stalep bingo !!!!!!") c) - (some #'cd-deep-stale (cd-useds c)))) - -(defmethod cd-deep-stale ((syn synapse)) - (cd-deep-stale (syn-used syn))) - -(defmethod cd-deep-stale (c) - (declare (ignore c))) - -(defparameter *sw-pending* nil) -(defparameter *dataflowing* nil) - -(defun dump-pending () - (dotimes (x (length *sw-pending*)) - (let ((p (nth x *sw-pending*))) - (destructuring-bind (heldup . holdup) p - (declare (ignorable holdup)) - (trc heldup " pending!!!!!!!!!!" p) - ))) - ) - -;; mo better diags: holdup (c-true-stalep holdup) heldup (c-true-stalep heldup)))))) - -(defun call-with-dataflow-management (c-originating bodyfn) - (declare (ignorable c-originating)) - (if *dataflowing* - (funcall bodyfn) - (let ((*dataflowing* t) - *sw-pending*) - #+dfdbg (trc nil ">>>>> with-dataflow-management: 001" c-originating) - (setf (unst-setting-p c-originating) t) - (prog1 - (funcall bodyfn) - - (while (and *sw-pending* - (not *sw-looping*)) - - #+dfdbg - (progn - (trc nil "we have pending!!!!!!!!!!" (length *sw-pending*)) - (dump-pending)) - - (let ((pct (length *sw-pending*)) - (oldpending (copy-list *sw-pending*))) - ;;(trace c-rethink) - (labels ((do-last (pending) - (when pending - (do-last (cdr pending)) - ;;(trace c-rethink cd-deep-stale sw-detect-interference) - (destructuring-bind (heldup . holdup) (car pending) - (trc heldup "pending sweep sees held up" heldup :holdup holdup) - (assert (find heldup (cells (c-model heldup)) :key #'cdr)) - (assert (find holdup (cells (c-model holdup)) :key #'cdr)) - ;; (unless (c-true-stalep holdup) - ;; (trc nil "dataflow sees freed blocker" holdup)) - (if (c-true-stalep holdup) - (if (eq :eternal-rest (md-state (c-model holdup))) - (progn (trc "holdup is no more!!!!!!!" holdup (c-true-stalep heldup) heldup)) - (progn - (trc holdup "dataflow retrying blocker" holdup) - (c-rethink holdup))) - (progn - (trc heldup "holdup not stale!!!" holdup :heldup> heldup) - (c-pending-set heldup nil :holdup-unstale) )) - ;;(unless (c-true-stalep heldup) - ;; (trc nil "dataflow sees freed blocked" heldup)) - (when (c-true-stalep heldup) - (trc heldup "dataflow retrying blocked" heldup) - (c-rethink heldup)))))) - ;; (trace c-rethink cd-deep-stale sw-detect-interference) - (do-last *sw-pending*) - ;; (trc "post sweep pending leftovers:" (length *sw-pending*)) - ;; (untrace c-rethink cd-deep-stale sw-detect-interference) - ) - ;;(untrace c-rethink) - (when (and (equal oldpending *sw-pending*) - (eql pct (length *sw-pending*)) - (not *sw-looping*)) - (setf *sw-looping* t) - #+nah (dolist (p *sw-pending*) - (destructuring-bind (heldup . holdup) p - (dump-dependency-path holdup heldup))) - #+nah (dolist (p *sw-pending*) - (destructuring-bind (heldup . holdup) p - (declare (ignorable heldup)) - (when t ;; (trcp holdup) - (dump-stale-path holdup)))) - (break "trigger ~a stuck; cant lose pendings ~a" - c-originating - *sw-pending*)) - - ;; (trc "after sweep sw-pending" *sw-pending*) - ;; (cellbrk) - (when c-originating - (setf (unst-setting-p c-originating) nil)))) - (trc nil "<<<< with-dataflow-management:" c-originating))))) - -(defun dump-stale-path (used) - (assert used) - (when (typep used 'c-dependent) - (loop with any - for used-used in (cd-useds used) - when (dump-stale-path used-used) - do (progn - (setf any t) - (trc "stale-path" used :uses... used-used)) - finally - (when (or any (cd-stale-p used)) - (trc "stale" used) - (return any))))) - -(defun dump-dependency-path (used user) - (assert (and used user)) - (if (eql used user) - (progn - (trc "bingo---------------") - (trc "user" user :uses...) - t) - (let (any) - (dolist (used-user (cd-users used) any) - (when (dump-dependency-path used-user user) - (setf any t) - (trc "user" used-user :uses... used)))))) - -(defun c-pending-set (c newvalue debug-tag) - (declare (ignorable debug-tag)) - (assert (find c (cells (c-model c)) :key #'cdr)) - (when newvalue (trc nil "still pending!!!!!!!!!!!!!!!!!!" c newvalue debug-tag)) - (if newvalue - (bif (known (assoc c *sw-pending*)) - (cond - ((eq newvalue (cdr known)) - (break "hunh? re-pending ~a on same holdup ~a?" c (cdr known))) - ((c-true-stalep (cdr known)) - (break "hunh? pending ~a on second holdup ~a as well as ~a?" c newvalue (cdr known))) - (t - (trc nil "re-pending ~a on new holdup ~a, last ok: ~a" c newvalue (assoc c *sw-pending*)) - (rplacd known newvalue))) ;; risky business, might need whole new assoc entry - (let ((newpending (cons c newvalue))) - (progn - (assert (typep c 'c-dependent)) - (assert (not (eq :eternal-rest (md-state (c-model c))))) - ;;(trc nil "pending on, genealogy holdup: held, holder:" debug-tag c newvalue) - ;;(dump-pending) - ) - ;;; hunh?> (pushnew newpending *sw-pending* :test #'equal) - (push newpending *sw-pending*))) - (bwhen (p (assoc c *sw-pending*)) - (trc nil "clear from sw-pending" debug-tag c (remove-if (lambda (p) - (not (eql c (car p)))) - *sw-pending*)) - (setf *sw-pending* (delete (assoc c *sw-pending*) *sw-pending*)) - (progn - (trc nil "pending off, genealogy holdup: held, holder:" debug-tag p - (count c *sw-pending* :key #'car)) - (dump-pending)) - )) - newvalue) - -(defmethod sw-pending ((c cell)) - (assoc c *sw-pending*)) - -(defmethod sw-pending ((s synapse)) - (sw-pending (syn-used s))) - - +;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- +;;; +;;; Copyright (c) 1995,2003 by Kenneth William Tilton. +;;; +;;; Permission is hereby granted, free of charge, to any person obtaining a copy +;;; of this software and associated documentation files (the "Software"), to deal +;;; in the Software without restriction, including without limitation the rights +;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +;;; copies of the Software, and to permit persons to whom the Software is furnished +;;; to do so, subject to the following conditions: +;;; +;;; The above copyright notice and this permission notice shall be included in +;;; all copies or substantial portions of the Software. +;;; +;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS +;;; IN THE SOFTWARE. + +(in-package :cells) + +(defparameter *df-interference-detection* t) + +(eval-when (compile eval load) + (export '(*df-interference-detection*))) + +(defmethod sw-detect-interference (user trigger) + (declare (ignorable trigger)) + (when #+runtime-system t #-runtime-system *df-interference-detection* + (trc nil "detect entry" user (cd-useds user)) + (dolist (used (cd-useds user)) + (do ((deep-stale (cd-deep-stale used)(cd-deep-stale used))) + ((null deep-stale)) + ;;(trc nil "sw-detect-interference trying deep stale" deep-stale) + (c-rethink deep-stale) + (cond + ((c-true-stalep deep-stale) + (trc "!! true deep stalep: user>" user) + (trc "!! true deep stalep: used>" used) + (trc "!! true deep stalep: deepstale>" deep-stale) + (return-from sw-detect-interference deep-stale #+debugging (list user used deep-stale))) + + ((not (c-true-stalep user)) + (return-from sw-detect-interference nil))))))) + +(defmethod sw-detect-interference ((user c-variable) trigger) + (declare (ignore trigger))) + +(defmethod sw-detect-interference ((user synapse) trigger) + (sw-detect-interference (syn-used user) trigger)) + +(defmethod cd-deep-stale ((c c-dependent)) + (trc nil "cd-deep-stale entry" c) + (if (cd-stale-p c) + c ;; (eko ("deep stalep bingo !!!!!!") c) + (some #'cd-deep-stale (cd-useds c)))) + +(defmethod cd-deep-stale ((syn synapse)) + (cd-deep-stale (syn-used syn))) + +(defmethod cd-deep-stale (c) + (declare (ignore c))) + +(defparameter *sw-pending* nil) +(defparameter *dataflowing* nil) + +(defun dump-pending () + (dotimes (x (length *sw-pending*)) + (let ((p (nth x *sw-pending*))) + (destructuring-bind (heldup . holdup) p + (declare (ignorable holdup)) + (trc heldup " pending!!!!!!!!!!" p) + ))) + ) + +;; mo better diags: holdup (c-true-stalep holdup) heldup (c-true-stalep heldup)))))) + +(defun call-with-dataflow-management (c-originating bodyfn) + (declare (ignorable c-originating)) + (if *dataflowing* + (progn + (setf (cv-setting-p c-originating) t) + (prog1 + (funcall bodyfn) + (setf (cv-setting-p c-originating) nil))) + + (let ((*dataflowing* t) + *sw-pending*) + #+dfdbg (trc nil ">>>>> with-dataflow-management: 001" c-originating) + (setf (cv-setting-p c-originating) t) + (prog1 + (funcall bodyfn) + + (while (and *sw-pending* + (not *sw-looping*)) + + #+dfdbg + (progn + (trc nil "we have pending!!!!!!!!!!" (length *sw-pending*)) + (dump-pending)) + + (let ((pct (length *sw-pending*)) + (oldpending (copy-list *sw-pending*))) + ;;(trace c-rethink) + (labels ((do-last (pending) + (when pending + (do-last (cdr pending)) + ;;(trace c-rethink cd-deep-stale sw-detect-interference) + (destructuring-bind (heldup . holdup) (car pending) + (trc heldup "pending sweep sees held up" heldup :holdup holdup) + (c-assert (find heldup (cells (c-model heldup)) :key #'cdr)) + (c-assert (find holdup (cells (c-model holdup)) :key #'cdr)) + ;; (unless (c-true-stalep holdup) + ;; (trc nil "dataflow sees freed blocker" holdup)) + (if (c-true-stalep holdup) + (if (eq :eternal-rest (md-state (c-model holdup))) + (progn (trc "holdup is no more!!!!!!!" holdup (c-true-stalep heldup) heldup)) + (progn + (trc holdup "dataflow retrying blocker" holdup) + (c-rethink holdup))) + (progn + (trc heldup "holdup not stale!!!" holdup :heldup> heldup) + (c-pending-set heldup nil :holdup-unstale) )) + ;;(unless (c-true-stalep heldup) + ;; (trc nil "dataflow sees freed blocked" heldup)) + (when (c-true-stalep heldup) + (trc heldup "dataflow retrying blocked" heldup) + (c-rethink heldup)))))) + ;; (trace c-rethink cd-deep-stale sw-detect-interference) + (do-last *sw-pending*) + ;; (trc "post sweep pending leftovers:" (length *sw-pending*)) + ;; (untrace c-rethink cd-deep-stale sw-detect-interference) + ) + ;;(untrace c-rethink) + (when (and (equal oldpending *sw-pending*) + (eql pct (length *sw-pending*)) + (not *sw-looping*)) + (setf *sw-looping* t) + #+nah (dolist (p *sw-pending*) + (destructuring-bind (heldup . holdup) p + (dump-dependency-path holdup heldup))) + #+nah (dolist (p *sw-pending*) + (destructuring-bind (heldup . holdup) p + (declare (ignorable heldup)) + (when t ;; (trcp holdup) + (dump-stale-path holdup)))) + (break "trigger ~a stuck; cant lose pendings ~a" + c-originating + *sw-pending*)) + + ;; (trc "after sweep sw-pending" *sw-pending*) + ;; (cellbrk) + )) + (when c-originating + (setf (cv-setting-p c-originating) nil)) + (trc nil "<<<< with-dataflow-management:" c-originating))))) + +(defun dump-stale-path (used) + (c-assert used) + (when (typep used 'c-dependent) + (loop with any + for used-used in (cd-useds used) + when (dump-stale-path used-used) + do (progn + (setf any t) + (trc "stale-path" used :uses... used-used)) + finally + (when (or any (cd-stale-p used)) + (trc "stale" used) + (return any))))) + +(defun dump-dependency-path (used user) + (c-assert (and used user)) + (if (eql used user) + (progn + (trc "bingo---------------") + (trc "user" user :uses...) + t) + (let (any) + (dolist (used-user (cd-users used) any) + (when (dump-dependency-path used-user user) + (setf any t) + (trc "user" used-user :uses... used)))))) + +(defun c-pending-set (c newvalue debug-tag) + (declare (ignorable debug-tag)) + (c-assert (find c (cells (c-model c)) :key #'cdr)) + (when newvalue (trc nil "still pending!!!!!!!!!!!!!!!!!!" c newvalue debug-tag)) + (if newvalue + (bif (known (assoc c *sw-pending*)) + (cond + ((eq newvalue (cdr known)) + (break "hunh? re-pending ~a on same holdup ~a?" c (cdr known))) + ((c-true-stalep (cdr known)) + (break "hunh? pending ~a on second holdup ~a as well as ~a?" c newvalue (cdr known))) + (t + (trc nil "re-pending ~a on new holdup ~a, last ok: ~a" c newvalue (assoc c *sw-pending*)) + (rplacd known newvalue))) ;; risky business, might need whole new assoc entry + (let ((newpending (cons c newvalue))) + (progn + (c-assert (typep c 'c-dependent)) + (c-assert (not (eq :eternal-rest (md-state (c-model c))))) + ;;(trc nil "pending on, genealogy holdup: held, holder:" debug-tag c newvalue) + ;;(dump-pending) + ) + ;;; hunh?> (pushnew newpending *sw-pending* :test #'equal) + (push newpending *sw-pending*))) + (bwhen (p (assoc c *sw-pending*)) + (trc nil "clear from sw-pending" debug-tag c (remove-if (lambda (p) + (not (eql c (car p)))) + *sw-pending*)) + (setf *sw-pending* (delete (assoc c *sw-pending*) *sw-pending*)) + (progn + (trc nil "pending off, genealogy holdup: held, holder:" debug-tag p + (count c *sw-pending* :key #'car)) + (dump-pending)) + )) + newvalue) + +(defmethod sw-pending ((c cell)) + (assoc c *sw-pending*)) + +(defmethod sw-pending ((s synapse)) + (sw-pending (syn-used s))) + +

Index: cells/debug.lisp diff -u cells/debug.lisp:1.1.1.1 cells/debug.lisp:1.2 --- cells/debug.lisp:1.1.1.1 Sat Nov 8 18:44:00 2003 +++ cells/debug.lisp Tue Dec 16 10:02:58 2003 @@ -1,268 +1,263 @@ -;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- -;;; -;;; Copyright © 1995,2003 by Kenneth William Tilton. -;;; -;;; Permission is hereby granted, free of charge, to any person obtaining a copy -;;; of this software and associated documentation files (the "Software"), to deal -;;; in the Software without restriction, including without limitation the rights -;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell -;;; copies of the Software, and to permit persons to whom the Software is furnished -;;; to do so, subject to the following conditions: -;;; -;;; The above copyright notice and this permission notice shall be included in -;;; all copies or substantial portions of the Software. -;;; -;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING -;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS -;;; IN THE SOFTWARE. - -(in-package :cells) - -(defun cellstop () - ;; (break "in-cell-stop") - (setf *stop* t)) - -(defun cellbrk (&optional (tag :anon)) - (unless (or *stop*) - ;; daring move, hoping having handler at outside stops the game (cellstop) - (print `(cell break , tag)) - (break))) - -;----------- trc ------------------------------------------- - -(defun trcdepth-reset () - (setf *trcdepth* 0)) - -(defmacro trc (tgtform &rest os) - (if (eql tgtform 'nil) - '(progn) - (if (stringp tgtform) - `(without-c-dependency - (call-trc t ,tgtform ,@os)) - (let ((tgt (gensym))) - `(without-c-dependency - (bif (,tgt ,tgtform) - (if (trcp ,tgt) - (progn - (assert (stringp ,(car os))) - (call-trc t ,@os)) ;;,(car os) ,tgt ,@(cdr os))) - (progn - (break) - (count-it :trcfailed))) - (count-it :tgtnileval))))))) - -(defun call-trc (stream s &rest os) - (if #+cormanlisp nil #-cormanlisp (and (boundp '*trcdepth*) - *trcdepth*) - (format stream "~&~v,,,'.<~d~>> " (mod *trcdepth* 100) *trcdepth*) - (format stream "~&")) - - (format stream "~a" s) - (let (pkwp) - (dolist (o os) - (format stream (if pkwp " ~s" " | ~s") o) - (setf pkwp (keywordp o)))) - (values)) - -(defun call-trc-to-string (fmt$ &rest fmtargs) - (let ((o$ (make-array '(0) :element-type 'base-char - :fill-pointer 0 :adjustable t))) - (with-output-to-string (ostream o$) - (apply 'call-trc ostream fmt$ fmtargs)) - o$)) - -#+findtrcevalnils -(defmethod trcp :around (other) - (unless (call-next-method other)(break))) - -(defmethod trcp (other) - (eq other t)) - -(defmethod trcp (($ string)) - t) - -(defun trcdepth-incf () - (incf *trcdepth*)) - -(defun trcdepth-decf () - (format t "decrementing trc depth" *trcdepth*) - (decf *trcdepth*)) - -(defmacro wtrc ((&optional (min 1) (max 50) &rest banner) &body body ) - `(let ((*trcdepth* (if *trcdepth* - (1+ *trcdepth*) - 0))) - ,(when banner `(when (>= *trcdepth* ,min) - (if (< *trcdepth* ,max) - (trc ,@banner) - (progn - (break "excess trace notttt!!! ~d" *trcdepth*) ;; ,@banner) - nil)))) - (when (< *trcdepth* ,max) - ,@body))) - -(defmacro wnotrc ((&optional (min 1) (max 50) &rest banner) &body body ) - (declare (ignore min max banner)) - `(progn ,@body)) - -;------ eko -------------------------------------- - - -(defmacro eko ((&rest trcargs) &rest body) - (let ((result (gensym))) - `(let ((,result ,@body)) - (trc ,(car trcargs) :=> ,result ,@(cdr trcargs)) - ,result))) - -(defmacro ek (label &rest body) - (let ((result (gensym))) - `(let ((,result (,@body))) - (when ,label - (trc ,label ,result)) - ,result))) - -;------------- counting --------------------------- -(defvar *count* nil) -(defvar *counting* nil) - -(defmacro with-counts ((onp &rest msg) &body body) - `(if ,onp - (prog2 - (progn - (count-clear ,@msg) - (push t *counting*)) - (progn ,@body) - (pop *counting*) - (show-count t ,@msg)) - (progn ,@body))) - -(defun count-clear (&rest msg) - (declare (ignorable msg)) - (format t "~&count-clear > ~a" msg) - (setf *count* nil)) - -(defmacro count-it (&rest keys) - `(when *counting* - (call-count-it ,@keys))) - -(defun call-count-it (&rest keys) - (declare (ignorable keys)) - ;;; (when (eql :TGTNILEVAL (car keys))(break)) - (let ((entry (assoc keys *count* :test #'equal))) - (if entry - (setf (cdr entry) (1+ (cdr entry))) - (push (cons keys 1) *count*)))) - -(defun show-count (clearp &rest msg) - (format t "~&Counts after: clearp ~a, length ~d: ~s" clearp (length *count*) msg) - (let ((res (sort (copy-list *count*) (lambda (v1 v2) - (let ((v1$ (symbol-name (caar v1))) - (v2$ (symbol-name (caar v2)))) - (if (string= v1$ v2$) - (< (cdr v1) (cdr v2)) - (string< v1$ v2$)))))) - ) - (loop for entry in res - for occs = (cdr entry) - when (plusp occs) - sum occs into running - and do (format t "~&~4d ... ~2d ... ~s" running occs (car entry)))) - (when clearp (count-clear "show-count"))) - -#+test -(loop for entry in '((a . 10)(b . 5)(c . 0)(e . -20)(d . 2)) - for occs = (cdr entry) - when (plusp occs) - sum occs into running - and do (print (list entry occs running))) - - -;-------------------- timex --------------------------------- - -;;;(defmacro timex ((onp &rest trcArgs) &body body) -;;; `(if ,onp -;;; (prog1 -;;; (time -;;; (progn ,@body)) -;;; (trc "timing was of" ,@trcARgs)) -;;; (progn ,@body))) - - -;---------------- Metrics ------------------- - -(defmacro with-metrics ((countp timep &rest trcargs) &body body) - `(with-counts (,countp ,@trcargs) - (timex (,timep ,@trcargs) - ,@body))) - - -; -------- cell conditions (not much used) --------------------------------------------- - -(define-condition xcell () ;; new 2k0227 - ((cell :initarg :cell :reader cell :initform nil) - (appfunc :initarg :appfunc :reader appfunc :initform 'badcell) - (errortext :initarg :errortext :reader errortext :initform "<???>") - (otherdata :initarg :otherdata :reader otherdata :initform "<nootherdata>")) - (:report (lambda (c s) - (format s "~& trouble with cell ~a in function ~s,~s: ~s" - (cell c) (appfunc c) (errortext c) (otherdata c))))) - -(define-condition c-enabling () - ((name :initarg :name :reader name) - (model :initarg :model :reader model) - (cell :initarg :cell :reader cell)) - (:report (lambda (condition stream) - (format stream "~&unhandled <c-enabling>: ~s" condition) - (break "~&i say, unhandled <c-enabling>: ~s" condition)))) - -(define-condition c-fatal (xcell) - ((name :initarg :name :reader name) - (model :initarg :model :reader model) - (cell :initarg :cell :reader cell)) - (:report (lambda (condition stream) - (format stream "~&fatal cell programming error: ~s" condition) - (format stream "~& : ~s" (name condition)) - (format stream "~& : ~s" (model condition)) - (format stream "~& : ~s" (cell condition))))) - -(define-condition c-unadopted (c-fatal) - () - (:report - (lambda (condition stream) - (format stream "~&unadopted cell >: ~s" (cell condition)) - (format stream "~& >: often you mis-edit (c? (c? ...)) nesting is error")))) - - -;----------------------------- link debugging ----------------------- - - -(defun dump-users (c &optional (depth 0)) - (format t "~&~v,4t~s" depth c) - (dolist (user (un-users c)) - (dump-users user (+ 1 depth)))) - -(defun dump-useds (c &optional (depth 0)) - ;(c.trc "dump-useds> entry " c (+ 1 depth)) - (when (zerop depth) - (format t "x~&")) - (format t "~&|usd> ~v,8t~s" depth c) - (when (typep c 'c-ruled) - ;(c.trc "its ruled" c) - (dolist (used (cd-useds c)) - (dump-useds used (+ 1 depth))))) - - -(defun cell-reset () - (setf *count* nil - *stop* nil - *dbg* nil - *mybreak* nil - *c-prop-depth* 0 - *sw-looping* nil - *to-be-awakened* nil - *trcdepth* 0)) - +;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- +;;; +;;; Copyright (c) 1995,2003 by Kenneth William Tilton. +;;; +;;; Permission is hereby granted, free of charge, to any person obtaining a copy +;;; of this software and associated documentation files (the "Software"), to deal +;;; in the Software without restriction, including without limitation the rights +;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +;;; copies of the Software, and to permit persons to whom the Software is furnished +;;; to do so, subject to the following conditions: +;;; +;;; The above copyright notice and this permission notice shall be included in +;;; all copies or substantial portions of the Software. +;;; +;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS +;;; IN THE SOFTWARE. + +(in-package :cells) + +(defun cellbrk (&optional (tag :anon)) + (unless (or (c-stopped)) + ;; daring move, hoping having handler at outside stops the game (cellstop) + (print `(cell break , tag)) + (break))) + +;----------- trc ------------------------------------------- + +(defun trcdepth-reset () + (setf *trcdepth* 0)) + +(defmacro trc (tgtform &rest os) + (if (eql tgtform 'nil) + '(progn) + (if (stringp tgtform) + `(without-c-dependency + (call-trc t ,tgtform ,@os)) + (let ((tgt (gensym))) + `(without-c-dependency + (bif (,tgt ,tgtform) + (if (trcp ,tgt) + (progn + (c-assert (stringp ,(car os))) + (call-trc t ,@os)) ;;,(car os) ,tgt ,@(cdr os))) + (progn + ;;; (break) + (count-it :trcfailed))) + (count-it :tgtnileval))))))) + +(defun call-trc (stream s &rest os) + (if #+cormanlisp nil #-cormanlisp (and (boundp '*trcdepth*) + *trcdepth*) + (format stream "~&~v,,,'.<~d~>> " (mod *trcdepth* 100) *trcdepth*) + (format stream "~&")) + + (format stream "~a" s) + (let (pkwp) + (dolist (o os) + (format stream (if pkwp " ~s" " | ~s") o) + (setf pkwp (keywordp o)))) + (values)) + +(defun call-trc-to-string (fmt$ &rest fmtargs) + (let ((o$ (make-array '(0) :element-type 'base-char + :fill-pointer 0 :adjustable t))) + (with-output-to-string (ostream o$) + (apply 'call-trc ostream fmt$ fmtargs)) + o$)) + +#+findtrcevalnils +(defmethod trcp :around (other) + (unless (call-next-method other)(break))) + +(defmethod trcp (other) + (eq other t)) + +(defmethod trcp (($ string)) + t) + +(defun trcdepth-incf () + (incf *trcdepth*)) + +(defun trcdepth-decf () + (format t "decrementing trc depth" *trcdepth*) + (decf *trcdepth*)) + +(defmacro wtrc ((&optional (min 1) (max 50) &rest banner) &body body ) + `(let ((*trcdepth* (if *trcdepth* + (1+ *trcdepth*) + 0))) + ,(when banner `(when (>= *trcdepth* ,min) + (if (< *trcdepth* ,max) + (trc ,@banner) + (progn + (break "excess trace notttt!!! ~d" *trcdepth*) ;; ,@banner) + nil)))) + (when (< *trcdepth* ,max) + ,@body))) + +(defmacro wnotrc ((&optional (min 1) (max 50) &rest banner) &body body ) + (declare (ignore min max banner)) + `(progn ,@body)) + +;------ eko -------------------------------------- + + +(defmacro eko ((&rest trcargs) &rest body) + (let ((result (gensym))) + `(let ((,result ,@body)) + (trc ,(car trcargs) :=> ,result ,@(cdr trcargs)) + ,result))) + +(defmacro ek (label &rest body) + (let ((result (gensym))) + `(let ((,result (,@body))) + (when ,label + (trc ,label ,result)) + ,result))) + +;------------- counting --------------------------- +(defvar *count* nil) +(defvar *counting* nil) + +(defmacro with-counts ((onp &rest msg) &body body) + `(if ,onp + (prog2 + (progn + (count-clear ,@msg) + (push t *counting*)) + (progn ,@body) + (pop *counting*) + (show-count t ,@msg)) + (progn ,@body))) + +(defun count-clear (&rest msg) + (declare (ignorable msg)) + (format t "~&count-clear > ~a" msg) + (setf *count* nil)) + +(defmacro count-it (&rest keys) + `(when *counting* + (call-count-it ,@keys))) + +(defun call-count-it (&rest keys) + (declare (ignorable keys)) + ;;; (when (eql :TGTNILEVAL (car keys))(break)) + (let ((entry (assoc keys *count* :test #'equal))) + (if entry + (setf (cdr entry) (1+ (cdr entry))) + (push (cons keys 1) *count*)))) + +(defun show-count (clearp &rest msg) + (format t "~&Counts after: clearp ~a, length ~d: ~s" clearp (length *count*) msg) + (let ((res (sort (copy-list *count*) (lambda (v1 v2) + (let ((v1$ (symbol-name (caar v1))) + (v2$ (symbol-name (caar v2)))) + (if (string= v1$ v2$) + (< (cdr v1) (cdr v2)) + (string< v1$ v2$)))))) + ) + (loop for entry in res + for occs = (cdr entry) + when (plusp occs) + sum occs into running + and do (format t "~&~4d ... ~2d ... ~s" running occs (car entry)))) + (when clearp (count-clear "show-count"))) + +#+test +(loop for entry in '((a . 10)(b . 5)(c . 0)(e . -20)(d . 2)) + for occs = (cdr entry) + when (plusp occs) + sum occs into running + and do (print (list entry occs running))) + + +;-------------------- timex --------------------------------- + +(defmacro timex ((onp &rest trcArgs) &body body) + `(if ,onp + (prog1 + (time + (progn ,@body)) + (trc "timing was of" ,@trcARgs)) + (progn ,@body))) + + +;---------------- Metrics ------------------- + +(defmacro with-metrics ((countp timep &rest trcargs) &body body) + `(with-counts (,countp ,@trcargs) + (timex (,timep ,@trcargs) + ,@body))) + + +; -------- cell conditions (not much used) --------------------------------------------- + +(define-condition xcell () ;; new 2k0227 + ((cell :initarg :cell :reader cell :initform nil) + (appfunc :initarg :appfunc :reader appfunc :initform 'badcell) + (errortext :initarg :errortext :reader errortext :initform "<???>") + (otherdata :initarg :otherdata :reader otherdata :initform "<nootherdata>")) + (:report (lambda (c s) + (format s "~& trouble with cell ~a in function ~s,~s: ~s" + (cell c) (appfunc c) (errortext c) (otherdata c))))) + +(define-condition c-enabling () + ((name :initarg :name :reader name) + (model :initarg :model :reader model) + (cell :initarg :cell :reader cell)) + (:report (lambda (condition stream) + (format stream "~&unhandled <c-enabling>: ~s" condition) + (break "~&i say, unhandled <c-enabling>: ~s" condition)))) + +(define-condition c-fatal (xcell) + ((name :initarg :name :reader name) + (model :initarg :model :reader model) + (cell :initarg :cell :reader cell)) + (:report (lambda (condition stream) + (format stream "~&fatal cell programming error: ~s" condition) + (format stream "~& : ~s" (name condition)) + (format stream "~& : ~s" (model condition)) + (format stream "~& : ~s" (cell condition))))) + +(define-condition c-unadopted (c-fatal) + () + (:report + (lambda (condition stream) + (format stream "~&unadopted cell >: ~s" (cell condition)) + (format stream "~& >: often you mis-edit (c? (c? ...)) nesting is error")))) + + +;----------------------------- link debugging ----------------------- + + +(defun dump-users (c &optional (depth 0)) + (format t "~&~v,4t~s" depth c) + (dolist (user (c-users c)) + (dump-users user (+ 1 depth)))) + +(defun dump-useds (c &optional (depth 0)) + ;(c.trc "dump-useds> entry " c (+ 1 depth)) + (when (zerop depth) + (format t "x~&")) + (format t "~&|usd> ~v,8t~s" depth c) + (when (typep c 'c-ruled) + ;(c.trc "its ruled" c) + (dolist (used (cd-useds c)) + (dump-useds used (+ 1 depth))))) + + +(defun cell-reset () + (setf *count* nil + *stop* nil + *dbg* nil + *c-break* nil + *c-prop-depth* 0 + *sw-looping* nil + *to-be-awakened* nil + *trcdepth* 0)) \ No newline at end of file

Index: cells/defmodel.lisp diff -u cells/defmodel.lisp:1.1.1.1 cells/defmodel.lisp:1.2 --- cells/defmodel.lisp:1.1.1.1 Sat Nov 8 18:44:00 2003 +++ cells/defmodel.lisp Tue Dec 16 10:02:58 2003 @@ -1,121 +1,121 @@ -;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- -;;; -;;; Copyright © 1995,2003 by Kenneth William Tilton. -;;; -;;; Permission is hereby granted, free of charge, to any person obtaining a copy -;;; of this software and associated documentation files (the "Software"), to deal -;;; in the Software without restriction, including without limitation the rights -;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell -;;; copies of the Software, and to permit persons to whom the Software is furnished -;;; to do so, subject to the following conditions: -;;; -;;; The above copyright notice and this permission notice shall be included in -;;; all copies or substantial portions of the Software. -;;; -;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING -;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS -;;; IN THE SOFTWARE. - -(in-package :cells) - -(defmacro defmodel (class directsupers slotspecs &rest options) - ;;(print `(defmodel sees directsupers ,directsupers using ,(or directsupers :model-object))) - `(progn - (eval-when (:compile-toplevel :execute :load-toplevel) - (setf (get ',class :cell-defs) nil)) - ; - ; define slot macros before class so they can appear in initforms and default-initargs - ; - ,@(mapcar (lambda (slotspec) - (destructuring-bind - (slotname &rest slotargs - &key (cell t) accessor reader - &allow-other-keys) - slotspec - (declare (ignorable slotargs)) - (when cell - (let* ((readerfn (or reader accessor)) - (deriverfn (intern$ "^" (symbol-name readerfn))) - ) - ; - ; may as well do this here... - ; - ;;(trc nil "slot, deriverfn would be" slotname deriverfn) - `(eval-when (:compile-toplevel :execute :load-toplevel) - (setf (md-slot-cell-type ',class ',slotname) ,cell) - (unless (macro-function ',deriverfn) - (defmacro ,deriverfn (&optional (model 'self) synfactory) - `(let ((*synapse-factory* ,synfactory)) - (,',readerfn ,model)))) - ) - )) - )) - slotspecs) - - ; - ; ------- defclass --------------- (^slot-value ,model ',',slotname) - ; - - (progn - (defclass ,class ,(or directsupers '(model-object));; now we can def the class - ,(mapcar (lambda (s) - (list* (car s) - (let ((ias (cdr s))) - (remf ias :cell) - (remf ias :cwhen) - (remf ias :unchanged-if) - ias))) (mapcar #'copy-list slotspecs)) - (:documentation - ,@(or (cdr (find :documentation options :key #'car)) - '("chya"))) - (:default-initargs ;; nil ok and needed: acl oddity in re not clearing d-i's sans this - ,@(cdr (find :default-initargs options :key #'car))) - (:metaclass ,(or (find :metaclass options :key #'car) - 'standard-class))) - - (defmethod shared-initialize :after ((self ,class) slot-names &rest iargs) - (declare (ignore slot-names iargs)) - ,(when (and directsupers (not (member 'model-object directsupers))) - `(unless (typep self 'model-object) - (error "If no superclass of ~a inherits directly -or indirectly from model-object, model-object must be included as a direct super-class in -the defmodel form for ~a" ',class ',class)))) - ; - ; slot accessors once class is defined... - ; - ,@(mapcar (lambda (slotspec) - (destructuring-bind - (slotname &rest slotargs - &key (cell t) unchanged-if accessor reader writer type - &allow-other-keys) - slotspec - (declare (ignorable slotargs)) - (when cell - (let* ((readerfn (or reader accessor)) - (writerfn (or writer accessor)) - ) - (setf (md-slot-cell-type class slotname) cell) - - `(progn - ,(when readerfn - `(defmethod ,readerfn ((self ,class)) - (md-slot-value self ',slotname))) - - ,(when writerfn - `(defmethod (setf ,writerfn) (new-value (self ,class)) - (setf (md-slot-value self ',slotname) - ,(if type - `(coerce new-value ',type) - 'new-value)))) - - ,(when unchanged-if - `(def-c-unchanged-test (,class ,slotname))) - ) - )) - )) - slotspecs) +;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- +;;; +;;; Copyright (c) 1995,2003 by Kenneth William Tilton. +;;; +;;; Permission is hereby granted, free of charge, to any person obtaining a copy +;;; of this software and associated documentation files (the "Software"), to deal +;;; in the Software without restriction, including without limitation the rights +;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +;;; copies of the Software, and to permit persons to whom the Software is furnished +;;; to do so, subject to the following conditions: +;;; +;;; The above copyright notice and this permission notice shall be included in +;;; all copies or substantial portions of the Software. +;;; +;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS +;;; IN THE SOFTWARE. + +(in-package :cells) + +(defmacro defmodel (class directsupers slotspecs &rest options) + ;;(print `(defmodel sees directsupers ,directsupers using ,(or directsupers :model-object))) + `(progn + (eval-when (:compile-toplevel :execute :load-toplevel) + (setf (get ',class :cell-types) nil)) + ; + ; define slot macros before class so they can appear in initforms and default-initargs + ; + ,@(mapcar (lambda (slotspec) + (destructuring-bind + (slotname &rest slotargs + &key (cell t) accessor reader + &allow-other-keys) + slotspec + (declare (ignorable slotargs)) + (when cell + (let* ((readerfn (or reader accessor)) + (deriverfn (intern$ "^" (symbol-name readerfn))) + ) + ; + ; may as well do this here... + ; + ;;(trc nil "slot, deriverfn would be" slotname deriverfn) + `(eval-when (:compile-toplevel :execute :load-toplevel) + (setf (md-slot-cell-type ',class ',slotname) ,cell) + (unless (macro-function ',deriverfn) + (defmacro ,deriverfn (&optional (model 'self) synfactory) + `(let ((*synapse-factory* ,synfactory)) + (,',readerfn ,model)))) + ) + )) + )) + slotspecs) + + ; + ; ------- defclass --------------- (^slot-value ,model ',',slotname) + ; + + (progn + (defclass ,class ,(or directsupers '(model-object));; now we can def the class + ,(mapcar (lambda (s) + (list* (car s) + (let ((ias (cdr s))) + (remf ias :cell) + (remf ias :cwhen) + (remf ias :unchanged-if) + ias))) (mapcar #'copy-list slotspecs)) + (:documentation + ,@(or (cdr (find :documentation options :key #'car)) + '("chya"))) + (:default-initargs ;; nil ok and needed: acl oddity in re not clearing d-i's sans this + ,@(cdr (find :default-initargs options :key #'car))) + (:metaclass ,(or (find :metaclass options :key #'car) + 'standard-class))) + + (defmethod shared-initialize :after ((self ,class) slot-names &rest iargs) + (declare (ignore slot-names iargs)) + ,(when (and directsupers (not (member 'model-object directsupers))) + `(unless (typep self 'model-object) + (error "If no superclass of ~a inherits directly +or indirectly from model-object, model-object must be included as a direct super-class in +the defmodel form for ~a" ',class ',class)))) + ; + ; slot accessors once class is defined... + ; + ,@(mapcar (lambda (slotspec) + (destructuring-bind + (slotname &rest slotargs + &key (cell t) unchanged-if accessor reader writer type + &allow-other-keys) + slotspec + (declare (ignorable slotargs)) + (when cell + (let* ((readerfn (or reader accessor)) + (writerfn (or writer accessor)) + ) + (setf (md-slot-cell-type class slotname) cell) + + `(progn + ,(when readerfn + `(defmethod ,readerfn ((self ,class)) + (md-slot-value self ',slotname))) + + ,(when writerfn + `(defmethod (setf ,writerfn) (new-value (self ,class)) + (setf (md-slot-value self ',slotname) + ,(if type + `(coerce new-value ',type) + 'new-value)))) + + ,(when unchanged-if + `(def-c-unchanged-test (,class ,slotname) ,unchanged-if)) + ) + )) + )) + slotspecs) (find-class ',class))))

Index: cells/detritus.lisp diff -u cells/detritus.lisp:1.1.1.1 cells/detritus.lisp:1.2 --- cells/detritus.lisp:1.1.1.1 Sat Nov 8 18:44:05 2003 +++ cells/detritus.lisp Tue Dec 16 10:02:58 2003 @@ -1,49 +1,49 @@ -;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- -;;; -;;; Copyright © 1995,2003 by Kenneth William Tilton. -;;; -;;; Permission is hereby granted, free of charge, to any person obtaining a copy -;;; of this software and associated documentation files (the "Software"), to deal -;;; in the Software without restriction, including without limitation the rights -;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell -;;; copies of the Software, and to permit persons to whom the Software is furnished -;;; to do so, subject to the following conditions: -;;; -;;; The above copyright notice and this permission notice shall be included in -;;; all copies or substantial portions of the Software. -;;; -;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING -;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS -;;; IN THE SOFTWARE. - -(in-package :cells) - -(defvar *dbg*) - -(defmacro wdbg (&body body) - `(let ((*dbg* t)) - ,@body)) - -#+clisp -(defun slot-definition-name (slot) - (clos::slotdef-name slot)) - -(defmethod class-slot-named ((classname symbol) slotname) - (class-slot-named (find-class classname) slotname)) - -(defmethod class-slot-named (class slotname) - (find slotname (class-slots class) :key #'slot-definition-name)) - -#+mcl -(defun class-slots (c) - (nconc (copy-list (class-class-slots c)) - (copy-list (class-instance-slots c)))) - -(defun true (it) (declare (ignore it)) t) -(defun false (it) (declare (ignore it))) -(defun xor (c1 c2) - (if c1 (not c2) c2)) +;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- +;;; +;;; Copyright (c) 1995,2003 by Kenneth William Tilton. +;;; +;;; Permission is hereby granted, free of charge, to any person obtaining a copy +;;; of this software and associated documentation files (the "Software"), to deal +;;; in the Software without restriction, including without limitation the rights +;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +;;; copies of the Software, and to permit persons to whom the Software is furnished +;;; to do so, subject to the following conditions: +;;; +;;; The above copyright notice and this permission notice shall be included in +;;; all copies or substantial portions of the Software. +;;; +;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS +;;; IN THE SOFTWARE. + +(in-package :cells) + +(defvar *dbg*) + +(defmacro wdbg (&body body) + `(let ((*dbg* t)) + ,@body)) + +#+clisp +(defun slot-definition-name (slot) + (clos::slotdef-name slot)) + +(defmethod class-slot-named ((classname symbol) slotname) + (class-slot-named (find-class classname) slotname)) + +(defmethod class-slot-named (class slotname) + (find slotname (class-slots class) :key #'slot-definition-name)) + +#+mcl +(defun class-slots (c) + (nconc (copy-list (class-class-slots c)) + (copy-list (class-instance-slots c)))) + +(defun true (it) (declare (ignore it)) t) +(defun false (it) (declare (ignore it))) +(defun xor (c1 c2) + (if c1 (not c2) c2))

Index: cells/family-values.lisp diff -u cells/family-values.lisp:1.1.1.1 cells/family-values.lisp:1.2 --- cells/family-values.lisp:1.1.1.1 Sat Nov 8 18:44:05 2003 +++ cells/family-values.lisp Tue Dec 16 10:02:58 2003 @@ -1,105 +1,105 @@ -;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- -;;; -;;; Copyright © 1995,2003 by Kenneth William Tilton. -;;; -;;; Permission is hereby granted, free of charge, to any person obtaining a copy -;;; of this software and associated documentation files (the "Software"), to deal -;;; in the Software without restriction, including without limitation the rights -;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell -;;; copies of the Software, and to permit persons to whom the Software is furnished -;;; to do so, subject to the following conditions: -;;; -;;; The above copyright notice and this permission notice shall be included in -;;; all copies or substantial portions of the Software. -;;; -;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING -;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS -;;; IN THE SOFTWARE. - -(in-package :cells) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (export '(family-values family-values-sorted - sortindex sortdirection sortpredicate sortkey - ^sortindex ^sortdirection ^sortpredicate ^sortkey))) - -(defmodel family-values (family) - ( - (kvcollector :initarg :kvcollector - :initform #'identity - :reader kvcollector) - - (kidvalues :cell t - :initform (c? (when (kvcollector self) - (funcall (kvcollector self) (^mdvalue)))) - :accessor kidvalues - :initarg :kidvalues) - - (kvkey :initform #'identity - :initarg :kvkey - :reader kvkey) - - (kvkeytest :initform #'equal - :initarg :kvkeytest - :reader kvkeytest) - - (kidfactory :cell t - :initform #'identity - :initarg :kidfactory - :reader kidfactory) - - (.kids :cell t - :initform (c? (assert (listp (kidvalues self))) - (let ((newkids (mapcan (lambda (kidvalue) - (list (or (find kidvalue .cache - :key (kvkey self) - :test (kvkeytest self)) - (trc nil "family-values forced to make new kid" - self .cache kidvalue) - (funcall (kidfactory self) self kidvalue)))) - (^kidvalues)))) - (nconc (mapcan (lambda (oldkid) - (unless (find oldkid newkids) - (when (fv-kid-keep self oldkid) - (list oldkid)))) - .cache) - newkids))) - :accessor kids - :initarg :kids))) - -(defmethod fv-kid-keep (family oldkid) - (declare (ignorable family oldkid)) - nil) - -(defmodel family-values-sorted (family-values) - ((sortedkids :initarg :sortedkids :accessor sortedkids - :initform nil) - (sortmap :initform (cv nil) :initarg :sortmap :accessor sortmap) - (.kid-slots :cell t - :initform (c? (assert (listp (kidvalues self))) - (mapsort (^sortmap) - (thekids - (mapcar (lambda (kidvalue) - (trc "making kid" kidvalue) - (or (find kidvalue .cache :key (kvkey self) :test (kvkeytest self)) - (trc nil "family-values forced to make new kid" self .cache kidvalue) - (funcall (kidfactory self) self kidvalue))) - (^kidvalues))))) - :accessor kid-slots - :initarg :kid-slots))) - -(defun mapsort (map data) - ;;(trc "mapsort map" map) - (if map - (stable-sort data #'< :key (lambda (datum) (or (position datum map) - ;(trc "mapsort datum not in map" datum) - (1+ (length data))))) - data)) - -(def-c-echo sortedkids () - (setf (sortmap self) new-value)) ;; cellular trick to avoid cyclicity - +;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- +;;; +;;; Copyright (c) 1995,2003 by Kenneth William Tilton. +;;; +;;; Permission is hereby granted, free of charge, to any person obtaining a copy +;;; of this software and associated documentation files (the "Software"), to deal +;;; in the Software without restriction, including without limitation the rights +;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +;;; copies of the Software, and to permit persons to whom the Software is furnished +;;; to do so, subject to the following conditions: +;;; +;;; The above copyright notice and this permission notice shall be included in +;;; all copies or substantial portions of the Software. +;;; +;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS +;;; IN THE SOFTWARE. + +(in-package :cells) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (export '(family-values family-values-sorted + sortindex sortdirection sortpredicate sortkey + ^sortindex ^sortdirection ^sortpredicate ^sortkey))) + +(defmodel family-values (family) + ( + (kvcollector :initarg :kvcollector + :initform #'identity + :reader kvcollector) + + (kidvalues :cell t + :initform (c? (when (kvcollector self) + (funcall (kvcollector self) (^md-value)))) + :accessor kidvalues + :initarg :kidvalues) + + (kvkey :initform #'identity + :initarg :kvkey + :reader kvkey) + + (kvkeytest :initform #'equal + :initarg :kvkeytest + :reader kvkeytest) + + (kidfactory :cell t + :initform #'identity + :initarg :kidfactory + :reader kidfactory) + + (.kids :cell t + :initform (c? (c-assert (listp (kidvalues self))) + (let ((newkids (mapcan (lambda (kidvalue) + (list (or (find kidvalue .cache + :key (kvkey self) + :test (kvkeytest self)) + (trc nil "family-values forced to make new kid" + self .cache kidvalue) + (funcall (kidfactory self) self kidvalue)))) + (^kidvalues)))) + (nconc (mapcan (lambda (oldkid) + (unless (find oldkid newkids) + (when (fv-kid-keep self oldkid) + (list oldkid)))) + .cache) + newkids))) + :accessor kids + :initarg :kids))) + +(defmethod fv-kid-keep (family oldkid) + (declare (ignorable family oldkid)) + nil) + +(defmodel family-values-sorted (family-values) + ((sortedkids :initarg :sortedkids :accessor sortedkids + :initform nil) + (sortmap :initform (cv nil) :initarg :sortmap :accessor sortmap) + (.kids :cell t + :initform (c? (c-assert (listp (kidvalues self))) + (mapsort (^sortmap) + (thekids + (mapcar (lambda (kidvalue) + (trc "making kid" kidvalue) + (or (find kidvalue .cache :key (kvkey self) :test (kvkeytest self)) + (trc nil "family-values forced to make new kid" self .cache kidvalue) + (funcall (kidfactory self) self kidvalue))) + (^kidvalues))))) + :accessor kids + :initarg :kids))) + +(defun mapsort (map data) + ;;(trc "mapsort map" map) + (if map + (stable-sort data #'< :key (lambda (datum) (or (position datum map) + ;(trc "mapsort datum not in map" datum) + (1+ (length data))))) + data)) + +(def-c-echo sortedkids () + (setf (sortmap self) new-value)) ;; cellular trick to avoid cyclicity +

Index: cells/family.lisp diff -u cells/family.lisp:1.1.1.1 cells/family.lisp:1.2 --- cells/family.lisp:1.1.1.1 Sat Nov 8 18:44:05 2003 +++ cells/family.lisp Tue Dec 16 10:02:58 2003 @@ -1,240 +1,261 @@ -;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- -;;; -;;; Copyright © 1995,2003 by Kenneth William Tilton. -;;; -;;; Permission is hereby granted, free of charge, to any person obtaining a copy -;;; of this software and associated documentation files (the "Software"), to deal -;;; in the Software without restriction, including without limitation the rights -;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell -;;; copies of the Software, and to permit persons to whom the Software is furnished -;;; to do so, subject to the following conditions: -;;; -;;; The above copyright notice and this permission notice shall be included in -;;; all copies or substantial portions of the Software. -;;; -;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING -;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS -;;; IN THE SOFTWARE. - -(in-package :cells) - -(eval-when (:compile-toplevel :execute :load-toplevel) - (export '(model mdvalue family kids kid1 perishable))) - -(defmodel model () - ((.mdvalue :initform nil :accessor mdvalue :initarg :mdvalue))) - -(defmodel perishable () - ((expiration :initform nil :accessor expiration :initarg :expiration))) - -(def-c-echo expiration () - (when new-value - (not-to-be self))) - -(defmodel family (model) - ((.kids :cell t - :initform (cv nil) ;; most useful - :accessor kids - :initarg :kids) - (.kid-slots :cell t - :initform nil - :accessor kid-slots - :initarg :kid-slots))) - -(defmacro thekids (&rest kids) - `(packed-flat! ,@(mapcar (lambda (kid) - (typecase kid - (keyword `(make-instance ',(intern$ (symbol-name kid)))) - (t `,kid))) - kids))) - -(defmacro thekids2 (&rest kids) - `(packed-flat! ,@(mapcar (lambda (kid) - (typecase kid - (keyword `(make-instance ',(intern$ (symbol-name kid)))) - (t `,kid))) - kids))) - -(defun kid1 (self) (car (kids self))) - -;; /// redundancy in following - -(defmacro psib (&optional (selfform 'self)) - (let ((self (gensym))) - `(bwhen (,self ,selfform) - (find-prior ,self (kids (fmparent ,self)))))) - -(defmacro nsib (&optional (selfform 'self)) - (let ((self (gensym))) - `(bwhen (,self ,selfform) - (cadr (member ,self (kids (fmparent ,self))))))) - -(defmacro ^priorSib (self) - (let ((kid (gensym))) - `(let* ((,kid ,self)) - (find-prior ,kid (^kids (fmParent ,kid)))))) - -(defmacro ^firstKidP (self) - (let ((kid (gensym))) - `(let ((,kid ,self)) - (eql ,kid (car (^kids (fmParent ,kid))))))) - -(defmacro ^lastKidP (self) - (let ((kid (gensym))) - `(let ((,kid ,self)) - (null (cdr (member ,kid (^kids (fmParent ,kid)))))))) - -(defun md-adopt (fmparent self) - (assert self) - (assert fmparent) - (assert (typep fmparent 'family)) - - (trc nil "md-adopt >" :by fmparent) - - (let ((currparent (fmparent self)) - (selftype (type-of self))) - (assert (or (null currparent) - (eql fmparent currparent))) - (unless (plusp (adopt-ct self)) - (incf (adopt-ct self)) - (setf (fmparent self) fmparent) - - (bwhen (kid-slots-fn (kid-slots (fmparent self))) - (dolist (ksdef (funcall kid-slots-fn self) self) - (let ((slot-name (ksname ksdef))) - (trc nil "got ksdef " slot-name) - (when (md-slot-cell-type selftype slot-name) - (trc nil "got cell type " slot-name) - (when (or (not (ksifmissing ksdef)) - (and (null (c-slot-value self slot-name)) - (null (md-slot-cell self slot-name)))) - (trc nil "ks missing ok " slot-name) - (multiple-value-bind (c-or-value suppressp) - (funcall (ksrule ksdef) self) - (unless suppressp - (trc nil "c-install " slot-name c-or-value) - (c-install self slot-name c-or-value)))))))) - - ; new for 12/02... - (md-adopt-kids self))) - self) - -(defmethod md-adopt-kids (self) (declare (ignorable self))) -(defmethod md-adopt-kids ((self family)) - (when (slot-boundp self '.kids) - (dolist (k (slot-value self '.kids)) - (unless (fmParent k) - (md-adopt self k))))) - - - - -(defmethod c-slot-value ((self model-object) slot) - (slot-value self slot)) - -(defun md-kids-change (self new-kids old-kids usage) - (assert (listp new-kids)) - (assert (listp old-kids)) - (assert (not (member nil old-kids))) - (assert (not (member nil new-kids))) - - (trc nil "md-kids-change > entry" usage new-kids old-kids) - #+nah (when (and (trcp (car new-kids)) - (eql usage :md-slot-value-assume)) - (break "how here? ~a" self)) - - (dolist (k old-kids) - (unless (member k new-kids) - (trc nil "kids change nailing lost kid" k) - (not-to-be k) - (setf (fmparent k) nil) ;; 020302kt unnecessary? anyway, after not-to-be since that might require fmparent - )) - - (dolist (k new-kids) - (unless (member k old-kids) - (if (eql :nascent (md-state k)) - (progn - #+dfdbg (trc k "adopting par,k:" self k) - (md-adopt self k)) - (unless (eql self (fmParent k)) - ;; 230126 recent changes to kids handling leads to dup kids-change calls - (trc "feature not yet implemented: adopting previously adopted: parent, kid" self (type-of k)) - (trc "old" old-kids) - (trc "new" new-kids) - (break "bad state extant nkid ~a ~a ~a" usage k (md-state k)) - ))))) - -(def-c-echo .kids ((self family)) - (dolist (k new-value) - (to-be k))) - -(defun md-reinitialize (self) - (unless (eql (md-state self) :nascent) - (setf (md-state self) :nascent) - (md-reinitialize-primary self))) - -(defmethod md-reinitialize-primary :after ((self family)) - (dolist (kid (slot-value self '.kids)) ;; caused re-entrance to c? (kids self)) - (md-reinitialize kid))) - -(defmethod md-reinitialize-primary (self) - (cellbrk) - (md-map-cells self nil (lambda (c) - (setf (c-waking-state c) nil) - (when (typep c 'c-ruled) - (setf (c-state c) :unbound))))) - -(defmethod kids ((other model-object)) nil) - -(defmethod not-to-be :before ((fm family)) - (unless (md-untouchable fm) - (trc nil "(not-to-be :before family) not closed stream, backdooropen; kids c-awake; kids c-state" - *svuc-backdoor-open* - (if (md-slot-cell fm '.kids) - (c-waking-state (md-slot-cell fm '.kids)) - :no-kids-cell) - (when (md-slot-cell fm '.kids) - (c-state (md-slot-cell fm 'kids)))) - ;; use backdoor so if kids not yet ruled into - ;; existence they won't be now just to not-to-be them - (let ((svkids (slot-value fm '.kids))) - (when (listp svkids) - (dolist ( kid svkids) - (not-to-be kid))))) - - (trc nil "(not-to-be :before family) exit, kids state" (when (md-slot-cell fm 'kids) - (c-state (md-slot-cell fm 'kids))))) - - -;------------------ kid slotting ---------------------------- -; -(cc-defstruct (kid-slotdef - (:conc-name nil)) - ksname - ksrule - (ksifmissing t)) - -(defmacro mk-kid-slot ((ksname &key ifmissing) ksrule) - `(make-kid-slotdef - :ksname ',ksname - :ksrule (lambda (self) - (declare (ignorable self)) - ,ksrule) - :ksifmissing ,ifmissing)) - -(defmacro def-kid-slots (&rest slot-defs) - `(lambda (self) - (declare (ignorable self)) - (list ,@slot-defs))) - -(defmethod md-name (symbol) - symbol) - -(defmethod md-name ((nada null)) - (unless *stop* - (setq *stop* t) - (break "md-name called on nil"))) \ No newline at end of file +;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- +;;; +;;; Copyright (c) 1995,2003 by Kenneth William Tilton. +;;; +;;; Permission is hereby granted, free of charge, to any person obtaining a copy +;;; of this software and associated documentation files (the "Software"), to deal +;;; in the Software without restriction, including without limitation the rights +;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +;;; copies of the Software, and to permit persons to whom the Software is furnished +;;; to do so, subject to the following conditions: +;;; +;;; The above copyright notice and this permission notice shall be included in +;;; all copies or substantial portions of the Software. +;;; +;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS +;;; IN THE SOFTWARE. + +(in-package :cells) + +(eval-when (:compile-toplevel :execute :load-toplevel) + (export '(model md-value family kids kid1 perishable))) + +(defmodel model () + ((.md-name :cell nil :initform nil :initarg :md-name :accessor md-name) + (.fm-parent :cell nil :initform nil :initarg :fm-parent :accessor fm-parent) + (.md-value :initform nil :accessor md-value :initarg :md-value))) + +(defmethod print-object ((self model) s) + (format s "~a" (or (md-name self) (type-of self)))) + +(define-symbol-macro .parent (fm-parent self)) + +(defmethod md-initialize :around ((self model)) + (when (slot-boundp self '.md-name) + (unless (md-name self) + (setf (md-name self) (c-class-name (class-of self))))) + + (when (fm-parent self) + (md-adopt (fm-parent self) self)) + + (call-next-method)) + +(defmodel perishable () + ((expiration :initform nil :accessor expiration :initarg :expiration))) + +(def-c-echo expiration () + (when new-value + (not-to-be self))) + +(defmodel family (model) + ((.kid-slots :cell nil + :initform nil + :accessor kid-slots + :initarg :kid-slots) + (.kids :initform (cv nil) ;; most useful + :accessor kids + :initarg :kids) + )) + +(defmacro thekids (&rest kids) + `(packed-flat! ,@(mapcar (lambda (kid) + (typecase kid + (keyword `(make-instance ',(intern$ (symbol-name kid)))) + (t `,kid))) + kids))) + +(defmacro thekids2 (&rest kids) + `(packed-flat! ,@(mapcar (lambda (kid) + (typecase kid + (keyword `(make-instance ',(intern$ (symbol-name kid)))) + (t `,kid))) + kids))) + +(defun kid1 (self) (car (kids self))) +(defun lastkid (self) (last1 (kids self))) + +;; /// redundancy in following + +(defmacro psib (&optional (selfform 'self)) + (let ((self (gensym))) + `(bwhen (,self ,selfform) + (find-prior ,self (kids (fm-parent ,self)))))) + +(defmacro nsib (&optional (selfform 'self)) + (let ((self (gensym))) + `(bwhen (,self ,selfform) + (cadr (member ,self (kids (fm-parent ,self))))))) + +(defmacro ^priorSib (self) + (let ((kid (gensym))) + `(let* ((,kid ,self)) + (find-prior ,kid (^kids (fm-parent ,kid)))))) + +(defmacro ^firstKidP (self) + (let ((kid (gensym))) + `(let ((,kid ,self)) + (eql ,kid (car (^kids (fm-parent ,kid))))))) + +(defmacro ^lastKidP (self) + (let ((kid (gensym))) + `(let ((,kid ,self)) + (null (cdr (member ,kid (^kids (fm-parent ,kid)))))))) + +(defun md-adopt (fm-parent self) + (c-assert self) + (c-assert fm-parent) + (c-assert (typep fm-parent 'family)) + + + (trc nil "md-adopt >" :kid self (adopt-ct self) :by fm-parent) + + (let ((currparent (fm-parent self)) + (selftype (type-of self))) + (c-assert (or (null currparent) + (eql fm-parent currparent))) + ;; (when (plusp (adopt-ct self))(c-break "2nd adopt ~a, by ~a" self fm-parent)) + (unless (plusp (adopt-ct self)) + (incf (adopt-ct self)) + (setf (fm-parent self) fm-parent) + + (bwhen (kid-slots-fn (kid-slots (fm-parent self))) + (dolist (ksdef (funcall kid-slots-fn self) self) + (let ((slot-name (ksname ksdef))) + (trc nil "got ksdef " slot-name) + (when (md-slot-cell-type selftype slot-name) + (trc fm-parent "got cell type " slot-name) + (when (or (not (ksifmissing ksdef)) + (and (null (c-slot-value self slot-name)) + (null (md-slot-cell self slot-name)))) + (trc fm-parent "ks missing ok " slot-name) + (multiple-value-bind (c-or-value suppressp) + (funcall (ksrule ksdef) self) + (unless suppressp + (trc fm-parent "c-install " slot-name c-or-value) + (c-install self slot-name c-or-value)))))))) + + ; new for 12/02... + (md-adopt-kids self))) + self) + +(defmethod md-adopt-kids (self) (declare (ignorable self))) +(defmethod md-adopt-kids ((self family)) + (when (slot-boundp self '.kids) + (dolist (k (slot-value self '.kids)) + (unless (fm-parent k) + (md-adopt self k))))) + + + + +(defmethod c-slot-value ((self model-object) slot) + (slot-value self slot)) + +(defun md-kids-change (self new-kids old-kids usage) + (c-assert (listp new-kids)) + (c-assert (listp old-kids)) + (c-assert (not (member nil old-kids))) + (c-assert (not (member nil new-kids))) + + (trc nil "md-kids-change > entry" usage new-kids old-kids) + #+nah (when (and (trcp (car new-kids)) + (eql usage :md-slot-value-assume)) + (break "how here? ~a" self)) + + (dolist (k old-kids) + (unless (member k new-kids) + (trc nil "kids change nailing lost kid" k) + (not-to-be k) + (setf (fm-parent k) nil) ;; 020302kt unnecessary? anyway, after not-to-be since that might require fm-parent + )) + + (dolist (k new-kids) + (unless (member k old-kids) + (if (eql :nascent (md-state k)) + (progn + #+dfdbg (trc k "adopting par,k:" self k) + (md-adopt self k)) + (unless (eql self (fm-parent k)) + ;; 230126 recent changes to kids handling leads to dup kids-change calls + (trc "feature not yet implemented: adopting previously adopted: parent, kid" self (type-of k)) + (trc "old" old-kids) + (trc "new" new-kids) + (break "bad state extant nkid ~a ~a ~a" usage k (md-state k)) + ))))) + +(def-c-echo .kids ((self family)) + (dolist (k new-value) + (to-be k))) + +(defun md-reinitialize (self) + (unless (eql (md-state self) :nascent) + (setf (md-state self) :nascent) + (md-reinitialize-primary self))) + +(defmethod md-reinitialize-primary :after ((self family)) + (dolist (kid (slot-value self '.kids)) ;; caused re-entrance to c? (kids self)) + (md-reinitialize kid))) + +(defmethod md-reinitialize-primary (self) + (cellbrk) + (md-map-cells self nil (lambda (c) + (setf (c-waking-state c) nil) + (when (typep c 'c-ruled) + (setf (c-state c) :unbound))))) + +(defmethod kids ((other model-object)) nil) + +(defmethod not-to-be :before ((fm family)) + (unless (md-untouchable fm) + (trc nil "(not-to-be :before family) not closed stream, backdooropen; kids c-awake; kids c-state" + *svuc-backdoor-open* + (if (md-slot-cell fm '.kids) + (c-waking-state (md-slot-cell fm '.kids)) + :no-kids-cell) + (when (md-slot-cell fm '.kids) + (c-state (md-slot-cell fm 'kids)))) + ;; use backdoor so if kids not yet ruled into + ;; existence they won't be now just to not-to-be them + (let ((svkids (slot-value fm '.kids))) + (when (listp svkids) + (dolist ( kid svkids) + (not-to-be kid))))) + + (trc nil "(not-to-be :before family) exit, kids state" (when (md-slot-cell fm 'kids) + (c-state (md-slot-cell fm 'kids))))) + + +;------------------ kid slotting ---------------------------- +; +(defstruct (kid-slotdef + (:conc-name nil)) + ksname + ksrule + (ksifmissing t)) + +(defmacro mk-kid-slot ((ksname &key ifmissing) ksrule) + `(make-kid-slotdef + :ksname ',ksname + :ksrule (lambda (self) + (declare (ignorable self)) + ,ksrule) + :ksifmissing ,ifmissing)) + +(defmacro def-kid-slots (&rest slot-defs) + `(lambda (self) + (declare (ignorable self)) + (list ,@slot-defs))) + +(defmethod md-name (symbol) + symbol) + +(defmethod md-name ((nada null)) + (unless (c-stopped) + (c-stop :md-name-on-null) + (break "md-name called on nil"))) +

Index: cells/flow-control.lisp diff -u cells/flow-control.lisp:1.1.1.1 cells/flow-control.lisp:1.2 --- cells/flow-control.lisp:1.1.1.1 Sat Nov 8 18:44:17 2003 +++ cells/flow-control.lisp Tue Dec 16 10:02:58 2003 @@ -1,169 +1,155 @@ -;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- -;;; -;;; -;;; Copyright © 1995,2003 by Kenneth William Tilton. -;;; -;;; Permission is hereby granted, free of charge, to any person obtaining a copy -;;; of this software and associated documentation files (the "Software"), to deal -;;; in the Software without restriction, including without limitation the rights -;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell -;;; copies of the Software, and to permit persons to whom the Software is furnished -;;; to do so, subject to the following conditions: -;;; -;;; The above copyright notice and this permission notice shall be included in -;;; all copies or substantial portions of the Software. -;;; -;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING -;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS -;;; IN THE SOFTWARE. - -(in-package :cells) - -(defmacro maxf (place &rest othervalues) - `(setf ,place (max ,place ,@othervalues))) - -(defun last1 (thing) - (car (last thing))) - -(defun max-if (&rest values) - (loop for x in values when x maximize x)) - -(defun min-max-of (v1 v2) - (values (min-if v1 v2) (max-if v1 v2))) - -(defun min-if (v1 v2) - (if v1 (if v2 (min v1 v2) v1) v2)) - -(defun list-flatten! (&rest list) - (if (consp list) - (let (head work visited) - (labels ((link (cell) - ;;(format t "~&Link > cons: ~s . ~s" (car cell) (cdr cell)) - (when (and (consp cell) - (member cell visited)) - (break "list-flatten! detects infinite list: cell ~a, visited ~a" cell visited)) - (push cell visited) - - (when cell - (if (consp (car cell)) - (link (car cell)) - (progn - (setf head (or head cell)) - (when work - (rplacd work cell)) - (setf work cell))) - (link (rest cell))))) - (link list)) - head) - list)) - -(defun packed-flat! (&rest uNameit) - (delete-if #'null (list-flatten! uNameIt))) - -(defmacro with-dynamic-fn ((fnName (&rest fnArgs) &body fnBody) &body body) - `(let ((,fnName (lambda ,fnArgs ,@fnBody))) - (declare (dynamic-extent ,fnname)) - ,@body)) - -(eval-when (compile load eval) - (export 'myAssert)) - -(defmacro myAssert (assertion &optional places fmt$ &rest fmtargs) - (declare (ignore places)) - - `(unless *stop* - (unless ,assertion - (setf *stop* t) - ,(if fmt$ - `(mybreak ,fmt$ ,@fmtargs) - `(mybreak "failed assertion:" ',assertion))))) - -(defvar *mybreak*) - -(defun mybreak (&rest args) - (unless (or *mybreak* *stop*) - (setf *mybreak* t) - (setf *stop* t) - (format t "mybreak > stopping > ~a" args) - (apply #'break args))) - -(defun assocv (sym assoc) - (cdr (assoc sym assoc))) - -(defmacro assocv-setf (assoc-place sym-form v) - (let ((sym (gensym))(entry (gensym))) - `(let ((,sym ,sym-form)) - (bIf (,entry (assoc ,sym ,assoc-place)) - (rplacd ,entry ,v) - (push (cons ,sym ,v) ,assoc-place))))) - -(defun intern$ (&rest strings) - (intern (apply #'concatenate 'string (mapcar #'string-upcase strings)))) - -#-allegro -(defmacro until (test &body body) - `(LOOP (WHEN ,test (RETURN)) ,@body)) - -#-allegro -(defmacro while (test &body body) - `(LOOP (unless ,test (RETURN)) ,@body)) - -(defmacro bwhen ((bindvar boundform) &body body) - `(let ((,bindvar ,boundform)) - (when ,bindvar - ,@body))) - -(defmacro bif ((bindvar boundform) yup &optional nope) - `(let ((,bindvar ,boundform)) - (if ,bindvar - ,yup - ,nope))) - -(defmacro maptimes ((nvar count) &body body) - `(loop for ,nvar below ,count - collecting (progn ,@body))) - -; --- cloucell support for struct access of slots ------------------------ - -(eval-when (:compile-toplevel :execute :load-toplevel) - (export '(cc-defstruct instance-slots))) - -(defmacro cc-defstruct (header &rest slots) - (let (name concname (cache (gensym))) - (if (consp header) - (destructuring-bind (hname &rest options) - header - (setf name hname) - (setf concname (bIf (concoption (find :conc-name options :key #'car)) - (unless (eql (second concoption) 'nil) - (second concoption)) - (intern (concatenate 'string - (symbol-name hname) - "-"))))) - (progn - (setf name header) - (setf concname (intern (concatenate 'string - (symbol-name header) "-"))))) - - (let ((cc-info (mapcar (lambda (s) - (let ((sn (if (consp s) - (car s) s))) - (cons sn - (intern (concatenate 'string - (when concname (symbol-name concname)) - (symbol-name sn)))))) - slots))) - `(progn - (defstruct ,header ,@slots) - (let (,cache) - (defmethod instance-slots ((self ,name)) - (or ,cache (setf ,cache (append (call-next-method) ',cc-info))))) - )))) - -(defmethod instance-slots (root) - (declare (ignorable root))) - +;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- +;;; +;;; +;;; Copyright (c) 1995,2003 by Kenneth William Tilton. +;;; +;;; Permission is hereby granted, free of charge, to any person obtaining a copy +;;; of this software and associated documentation files (the "Software"), to deal +;;; in the Software without restriction, including without limitation the rights +;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +;;; copies of the Software, and to permit persons to whom the Software is furnished +;;; to do so, subject to the following conditions: +;;; +;;; The above copyright notice and this permission notice shall be included in +;;; all copies or substantial portions of the Software. +;;; +;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS +;;; IN THE SOFTWARE. + +(in-package :cells) + +(defmacro maxf (place &rest othervalues) + `(setf ,place (max ,place ,@othervalues))) + +(defun last1 (thing) + (car (last thing))) + +(defun max-if (&rest values) + (loop for x in values when x maximize x)) + +(defun min-max-of (v1 v2) + (values (min-if v1 v2) (max-if v1 v2))) + +(defun min-if (v1 v2) + (if v1 (if v2 (min v1 v2) v1) v2)) + +(defun list-flatten! (&rest list) + (if (consp list) + (let (head work visited) + (labels ((link (cell) + ;;(format t "~&Link > cons: ~s . ~s" (car cell) (cdr cell)) + (when (and (consp cell) + (member cell visited)) + (break "list-flatten! detects infinite list: cell ~a, visited ~a" cell visited)) + (push cell visited) + + (when cell + (if (consp (car cell)) + (link (car cell)) + (progn + (setf head (or head cell)) + (when work + (rplacd work cell)) + (setf work cell))) + (link (rest cell))))) + (link list)) + head) + list)) + +(defun packed-flat! (&rest uNameit) + (delete-if #'null (list-flatten! uNameIt))) + +(defmacro with-dynamic-fn ((fnName (&rest fnArgs) &body fnBody) &body body) + `(let ((,fnName (lambda ,fnArgs ,@fnBody))) + (declare (dynamic-extent ,fnname)) + ,@body)) + +(defvar *c-break*) + +(defun c-break (&rest args) + (unless (or *c-break* *stop*) + (setf *c-break* t) + (c-stop args) + (format t "c-break > stopping > ~a" args) + (apply #'break args))) + +(defmacro assocv-setf (assoc-place sym-form v-form) + (let ((sym (gensym))(entry (gensym))(v (gensym))) + `(let* ((,sym ,sym-form) + (,v ,v-form)) + (bIf (,entry (assoc ,sym ,assoc-place)) + (rplacd ,entry ,v) + (push (cons ,sym ,v) ,assoc-place)) + ,v))) + +(defun intern$ (&rest strings) + (intern (apply #'concatenate 'string (mapcar #'string-upcase strings)))) + +#-allegro +(defmacro until (test &body body) + `(LOOP (WHEN ,test (RETURN)) ,@body)) + +#-allegro +(defmacro while (test &body body) + `(LOOP (unless ,test (RETURN)) ,@body)) + +(defmacro bwhen ((bindvar boundform) &body body) + `(let ((,bindvar ,boundform)) + (when ,bindvar + ,@body))) + +(defmacro bif ((bindvar boundform) yup &optional nope) + `(let ((,bindvar ,boundform)) + (if ,bindvar + ,yup + ,nope))) + +(defmacro maptimes ((nvar count) &body body) + `(loop for ,nvar below ,count + collecting (progn ,@body))) + +; --- cloucell support for struct access of slots ------------------------ + +(eval-when (:compile-toplevel :execute :load-toplevel) + (export '(cc-defstruct instance-slots))) + +(defmacro cc-defstruct (header &rest slots) + (let (name concname (cache (gensym))) + (if (consp header) + (destructuring-bind (hname &rest options) + header + (setf name hname) + (setf concname (bIf (concoption (find :conc-name options :key #'car)) + (unless (eql (second concoption) 'nil) + (second concoption)) + (intern (concatenate 'string + (symbol-name hname) + "-"))))) + (progn + (setf name header) + (setf concname (intern (concatenate 'string + (symbol-name header) "-"))))) + + (let ((cc-info (mapcar (lambda (s) + (let ((sn (if (consp s) + (car s) s))) + (cons sn + (intern (concatenate 'string + (when concname (symbol-name concname)) + (symbol-name sn)))))) + slots))) + `(progn + (defstruct ,header ,@slots) + (let (,cache) + (defmethod instance-slots ((self ,name)) + (or ,cache (setf ,cache (append (call-next-method) ',cc-info))))) + )))) + +(defmethod instance-slots (root) + (declare (ignorable root))) +

Index: cells/fm-utilities.lisp diff -u cells/fm-utilities.lisp:1.1.1.1 cells/fm-utilities.lisp:1.2 --- cells/fm-utilities.lisp:1.1.1.1 Sat Nov 8 18:44:17 2003 +++ cells/fm-utilities.lisp Tue Dec 16 10:02:58 2003 @@ -1,557 +1,557 @@ -;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- -;;; -;;; Copyright © 1995,2003 by Kenneth William Tilton. -;;; -;;; Permission is hereby granted, free of charge, to any person obtaining a copy -;;; of this software and associated documentation files (the "Software"), to deal -;;; in the Software without restriction, including without limitation the rights -;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell -;;; copies of the Software, and to permit persons to whom the Software is furnished -;;; to do so, subject to the following conditions: -;;; -;;; The above copyright notice and this permission notice shall be included in -;;; all copies or substantial portions of the Software. -;;; -;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING -;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS -;;; IN THE SOFTWARE. - -(in-package :cells) - -(defparameter *fmdbg* nil) - -(eval-when (compile eval load) - (export '(make-part mkpart fm-other fm-traverse fm-descendant-typed do-like-fm-parts - container-typed *fmdbg*))) - -(defun make-part (partname partclass &rest initargs) - ;;(trc "make-part > name class" partname partclass) - (when partclass ;;a little programmer friendliness - (apply #'make-instance partclass :md-name partname initargs))) - -(defmacro mkpart (md-name (mdclass) &rest initargs) - `(make-part ',md-name ',mdclass ,@initargs)) - -(defmethod make-partspec ((partclass symbol)) - (make-part partclass partclass)) - -(defmethod make-partspec ((part model)) - part) - -(defmacro upper (self &optional (type t)) - `(container-typed ,self ',type)) - -(defmethod container (self) (fmparent self)) - -(defmethod container-typed ((self model-object) type) - (assert self) - (let ((parent (container self))) ;; fm- or ps-parent - (cond - ((null parent) nil) - ((typep parent type) parent) - (t (container-typed parent type))))) - -(defun fm-descendant-typed (self type) - (when self - (or (find-if (lambda (k) (typep k type)) (kids self)) - (some (lambda (k) - (fm-descendant-typed k type)) (kids self))))) - -(defun fm-descendant-named (parent name &key (must-find t)) - (fm-find-one parent name :must-find must-find :global-search nil)) - -(defun fm-ascendant-named (parent name) - (when parent - (or (when (eql (md-name parent) name) - parent) - (fm-ascendant-named (fmparent parent) name)))) - -(defun fm-ascendant-typed (parent name) - (when parent - (or (when (typep parent name) - parent) - (fm-ascendant-typed (fmparent parent) name)))) - -(defun fm-ascendant-some (parent somefunction) - (when (and parent somefunction) - (or (funcall somefunction parent) - (fm-ascendant-some (fmparent parent) somefunction)))) - -(defun fm-ascendant-if (self iffunction) - (when (and self iffunction) - (or (when (funcall iffunction self) - self) - (fm-ascendant-if .parent iffunction)))) - -(defun fm-ascendant-common (d1 d2) - (fm-ascendant-some d1 (lambda (node) - (when (fm-includes node d2) - node)))) - -(defun fm-collect-if (tree test) - (let (collection) - (fm-traverse tree (lambda (node) - (when (funcall test node) - (push node collection)))) - (nreverse collection))) - -(defun fm-max (tree key) - (let (max) - (fm-traverse tree (lambda (node) - (if max - (setf max (max max (funcall key node))) - (setf max (funcall key node)))) - :global-search nil) - max)) - - -(defun fm-traverse (family applied-fn &key skipnode skiptree (global-search t) (opaque nil)) - (progn ;; wtrc (0 1600 "fm-traverse2" family) - (labels ((tv-family (fm skippee) - (when *fmdbg* (trc "tv-family" fm)) - - (when (and (typep fm 'model-object) - (not (eql fm skippee))) - (let ((outcome (unless (eql skipnode fm) - (funcall applied-fn fm)))) - (unless (and outcome opaque) - (dolist (kid (sub-nodes fm)) - (tv-family kid nil))))) - (when (and (typep fm 'model-object) - (not (eql fm skippee))) - (let ((outcome (and (not (eql skipnode fm)) - (funcall applied-fn fm)))) - (unless (and outcome opaque) - (dolist (kid (sub-nodes fm)) - (tv-family kid nil))))))) - - (loop for fm = family then (when global-search (fmparent fm)) - and skip = skiptree then fm - unless fm return nil - do (when *fmdbg* (print `(fm-traverse using :fm , fm :skip ,skip))) - (tv-family fm skip))))) - -(defmethod sub-nodes (other) - (declare (ignore other))) - -(defmethod sub-nodes ((self family)) - (kids self)) - -(defmethod fm-ps-parent ((self model-object)) - (fmparent self)) - -(defmacro with-like-fm-parts ((partsvar (self likeclass)) &body body) - `(let (,partsvar) - (fm-traverse ,self (lambda (node) - ;;(trc "with like sees node" node (type-of node) ',likeclass) - (when (typep node ',likeclass) - (push node ,partsvar))) - :skipnode ,self - :global-search nil - :opaque t) - (setf ,partsvar (nreverse ,partsvar)) - (progn ,@body))) - -(defmacro do-like-fm-parts ((partvar (self likeclass) &optional returnvar) &body body) - `(progn - (fm-traverse ,self (lambda (,partvar) - (when (typep ,partvar ',likeclass) - ,@body)) - :skipnode ,self - :global-search nil - :opaque t) - ,returnvar) - ) - -;; -;; family member finding -;; - -#| - (defun fm-member-named (kidname kids) - (member kidname kids :key #'md-name)) - |# - -(defun true-that (that) (declare (ignore that)) t) -;; -;; eventually fm-find-all needs a better name (as does fm-collect) and they -;; should be modified to go through 'gather', which should be the real fm-find-all -;; -(defun fm-gather (family &key (test #'true-that)) - (packed-flat! - (cons (when (funcall test family) family) - (mapcar (lambda (fm) - (fm-gather fm :test test)) - (kids family))))) - -(defun fm-find-all (family md-name &key (must-find t) (global-search t)) - (let ((matches (catch 'fm-find-all - (with-dynamic-fn - (traveller (family) - (with-dynamic-fn - (filter (kid) (eql md-name (md-name kid))) - (let ((matches (remove-if-not filter (kids family)))) - (when matches - (throw 'fm-find-all matches))))) - (fm-traverse family traveller :global-search global-search))))) - (when (and must-find (null matches)) - (setf *stop* t) - (break "fm-find-all > *stop*ping...did not find ~a ~a ~a" family md-name global-search) - ;; (error 'fm-not-found (list md-name family global-search)) - ) - matches)) - -(defun fm-find-next (fm test-fn) - (fm-find-next-within fm test-fn)) - -(defun fm-find-next-within (fm test-fn &optional upperbound &aux (fmparent (unless (eql upperbound fm) - (fmparent fm)))) - (let ((sibs (and fmparent (rest (member fm (kids fmparent)))))) - (or (dolist (s sibs) - (let ((winner (fm-find-if s test-fn))) - (when winner (return winner)))) - (if fmparent - (fm-find-next-within fmparent test-fn upperbound) - (fm-find-if fm test-fn))))) - -(defun fm-find-prior (fm test-fn) - (fm-find-prior-within fm test-fn)) - -(defun fm-find-prior-within (fm test-fn &optional upperbound &aux (fmparent (unless (eql upperbound fm) - (fmparent fm)))) - (let ((sibs (and fmparent (kids fmparent)))) - (or (loop with next-ok - for s on sibs - for last-ok = nil then (or next-ok last-ok) - when (eql fm (first s)) do (loop-finish) - finally (return last-ok) - do (setf next-ok (fm-find-last-if (car s) test-fn))) - (if fmparent - (fm-find-prior-within fmparent test-fn upperbound) - (fm-find-last-if fm test-fn))))) - - (defun fm-find-last-if (family test-fn) - (let ((last)) - (or (and (kids family) - (dolist (k (kids family) last) - (setf last (or (fm-find-last-if k test-fn) last)))) - (when (funcall test-fn family) - family)))) - -(defun fm-prior-sib (self &optional (test-fn #'true-that) - &aux (kids (kids (fmparent self)))) - "Find nearest preceding sibling passing TEST-FN" - (find-if test-fn kids :end (position self kids) :from-end t)) - -(defun fm-next-sib-if (self test-fn) - (some test-fn (cdr (member self (kids (fmparent self)))))) - -(defun fm-next-sib (self) - (car (cdr (member self (kids (fmparent self)))))) - -(defmacro ^fm-next-sib (&optional (self 'self)) - (let ((s (gensym))) - `(let ((,s ,self)) - (car (cdr (member ,s (^kids (fmparent ,s)))))))) - -(defun find-prior (self sibs &key (test #'true-that)) - (assert (member self sibs)) ;; got this by accidentally having toolbar kids dependent..on second calc, - ;; all newkids got over, and when old kids tried to recalculate...not in sibs!! - (unless (eql self (car sibs)) - (labels - ((fpsib (rsibs &aux (psib (car rsibs))) - (assert rsibs () "~&find-prior > fpsib > self ~s not found to prior off" self) - (if (eql self (cadr rsibs)) - (when (funcall test psib) psib) - (or (fpsib (cdr rsibs)) - (when (funcall test psib) psib))))) - (fpsib sibs)))) - -(defun fm-find-if (family test-fn &key skiptopp) ;; 99-03 kt why is thsi depth-first? - (assert test-fn) - (when family - (or (dolist (b (sub-nodes family)) - (let ((match (fm-find-if b test-fn))) - (when match (return match)))) - (when (and (not skiptopp) - (funcall test-fn family)) - family)))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; -;;;; family ordering -;;;; -(defun fm-kid-add (fmparent kid &optional before) - (assert (or (null (fmparent kid)) (eql fmparent (fmparent kid)))) - (assert (typep fmparent 'family)) - (setf (fmparent kid) fmparent) - (fm-kid-insert kid before)) - -(defun fm-kid-insert-last (goal &aux (fmparent (fmparent goal))) - (setf (kids fmparent) (nconc (kids fmparent) (list goal)))) - -(defun fm-kid-insert-first (goal &aux (fmparent (fmparent goal))) - (setf (kids fmparent) (cons goal (kids fmparent)))) - -(defun fm-kid-insert (kid &optional before &aux (dakids (kids (fmparent kid)))) - (assert (or (null before) (eql (fmparent kid) (fmparent before)))) - (setf (kids (fmparent kid)) - (if before - (if (eql before (car dakids)) - (cons kid dakids) - (let ((cell (member before dakids))) - (rplaca cell kid) - (rplacd cell (cons before (cdr cell))) - (cons (car dakids) (rest dakids)))) - (if dakids - (progn - (rplacd (last dakids) (cons kid nil)) - (cons (car dakids) (rest dakids))) - (cons kid dakids))))) - -(defun fm-kid-remove (kid &key (quiesce t) &aux (parent (fmparent kid))) - (when quiesce - (fm-quiesce-all kid)) - (when parent - (setf (kids parent) (remove kid (kids parent))) - ;; (setf (fmparent kid) nil) gratuitous housekeeping caused ensuing focus echo - ;; image-invalidate to fail since no access to containing window via fmparent chain - )) - -(defun fm-quiesce-all (md) - (md-quiesce md) - (dolist (kid (kids md)) - (when (and kid (not (md-untouchable kid))) - (fm-quiesce-all kid))) - md) - - -(defun fm-kid-replace (oldkid newkid &aux (fmparent (fmparent oldkid))) - (assert (member oldkid (kids fmparent)) () - "~&oldkid ~s not amongst kids of its fmparent ~s" - oldkid fmparent) - (when fmparent ;; silly test given above assert--which is right? - (assert (typep fmparent 'family)) - (setf (fmparent newkid) fmparent) - (setf (kids fmparent) (substitute newkid oldkid (kids fmparent))) - ;;(rplaca (member oldkid (kids fmparent)) newkid) - newkid)) - -;---------------------------------------------------------- -;; -;; h i g h - o r d e r f a m i l y o p s -;; -;; currently not in use...someday? -(defmacro ^fm-min-max-kid (min-max slot-name &key (default 0) test (fmparent 'self)) - (let ((best (copy-symbol 'best)) - (kid (copy-symbol 'kid)) - ) - `(let ((,best ,default)) - (dolist (,kid (^kids ,fmparent) ,best) - ,(if test - `(when (funcall ,test ,kid) - (setf ,best (funcall ,min-max ,best (,slot-name ,kid)))) - `(bif (slotvalue (,slot-name ,kid)) - (setf ,best (funcall ,min-max ,best slotvalue)) - (break "nil slotvalue ~a in kid ~a of parent ~a" - ',slot-name ,kid ,fmparent))))))) - -(defmacro ^fm-min-kid (slot-name &key (default 0) test (fmparent 'self)) - `(^fm-min-max-kid #'min-if ,slot-name - :default ,default - :test ,test - :fmparent ,fmparent)) - -(defmacro ^fm-max-kid (slot-name &key (default 0) test (fmparent 'self)) - `(^fm-min-max-kid #'max-if ,slot-name - :default ,default - :test ,test - :fmparent ,fmparent)) - -(defmacro ^fm-max-sib (slot-name &key (default 0) test) - `(^fm-max-kid ,slot-name :default ,default - :test ,test - :fmparent (fmparent self))) - -(defmacro ^fm-max-sib-other (slot-name &key (default 0)) - `(with-dynamic-fn (tester (sib) (not (eql self sib))) - (^fm-max-kid ,slot-name :default ,default - :test tester - :fmparent (fmparent self)))) - -(defmacro ^sib-named (name) - `(find ,name (^kids (fmparent self)) :key #'md-name)) - - -(defmacro fm-other (md-name &key (starting 'self) skiptree (test '#'true-that)) - `(fm-find-one ,starting ,(if (consp md-name) - `(list ',(car md-name) ,(cadr md-name)) - `',md-name) - :must-find t - :skiptree ,skiptree - :global-search t - :test ,test)) - -(defmacro fm-otherx (md-name &key (starting 'self) skiptree) - (if (eql starting 'self) - `(or (fm-find-one ,starting ,(if (consp md-name) - `(list ',(car md-name) ,(cadr md-name)) - `',md-name) - :must-find t - :skiptree ,skiptree - :global-search t)) - `(fm-find-one ,starting ,(if (consp md-name) - `(list ',(car md-name) ,(cadr md-name)) - `',md-name) - :must-find t - :skiptree ,skiptree - :global-search t))) - -(defun fm-other-v (md-name starting &optional (global-search t)) - (break) - (fm-find-one starting md-name - :must-find nil - :global-search global-search)) - -(defmacro fm-otherv? (md-name &optional (starting 'self) (global-search t)) - `(fm-other-v ,md-name ,starting ,global-search)) - -(defmacro fm-other? (md-name &optional (starting 'self) (global-search t)) - `(fm-find-one ,starting ,(if (consp md-name) - `(list ',(car md-name) ,(cadr md-name)) - `',md-name) - :must-find nil - :global-search ,global-search)) - -(defun fm! (starting md-name &optional (global-search t)) - (fm-find-one starting md-name - :must-find t - :global-search global-search)) - -(defmacro fm? (md-name &optional (starting 'self) (global-search t)) - `(fm-find-one ,starting ,(if (consp md-name) - `(list ',(car md-name) ,(cadr md-name)) - `',md-name) - :must-find nil - :global-search ,global-search)) - -(defmacro fm-other! (md-name &optional (starting 'self)) - `(fm-find-one ,starting ,(if (consp md-name) - `(list ',(car md-name) ,(cadr md-name)) - `',md-name) - :must-find t - :global-search nil)) - -(defmacro fm-other?! (md-name &optional (starting 'self)) - `(fm-find-one ,starting ,(if (consp md-name) - `(list ',(car md-name) ,(cadr md-name)) - `',md-name) - :must-find nil - :global-search nil)) - -(defmacro fm-collect (md-name &key (must-find t)) - `(fm-find-all self ',md-name :must-find ,must-find)) ;deliberate capture - -(defmacro fm-map (fn md-name) - `(mapcar ,fn (fm-find-all self ',md-name))) ;deliberate capture - -(defmacro fm-mapc (fn md-name) - `(mapc ,fn (fm-find-all self ',md-name))) ;deliberate capture - -(defun fm-pos (goal &aux (fmparent (fmparent goal))) - (when fmparent - (or (position goal (kids fmparent)) - (length (kids fmparent))))) ;; ?!! - -(defmacro fm-count-named (family md-name &key (global-search t)) - `(length (fm-find-all ,family ,md-name - :must-find nil - :global-search ,global-search))) -;--------------------------------------------------------------- - -(defun fm-top (fm &optional (test #'true-that) &aux (fmparent (fmparent fm))) - (cond ((null fmparent) fm) - ((not (funcall test fmparent)) fm) - (t (fm-top fmparent test)))) - -(defun fm-first-above (fm &key (test #'true-that) &aux (fmparent (fmparent fm))) - (cond ((null fmparent) nil) - ((funcall test fmparent) fmparent) - (t (fm-first-above fmparent :test test)))) - -(defun fm-nearest-if (test fm) - (when fm - (if (funcall test fm) - fm - (fm-nearest-if test (fmparent fm))))) - -(defun fm-includes (fm sought) - (fm-ancestorp fm sought)) - -(defun fm-ancestorp (fm sought) - (assert fm) - (when sought - (or (eql fm sought) - (fm-includes fm (fmparent sought))))) - -(defun fm-kid-containing (fmparent descendant) - (with-dynamic-fn (finder (node) (not (eql fmparent node))) - (fm-top descendant finder))) - -(defun make-name (root &optional subscript) - (if subscript (list root subscript) root)) - -(defun name-root (md-name) - (if (atom md-name) md-name (car md-name))) - -(defun name-subscript (md-name) - (when (consp md-name) (cadr md-name))) - -(defun fm-find-one (family md-name &key (must-find t) - (global-search t) skiptree (test #'true-that)) - (flet ((matcher (fm) - (trc nil "fm-find-one matcher sees" md-name fm (md-name fm)) - (when (and (eql (name-root md-name) - (or (md-name fm) (c-class-name (class-of fm)))) - (or (null (name-subscript md-name)) - (eql (name-subscript md-name) (fm-pos fm))) - (funcall test fm)) - (throw 'fm-find-one fm)))) - #-lispworks (declare (dynamic-extent matcher)) - (trc nil "fm-find-one> entry " md-name family) - (let ((match (catch 'fm-find-one - (fm-traverse family #'matcher - :skiptree skiptree - :global-search global-search)))) - (when (and must-find (null match)) - (trc nil "fm-find-one > erroring fm-not-found" family md-name must-find global-search) - ;;(inspect family) - (let ((*fmdbg* family)) - (fm-find-one family md-name :must-find nil :global-search global-search) - (setf *stop* t) - ;;(trc "fm-find-one > *stop*ping...did not find" family md-name global-search) - (break "fm-find-one > *stop*ping...did not find ~a ~a ~a" family md-name global-search) - - )) - match))) - -(defun fm-find-kid (self name) - (find name (kids self) :key #'md-name)) - -(defun fm-kid-typed (self type) - (assert self) - (find type (kids self) :key #'type-of)) - -(defun kidno (self) - (unless (typep self 'model-object) - (break "not a model object ~a" self)) - (when (and self (fmparent self)) - (assert (member self (kids (fmparent self)))) - (position self (kids (fmparent self))))) - - +;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- +;;; +;;; Copyright (c) 1995,2003 by Kenneth William Tilton. +;;; +;;; Permission is hereby granted, free of charge, to any person obtaining a copy +;;; of this software and associated documentation files (the "Software"), to deal +;;; in the Software without restriction, including without limitation the rights +;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +;;; copies of the Software, and to permit persons to whom the Software is furnished +;;; to do so, subject to the following conditions: +;;; +;;; The above copyright notice and this permission notice shall be included in +;;; all copies or substantial portions of the Software. +;;; +;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS +;;; IN THE SOFTWARE. + +(in-package :cells) + +(defparameter *fmdbg* nil) + +(eval-when (compile eval load) + (export '(make-part mkpart fm-other fm-traverse fm-descendant-typed do-like-fm-parts + container-typed *fmdbg*))) + +(defun make-part (partname partclass &rest initargs) + ;;(trc "make-part > name class" partname partclass) + (when partclass ;;a little programmer friendliness + (apply #'make-instance partclass :md-name partname initargs))) + +(defmacro mkpart (md-name (mdclass) &rest initargs) + `(make-part ',md-name ',mdclass ,@initargs)) + +(defmethod make-partspec ((partclass symbol)) + (make-part partclass partclass)) + +(defmethod make-partspec ((part model)) + part) + +(defmacro upper (self &optional (type t)) + `(container-typed ,self ',type)) + +(defmethod container (self) (fm-parent self)) + +(defmethod container-typed ((self model-object) type) + (c-assert self) + (let ((parent (container self))) ;; fm- or ps-parent + (cond + ((null parent) nil) + ((typep parent type) parent) + (t (container-typed parent type))))) + +(defun fm-descendant-typed (self type) + (when self + (or (find-if (lambda (k) (typep k type)) (kids self)) + (some (lambda (k) + (fm-descendant-typed k type)) (kids self))))) + +(defun fm-descendant-named (parent name &key (must-find t)) + (fm-find-one parent name :must-find must-find :global-search nil)) + +(defun fm-ascendant-named (parent name) + (when parent + (or (when (eql (md-name parent) name) + parent) + (fm-ascendant-named (fm-parent parent) name)))) + +(defun fm-ascendant-typed (parent name) + (when parent + (or (when (typep parent name) + parent) + (fm-ascendant-typed (fm-parent parent) name)))) + +(defun fm-ascendant-some (parent somefunction) + (when (and parent somefunction) + (or (funcall somefunction parent) + (fm-ascendant-some (fm-parent parent) somefunction)))) + +(defun fm-ascendant-if (self iffunction) + (when (and self iffunction) + (or (when (funcall iffunction self) + self) + (fm-ascendant-if .parent iffunction)))) + +(defun fm-ascendant-common (d1 d2) + (fm-ascendant-some d1 (lambda (node) + (when (fm-includes node d2) + node)))) + +(defun fm-collect-if (tree test) + (let (collection) + (fm-traverse tree (lambda (node) + (when (funcall test node) + (push node collection)))) + (nreverse collection))) + +(defun fm-max (tree key) + (let (max) + (fm-traverse tree (lambda (node) + (if max + (setf max (max max (funcall key node))) + (setf max (funcall key node)))) + :global-search nil) + max)) + + +(defun fm-traverse (family applied-fn &key skipnode skiptree (global-search t) (opaque nil)) + (progn ;; wtrc (0 1600 "fm-traverse2" family) + (labels ((tv-family (fm skippee) + (when *fmdbg* (trc "tv-family" fm)) + + (when (and (typep fm 'model-object) + (not (eql fm skippee))) + (let ((outcome (unless (eql skipnode fm) + (funcall applied-fn fm)))) + (unless (and outcome opaque) + (dolist (kid (sub-nodes fm)) + (tv-family kid nil))))) + (when (and (typep fm 'model-object) + (not (eql fm skippee))) + (let ((outcome (and (not (eql skipnode fm)) + (funcall applied-fn fm)))) + (unless (and outcome opaque) + (dolist (kid (sub-nodes fm)) + (tv-family kid nil))))))) + + (loop for fm = family then (when global-search (fm-parent fm)) + and skip = skiptree then fm + unless fm return nil + do (when *fmdbg* (print `(fm-traverse using :fm , fm :skip ,skip))) + (tv-family fm skip))))) + +(defmethod sub-nodes (other) + (declare (ignore other))) + +(defmethod sub-nodes ((self family)) + (kids self)) + +(defmethod fm-ps-parent ((self model-object)) + (fm-parent self)) + +(defmacro with-like-fm-parts ((partsvar (self likeclass)) &body body) + `(let (,partsvar) + (fm-traverse ,self (lambda (node) + ;;(trc "with like sees node" node (type-of node) ',likeclass) + (when (typep node ',likeclass) + (push node ,partsvar))) + :skipnode ,self + :global-search nil + :opaque t) + (setf ,partsvar (nreverse ,partsvar)) + (progn ,@body))) + +(defmacro do-like-fm-parts ((partvar (self likeclass) &optional returnvar) &body body) + `(progn + (fm-traverse ,self (lambda (,partvar) + (when (typep ,partvar ',likeclass) + ,@body)) + :skipnode ,self + :global-search nil + :opaque t) + ,returnvar) + ) + +;; +;; family member finding +;; + +#| + (defun fm-member-named (kidname kids) + (member kidname kids :key #'md-name)) + |# + +(defun true-that (that) (declare (ignore that)) t) +;; +;; eventually fm-find-all needs a better name (as does fm-collect) and they +;; should be modified to go through 'gather', which should be the real fm-find-all +;; +(defun fm-gather (family &key (test #'true-that)) + (packed-flat! + (cons (when (funcall test family) family) + (mapcar (lambda (fm) + (fm-gather fm :test test)) + (kids family))))) + +(defun fm-find-all (family md-name &key (must-find t) (global-search t)) + (let ((matches (catch 'fm-find-all + (with-dynamic-fn + (traveller (family) + (with-dynamic-fn + (filter (kid) (eql md-name (md-name kid))) + (let ((matches (remove-if-not filter (kids family)))) + (when matches + (throw 'fm-find-all matches))))) + (fm-traverse family traveller :global-search global-search))))) + (when (and must-find (null matches)) + (setf *stop* t) + (break "fm-find-all > *stop*ping...did not find ~a ~a ~a" family md-name global-search) + ;; (error 'fm-not-found (list md-name family global-search)) + ) + matches)) + +(defun fm-find-next (fm test-fn) + (fm-find-next-within fm test-fn)) + +(defun fm-find-next-within (fm test-fn &optional upperbound &aux (fm-parent (unless (eql upperbound fm) + (fm-parent fm)))) + (let ((sibs (and fm-parent (rest (member fm (kids fm-parent)))))) + (or (dolist (s sibs) + (let ((winner (fm-find-if s test-fn))) + (when winner (return winner)))) + (if fm-parent + (fm-find-next-within fm-parent test-fn upperbound) + (fm-find-if fm test-fn))))) + +(defun fm-find-prior (fm test-fn) + (fm-find-prior-within fm test-fn)) + +(defun fm-find-prior-within (fm test-fn &optional upperbound &aux (fm-parent (unless (eql upperbound fm) + (fm-parent fm)))) + (let ((sibs (and fm-parent (kids fm-parent)))) + (or (loop with next-ok + for s on sibs + for last-ok = nil then (or next-ok last-ok) + when (eql fm (first s)) do (loop-finish) + finally (return last-ok) + do (setf next-ok (fm-find-last-if (car s) test-fn))) + (if fm-parent + (fm-find-prior-within fm-parent test-fn upperbound) + (fm-find-last-if fm test-fn))))) + + (defun fm-find-last-if (family test-fn) + (let ((last)) + (or (and (kids family) + (dolist (k (kids family) last) + (setf last (or (fm-find-last-if k test-fn) last)))) + (when (funcall test-fn family) + family)))) + +(defun fm-prior-sib (self &optional (test-fn #'true-that) + &aux (kids (kids (fm-parent self)))) + "Find nearest preceding sibling passing TEST-FN" + (find-if test-fn kids :end (position self kids) :from-end t)) + +(defun fm-next-sib-if (self test-fn) + (some test-fn (cdr (member self (kids (fm-parent self)))))) + +(defun fm-next-sib (self) + (car (cdr (member self (kids (fm-parent self)))))) + +(defmacro ^fm-next-sib (&optional (self 'self)) + (let ((s (gensym))) + `(let ((,s ,self)) + (car (cdr (member ,s (^kids (fm-parent ,s)))))))) + +(defun find-prior (self sibs &key (test #'true-that)) + (c-assert (member self sibs)) ;; got this by accidentally having toolbar kids dependent..on second calc, + ;; all newkids got over, and when old kids tried to recalculate...not in sibs!! + (unless (eql self (car sibs)) + (labels + ((fpsib (rsibs &aux (psib (car rsibs))) + (c-assert rsibs () "~&find-prior > fpsib > self ~s not found to prior off" self) + (if (eql self (cadr rsibs)) + (when (funcall test psib) psib) + (or (fpsib (cdr rsibs)) + (when (funcall test psib) psib))))) + (fpsib sibs)))) + +(defun fm-find-if (family test-fn &key skiptopp) ;; 99-03 kt why is thsi depth-first? + (c-assert test-fn) + (when family + (or (dolist (b (sub-nodes family)) + (let ((match (fm-find-if b test-fn))) + (when match (return match)))) + (when (and (not skiptopp) + (funcall test-fn family)) + family)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; +;;;; family ordering +;;;; +(defun fm-kid-add (fm-parent kid &optional before) + (c-assert (or (null (fm-parent kid)) (eql fm-parent (fm-parent kid)))) + (c-assert (typep fm-parent 'family)) + (setf (fm-parent kid) fm-parent) + (fm-kid-insert kid before)) + +(defun fm-kid-insert-last (goal &aux (fm-parent (fm-parent goal))) + (setf (kids fm-parent) (nconc (kids fm-parent) (list goal)))) + +(defun fm-kid-insert-first (goal &aux (fm-parent (fm-parent goal))) + (setf (kids fm-parent) (cons goal (kids fm-parent)))) + +(defun fm-kid-insert (kid &optional before &aux (dakids (kids (fm-parent kid)))) + (c-assert (or (null before) (eql (fm-parent kid) (fm-parent before)))) + (setf (kids (fm-parent kid)) + (if before + (if (eql before (car dakids)) + (cons kid dakids) + (let ((cell (member before dakids))) + (rplaca cell kid) + (rplacd cell (cons before (cdr cell))) + (cons (car dakids) (rest dakids)))) + (if dakids + (progn + (rplacd (last dakids) (cons kid nil)) + (cons (car dakids) (rest dakids))) + (cons kid dakids))))) + +(defun fm-kid-remove (kid &key (quiesce t) &aux (parent (fm-parent kid))) + (when quiesce + (fm-quiesce-all kid)) + (when parent + (setf (kids parent) (remove kid (kids parent))) + ;; (setf (fm-parent kid) nil) gratuitous housekeeping caused ensuing focus echo + ;; image-invalidate to fail since no access to containing window via fm-parent chain + )) + +(defun fm-quiesce-all (md) + (md-quiesce md) + (dolist (kid (kids md)) + (when (and kid (not (md-untouchable kid))) + (fm-quiesce-all kid))) + md) + + +(defun fm-kid-replace (oldkid newkid &aux (fm-parent (fm-parent oldkid))) + (c-assert (member oldkid (kids fm-parent)) () + "~&oldkid ~s not amongst kids of its fm-parent ~s" + oldkid fm-parent) + (when fm-parent ;; silly test given above assert--which is right? + (c-assert (typep fm-parent 'family)) + (setf (fm-parent newkid) fm-parent) + (setf (kids fm-parent) (substitute newkid oldkid (kids fm-parent))) + ;;(rplaca (member oldkid (kids fm-parent)) newkid) + newkid)) + +;---------------------------------------------------------- +;; +;; h i g h - o r d e r f a m i l y o p s +;; +;; currently not in use...someday? +(defmacro ^fm-min-max-kid (min-max slot-name &key (default 0) test (fm-parent 'self)) + (let ((best (copy-symbol 'best)) + (kid (copy-symbol 'kid)) + ) + `(let ((,best ,default)) + (dolist (,kid (^kids ,fm-parent) ,best) + ,(if test + `(when (funcall ,test ,kid) + (setf ,best (funcall ,min-max ,best (,slot-name ,kid)))) + `(bif (slotvalue (,slot-name ,kid)) + (setf ,best (funcall ,min-max ,best slotvalue)) + (break "nil slotvalue ~a in kid ~a of parent ~a" + ',slot-name ,kid ,fm-parent))))))) + +(defmacro ^fm-min-kid (slot-name &key (default 0) test (fm-parent 'self)) + `(^fm-min-max-kid #'min-if ,slot-name + :default ,default + :test ,test + :fm-parent ,fm-parent)) + +(defmacro ^fm-max-kid (slot-name &key (default 0) test (fm-parent 'self)) + `(^fm-min-max-kid #'max-if ,slot-name + :default ,default + :test ,test + :fm-parent ,fm-parent)) + +(defmacro ^fm-max-sib (slot-name &key (default 0) test) + `(^fm-max-kid ,slot-name :default ,default + :test ,test + :fm-parent (fm-parent self))) + +(defmacro ^fm-max-sib-other (slot-name &key (default 0)) + `(with-dynamic-fn (tester (sib) (not (eql self sib))) + (^fm-max-kid ,slot-name :default ,default + :test tester + :fm-parent (fm-parent self)))) + +(defmacro ^sib-named (name) + `(find ,name (^kids (fm-parent self)) :key #'md-name)) + + +(defmacro fm-other (md-name &key (starting 'self) skiptree (test '#'true-that)) + `(fm-find-one ,starting ,(if (consp md-name) + `(list ',(car md-name) ,(cadr md-name)) + `',md-name) + :must-find t + :skiptree ,skiptree + :global-search t + :test ,test)) + +(defmacro fm-otherx (md-name &key (starting 'self) skiptree) + (if (eql starting 'self) + `(or (fm-find-one ,starting ,(if (consp md-name) + `(list ',(car md-name) ,(cadr md-name)) + `',md-name) + :must-find t + :skiptree ,skiptree + :global-search t)) + `(fm-find-one ,starting ,(if (consp md-name) + `(list ',(car md-name) ,(cadr md-name)) + `',md-name) + :must-find t + :skiptree ,skiptree + :global-search t))) + +(defun fm-other-v (md-name starting &optional (global-search t)) + (break) + (fm-find-one starting md-name + :must-find nil + :global-search global-search)) + +(defmacro fm-otherv? (md-name &optional (starting 'self) (global-search t)) + `(fm-other-v ,md-name ,starting ,global-search)) + +(defmacro fm-other? (md-name &optional (starting 'self) (global-search t)) + `(fm-find-one ,starting ,(if (consp md-name) + `(list ',(car md-name) ,(cadr md-name)) + `',md-name) + :must-find nil + :global-search ,global-search)) + +(defun fm! (starting md-name &optional (global-search t)) + (fm-find-one starting md-name + :must-find t + :global-search global-search)) + +(defmacro fm? (md-name &optional (starting 'self) (global-search t)) + `(fm-find-one ,starting ,(if (consp md-name) + `(list ',(car md-name) ,(cadr md-name)) + `',md-name) + :must-find nil + :global-search ,global-search)) + +(defmacro fm-other! (md-name &optional (starting 'self)) + `(fm-find-one ,starting ,(if (consp md-name) + `(list ',(car md-name) ,(cadr md-name)) + `',md-name) + :must-find t + :global-search nil)) + +(defmacro fm-other?! (md-name &optional (starting 'self)) + `(fm-find-one ,starting ,(if (consp md-name) + `(list ',(car md-name) ,(cadr md-name)) + `',md-name) + :must-find nil + :global-search nil)) + +(defmacro fm-collect (md-name &key (must-find t)) + `(fm-find-all self ',md-name :must-find ,must-find)) ;deliberate capture + +(defmacro fm-map (fn md-name) + `(mapcar ,fn (fm-find-all self ',md-name))) ;deliberate capture + +(defmacro fm-mapc (fn md-name) + `(mapc ,fn (fm-find-all self ',md-name))) ;deliberate capture + +(defun fm-pos (goal &aux (fm-parent (fm-parent goal))) + (when fm-parent + (or (position goal (kids fm-parent)) + (length (kids fm-parent))))) ;; ?!! + +(defmacro fm-count-named (family md-name &key (global-search t)) + `(length (fm-find-all ,family ,md-name + :must-find nil + :global-search ,global-search))) +;--------------------------------------------------------------- + +(defun fm-top (fm &optional (test #'true-that) &aux (fm-parent (fm-parent fm))) + (cond ((null fm-parent) fm) + ((not (funcall test fm-parent)) fm) + (t (fm-top fm-parent test)))) + +(defun fm-first-above (fm &key (test #'true-that) &aux (fm-parent (fm-parent fm))) + (cond ((null fm-parent) nil) + ((funcall test fm-parent) fm-parent) + (t (fm-first-above fm-parent :test test)))) + +(defun fm-nearest-if (test fm) + (when fm + (if (funcall test fm) + fm + (fm-nearest-if test (fm-parent fm))))) + +(defun fm-includes (fm sought) + (fm-ancestorp fm sought)) + +(defun fm-ancestorp (fm sought) + (c-assert fm) + (when sought + (or (eql fm sought) + (fm-includes fm (fm-parent sought))))) + +(defun fm-kid-containing (fm-parent descendant) + (with-dynamic-fn (finder (node) (not (eql fm-parent node))) + (fm-top descendant finder))) + +(defun make-name (root &optional subscript) + (if subscript (list root subscript) root)) + +(defun name-root (md-name) + (if (atom md-name) md-name (car md-name))) + +(defun name-subscript (md-name) + (when (consp md-name) (cadr md-name))) + +(defun fm-find-one (family md-name &key (must-find t) + (global-search t) skiptree (test #'true-that)) + (flet ((matcher (fm) + (trc nil "fm-find-one matcher sees" md-name fm (md-name fm)) + (when (and (eql (name-root md-name) + (or (md-name fm) (c-class-name (class-of fm)))) + (or (null (name-subscript md-name)) + (eql (name-subscript md-name) (fm-pos fm))) + (funcall test fm)) + (throw 'fm-find-one fm)))) + #-lispworks (declare (dynamic-extent matcher)) + (trc nil "fm-find-one> entry " md-name family) + (let ((match (catch 'fm-find-one + (fm-traverse family #'matcher + :skiptree skiptree + :global-search global-search)))) + (when (and must-find (null match)) + (trc nil "fm-find-one > erroring fm-not-found" family md-name must-find global-search) + ;;(inspect family) + (let ((*fmdbg* family)) + (fm-find-one family md-name :must-find nil :global-search global-search) + (setf *stop* t) + ;;(trc "fm-find-one > *stop*ping...did not find" family md-name global-search) + (break "fm-find-one > *stop*ping...did not find ~a ~a ~a" family md-name global-search) + + )) + match))) + +(defun fm-find-kid (self name) + (find name (kids self) :key #'md-name)) + +(defun fm-kid-typed (self type) + (c-assert self) + (find type (kids self) :key #'type-of)) + +(defun kid-no (self) + (unless (typep self 'model-object) + (break "not a model object ~a" self)) + (when (and self (fm-parent self)) + (c-assert (member self (kids (fm-parent self)))) + (position self (kids (fm-parent self))))) + +

Index: cells/initialize.lisp diff -u cells/initialize.lisp:1.1.1.1 cells/initialize.lisp:1.2 --- cells/initialize.lisp:1.1.1.1 Sat Nov 8 18:44:17 2003 +++ cells/initialize.lisp Tue Dec 16 10:02:58 2003 @@ -1,105 +1,105 @@ -;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- -;;; -;;; Copyright © 1995,2003 by Kenneth William Tilton. -;;; -;;; Permission is hereby granted, free of charge, to any person obtaining a copy -;;; of this software and associated documentation files (the "Software"), to deal -;;; in the Software without restriction, including without limitation the rights -;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell -;;; copies of the Software, and to permit persons to whom the Software is furnished -;;; to do so, subject to the following conditions: -;;; -;;; The above copyright notice and this permission notice shall be included in -;;; all copies or substantial portions of the Software. -;;; -;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING -;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS -;;; IN THE SOFTWARE. - -(in-package :cells) - -(eval-when (compile eval load) - (export '(c-envalue))) - -(cc-defstruct (c-envaluer (:conc-name nil)) - envaluerule - ) - -(defun c-awaken (c) - (when *stop* - (princ #.) - (return-from c-awaken)) - - (assert (c-model c) () "c-awaken sees uninstalled cell" c) - - ; re-entry happen's normally - ; nop it... - ; - (when (c-waking-state c) - ;;(count-it :c-awaken :already) - ;;(trc "c-awaken > already awake" c) - (return-from c-awaken)) - - ;;(trc "c-awaken > awakening" c) - ;;(count-it :c-awaken) - (setf (c-waking-state c) :awakening) - (c-awaken-cell c) - (setf (c-waking-state c) :awake) - c) - -(defun c-ephemeral-p (c) - (eql :ephemeral (md-slot-cell-type (type-of (c-model c)) (c-slot-name c)))) - -(defmethod c-awaken-cell (c) - (declare (ignorable c))) - -(defmethod c-awaken-cell ((c c-variable)) - (when (and (c-ephemeral-p c) - (c-value c)) - (error "Feature not yet supported: initializing ephemeral to other than nil: [~a]" - (c-value c))) - ; - ; nothing to calculate, but every cellular slot should be echoed - ; - (let ((v (c-value c))) - ;;(trc (c-model c) "c-awaken > calling echo" c v (slot-value (c-model c)(c-slot-name c))) - (when (eql '.kids (c-slot-name c)) - (md-kids-change (c-model c) v nil :c-awaken-variable)) - (c-echo-slot-name (c-slot-name c) (c-model c) v nil nil) - (c-ephemeral-reset c))) - -(defmethod c-awaken-cell ((c c-ruled)) - ; - ; ^svuc (with askers supplied) calls c-awaken, and now we call ^svuc crucially without askers - ; this oddity comes from an incident in which an asker-free invocation of ^svuc - ; successfully calculated when the call passing askers failed, i guess because askers not - ; actually to be consulted given the algorithm still were detected as self-referential - ; since the self-ref detector could not anticipate the algorithm's branching. - ; - (let (*c-calculators*) - (c-calculate-and-set c))) - -(defmethod c-awaken-cell ((c c-dependent)) - ; - ; satisfy CormanCL bug - ; - (let (*c-calculators*) - (c-calculate-and-set c))) - -(defmethod c-awaken-cell ((c c-drifter)) - ; - ; drifters *begin* valid, so the derived version's test for unbounditude - ; would keep (drift) rule ever from being evaluated. correct solution - ; (for another day) is to separate awakening (ie, linking to independent - ; cs) from evaluation, tho also evaluating if necessary during - ; awakening, because awakening's other role is to get an instance up to speed - ; at once upon instantiation - ; - (c-calculate-and-set c) - (cond ((c-validp c) (c-value c)) - ((c-unboundp c) nil) - (t "illegal state!!!"))) +;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- +;;; +;;; Copyright (c) 1995,2003 by Kenneth William Tilton. +;;; +;;; Permission is hereby granted, free of charge, to any person obtaining a copy +;;; of this software and associated documentation files (the "Software"), to deal +;;; in the Software without restriction, including without limitation the rights +;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +;;; copies of the Software, and to permit persons to whom the Software is furnished +;;; to do so, subject to the following conditions: +;;; +;;; The above copyright notice and this permission notice shall be included in +;;; all copies or substantial portions of the Software. +;;; +;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS +;;; IN THE SOFTWARE. + +(in-package :cells) + +(eval-when (compile eval load) + (export '(c-envalue))) + +(defstruct (c-envaluer (:conc-name nil)) + envaluerule + ) + +(defun c-awaken (c) + (when *stop* + (princ #.) + (return-from c-awaken)) + + (c-assert (c-model c) () "c-awaken sees uninstalled cell" c) + + ; re-entry happen's normally + ; nop it... + ; + (when (c-waking-state c) + ;;(count-it :c-awaken :already) + ;;(trc "c-awaken > already awake" c) + (return-from c-awaken)) + + ;;(trc "c-awaken > awakening" c) + ;;(count-it :c-awaken) + (setf (c-waking-state c) :awakening) + (c-awaken-cell c) + (setf (c-waking-state c) :awake) + c) + +(defun c-ephemeral-p (c) + (eql :ephemeral (md-slot-cell-type (type-of (c-model c)) (c-slot-name c)))) + +(defmethod c-awaken-cell (c) + (declare (ignorable c))) + +(defmethod c-awaken-cell ((c c-variable)) + (when (and (c-ephemeral-p c) + (c-value c)) + (c-break "Feature not yet supported: initializing ephemeral to other than nil: [~a]" + (c-value c))) + ; + ; nothing to calculate, but every cellular slot should be echoed + ; + (let ((v (c-value c))) + ;;(trc (c-model c) "c-awaken > calling echo" c v (slot-value (c-model c)(c-slot-name c))) + (when (eql '.kids (c-slot-name c)) + (md-kids-change (c-model c) v nil :c-awaken-variable)) + (c-echo-slot-name (c-slot-name c) (c-model c) v nil nil) + (c-ephemeral-reset c))) + +(defmethod c-awaken-cell ((c c-ruled)) + ; + ; ^svuc (with askers supplied) calls c-awaken, and now we call ^svuc crucially without askers + ; this oddity comes from an incident in which an asker-free invocation of ^svuc + ; successfully calculated when the call passing askers failed, i guess because askers not + ; actually to be consulted given the algorithm still were detected as self-referential + ; since the self-ref detector could not anticipate the algorithm's branching. + ; + (let (*c-calculators*) + (c-calculate-and-set c))) + +(defmethod c-awaken-cell ((c c-dependent)) + ; + ; satisfy CormanCL bug + ; + (let (*c-calculators*) + (c-calculate-and-set c))) + +(defmethod c-awaken-cell ((c c-drifter)) + ; + ; drifters *begin* valid, so the derived version's test for unbounditude + ; would keep (drift) rule ever from being evaluated. correct solution + ; (for another day) is to separate awakening (ie, linking to independent + ; cs) from evaluation, tho also evaluating if necessary during + ; awakening, because awakening's other role is to get an instance up to speed + ; at once upon instantiation + ; + (c-calculate-and-set c) + (cond ((c-validp c) (c-value c)) + ((c-unboundp c) nil) + (t "illegal state!!!")))

Index: cells/link.lisp diff -u cells/link.lisp:1.1.1.1 cells/link.lisp:1.2 --- cells/link.lisp:1.1.1.1 Sat Nov 8 18:44:28 2003 +++ cells/link.lisp Tue Dec 16 10:02:58 2003 @@ -1,226 +1,226 @@ -;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- -;;; -;;; Copyright © 1995,2003 by Kenneth William Tilton. -;;; -;;; Permission is hereby granted, free of charge, to any person obtaining a copy -;;; of this software and associated documentation files (the "Software"), to deal -;;; in the Software without restriction, including without limitation the rights -;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell -;;; copies of the Software, and to permit persons to whom the Software is furnished -;;; to do so, subject to the following conditions: -;;; -;;; The above copyright notice and this permission notice shall be included in -;;; all copies or substantial portions of the Software. -;;; -;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING -;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS -;;; IN THE SOFTWARE. - -(in-package :cells) - - -(defun c-link-ex (used &aux (user (car *c-calculators*))) - - (cond - ((cmdead user) (return-from c-link-ex nil)) - ((null used) - ; - ; no cell on used value so it is constant, but if a synapse is involved the constant - ; must still be filtered thru that, albeit only this once - ; - (when *synapse-factory* - (assert (car *c-calculators*)) ;; sanity-check - (funcall *synapse-factory* nil (car *c-calculators*)))) - - ((or (not (typep used 'c-user-notifying)) - (and (typep used 'c-dependent) - (c-optimized-away-p used))) - (return-from c-link-ex nil)) - - (t - ; - ; --------- debug stuff -------------- - (assert user) - (assert (not (cmdead user)) () "dead user in link-ex ~a, used being ~a" user used) - (assert (not (cmdead used)) () "dead used in link-ex ~a, user being ~a" used user) - - #+dfdbg (trc user "c-link > user, used" user used) - (assert (not (eq :eternal-rest (md-state (c-model user))))) - (assert (not (eq :eternal-rest (md-state (c-model used))))) - (count-it :c-link-entry) - (when *c-debug* - (assert (or (null *synapse-factory*) - (functionp *synapse-factory*)) - () - "~s is not a function, but was supplied as a synapse factory between ~s and ~s. probably parentheses wrong, as in (- (^lr x 96))" - *synapse-factory* used user)) - - (let ((used-link - (or - ;; check if linked already - ;; /// looks like a bug: cannot have two synaptic dependencies on same - ;; /// cell slot...probably need to "name" the synapses just for this purpose - ;; - (c-find-used-link user used) - ;; - ;; following may have been a goof, but i like it: let synapse factory - ;; decide not to produce a synapse, in which case dumb direct c-cell link - ;; gets created. - ;; - (bwhen (syn (and *synapse-factory* - (funcall *synapse-factory* used user))) - (c-add-user used syn) - (c-add-used user syn) - ;;(trc used "c-link> users now:" (mapcar #'celltrueuser (un-users used))) - (trc nil "setting used to syn" syn used) - syn) - ;; - ;; make dumb link: used just tells user to rethink. - ;; - (progn - (trc nil "c-link > new user,used " user used) - (c-add-user used user) - (c-add-used user used) - used)))) - - (assert used-link) - (assert (position used-link (cd-useds user)) - () - "used-link ~a does not appear in useds ~a of user ~a" - used-link (cd-useds user) user) - - (let ((mapn (- *cd-usagect* - (- (length (cd-useds user)) - (or (position used-link (cd-useds user)) 0))))) - ;; (trc user "c-link> setting usage bit" user mapn used-link) - (if (minusp mapn) - (break "whoa. more than ~d used? i see ~d" *cd-usagect* (length (cd-useds user))) - (cd-usage-set user mapn))) - used-link)))) - -(defun cd-usage-set (c mapn) - (when (typep c 'synapse) - (setf (syn-relevant c) t)) - (setf (sbit (cd-usage c) mapn) 1)) - -(defun cd-usage-clear-all (c) - (bit-and (cd-usage c) - #*0000000000000000000000000000000000000000000000000000000000000000 - t)) - -(defun c-find-used-link (user-cell used) - "find any existing link to user-cell, the cell itself if direct or a synapse leading to it" - (some (lambda (user) - (if (typep user 'synapse) - (when (eql user-cell (syn-user user)) - user) ;; the synapse is the used link - (when (eql user-cell user) - used))) ;; the link to used is direct (non-synaptic) - (un-users used))) - -(defun c-add-user (used user) - (count-it :c-adduser) - - (typecase used - (c-user-notifying - (trc nil "c-add-user conventional > user, used" user used) - (pushnew user (un-users used))) - - (synapse (setf (syn-user used) user))) - - used) - -(defun c-user-path-exists-p (from-used to-user) - (typecase from-used - (synapse (c-user-path-exists-p (syn-user from-used) to-user)) - (c-user-notifying - (or (find to-user (un-users from-used)) - (find-if (lambda (from-used-user) - (c-user-path-exists-p (c-user-true from-used-user) to-user)) - (un-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))) - (mapcar 'c-users-resort (cd-useds user)) - (cd-useds user)) - -(defun c-users-resort (used) - (typecase used - (synapse (c-users-resort (syn-used used))) - (c-user-notifying - (when (second (un-users used)) - (setf (un-users used) (sort (un-users used) 'c-user-path-exists-p)) - (trc nil "c-users-resort resorted users > used" used (mapcar 'c-slot-name (un-users used))) - (mapcar 'c-users-resort (c-useds used)))))) - -(defmethod c-useds (other) (declare (ignore other))) -(defmethod c-useds ((c c-dependent)) (cd-useds c)) - - -(defun c-quiesce (c) - (typecase c - (cell - (trc nil "c-quiesce unlinking" c) - (c-unlink-from-used c) - (when (typep c 'c-user-notifying) - (dolist (user (un-users c)) - (c-unlink-user c user))) - (c-pending-set c nil :c-quiesce) - ;;; (setf (c-waking-state c) nil) - ;;; (when (eql :rpthead (c-model c)) - (trc nil "cell quiesce nulled cell awake" c)))) - -;------------------------- - -(defmethod c-unlink-from-used ((user c-dependent)) - (dolist (used (cd-useds user)) - #+dfdbg (trc user "unlinking from used" user used) - (c-unlink-user used user)) - ;; shouldn't be necessary (setf (cd-useds user) nil) - ) - -(defmethod c-unlink-from-used (other) - (declare (ignore other))) - -;---------------------------------------------------------- - -(defmethod c-unlink-user ((used c-user-notifying) user) - #+dfdbg (trc user "user unlinking from used" user used) - (setf (un-users used) (delete user (un-users used))) - (c-unlink-used user used)) - -(defmethod c-unlink-user ((syn synapse) user) - (assert (eq user (syn-user syn))) - (c-unlink-user (syn-used syn) syn) - (setf (syn-user syn) nil) ;; gc-paranoia? - ) - -;----------------------------------------------------------- - - -(defmethod c-unlink-used ((user c-dependent) used) - (setf (cd-useds user) (delete used (cd-useds user)))) - -(defmethod c-unlink-used ((syn synapse) used) - (assert (eq used (syn-used syn))) - (setf (syn-used syn) nil) - (c-unlink-used (syn-user syn) syn)) - -; --- very low-vel abstraction - -(defmethod c-user-true (c) c) -(defmethod c-user-true ((syn synapse)) (syn-user syn)) -(defmethod c-used-true (c) c) -(defmethod c-used-true ((syn synapse)) (syn-used syn)) +;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- +;;; +;;; Copyright (c) 1995,2003 by Kenneth William Tilton. +;;; +;;; Permission is hereby granted, free of charge, to any person obtaining a copy +;;; of this software and associated documentation files (the "Software"), to deal +;;; in the Software without restriction, including without limitation the rights +;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +;;; copies of the Software, and to permit persons to whom the Software is furnished +;;; to do so, subject to the following conditions: +;;; +;;; The above copyright notice and this permission notice shall be included in +;;; all copies or substantial portions of the Software. +;;; +;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS +;;; IN THE SOFTWARE. + +(in-package :cells) + + +(defun c-link-ex (used &aux (user (car *c-calculators*))) + (c-assert user) + (cond + ((cmdead user) (return-from c-link-ex nil)) + ((null used) + ; + ; no cell on used value so it is constant, but if a synapse is involved the constant + ; must still be filtered thru that, albeit only this once + ; + (when *synapse-factory* + (c-assert (car *c-calculators*)) ;; sanity-check + (funcall *synapse-factory* nil (car *c-calculators*)))) + + ((or (not (typep used 'cell)) + (and (typep used 'c-dependent) + (c-optimized-away-p used))) + (return-from c-link-ex nil)) + + (t + ; + ; --------- debug stuff -------------- + (c-assert user) + (c-assert (not (cmdead user)) () "dead user in link-ex ~a, used being ~a" user used) + (c-assert (not (cmdead used)) () "dead used in link-ex ~a, user being ~a" used user) + + #+dfdbg (trc user "c-link > user, used" user used) + (c-assert (not (eq :eternal-rest (md-state (c-model user))))) + (c-assert (not (eq :eternal-rest (md-state (c-model used))))) + (count-it :c-link-entry) + (when *c-debug* + (c-assert (or (null *synapse-factory*) + (functionp *synapse-factory*)) + () + "~s is not a function, but was supplied as a synapse factory between ~s and ~s. probably parentheses wrong, as in (- (^lr x 96))" + *synapse-factory* used user)) + + (let ((used-link + (or + ;; check if linked already + ;; /// looks like a bug: cannot have two synaptic dependencies on same + ;; /// cell slot...probably need to "name" the synapses just for this purpose + ;; + (c-find-used-link user used) + ;; + ;; following may have been a goof, but i like it: let synapse factory + ;; decide not to produce a synapse, in which case dumb direct c-cell link + ;; gets created. + ;; + (bwhen (syn (and *synapse-factory* + (funcall *synapse-factory* used user))) + (c-add-user used syn) + (c-add-used user syn) + ;;(trc used "c-link> users now:" (mapcar #'celltrueuser (c-users used))) + (trc nil "setting used to syn" syn used) + syn) + ;; + ;; make dumb link: used just tells user to rethink. + ;; + (progn + (trc nil "c-link > new user,used " user used) + (c-add-user used user) + (c-add-used user used) + used)))) + + (c-assert used-link) + (c-assert (position used-link (cd-useds user)) + () + "used-link ~a does not appear in useds ~a of user ~a" + used-link (cd-useds user) user) + + (let ((mapn (- *cd-usagect* + (- (length (cd-useds user)) + (or (position used-link (cd-useds user)) 0))))) + ;; (trc user "c-link> setting usage bit" user mapn used-link) + (if (minusp mapn) + (break "whoa. more than ~d used? i see ~d" *cd-usagect* (length (cd-useds user))) + (cd-usage-set user mapn))) + used-link)))) + +(defun cd-usage-set (c mapn) + (when (typep c 'synapse) + (setf (syn-relevant c) t)) + (setf (sbit (cd-usage c) mapn) 1)) + +(defun cd-usage-clear-all (c) + (bit-and (cd-usage c) + #*0000000000000000000000000000000000000000000000000000000000000000 + t)) + +(defun c-find-used-link (user-cell used) + "find any existing link to user-cell, the cell itself if direct or a synapse leading to it" + (some (lambda (user) + (if (typep user 'synapse) + (when (eql user-cell (syn-user user)) + user) ;; the synapse is the used link + (when (eql user-cell user) + used))) ;; the link to used is direct (non-synaptic) + (c-users used))) + +(defun c-add-user (used user) + (count-it :c-adduser) + + (typecase used + (cell + (trc nil "c-add-user conventional > user, used" user used) + (pushnew user (c-users used))) + + (synapse (setf (syn-user used) user))) + + used) + +(defun c-user-path-exists-p (from-used to-user) + (typecase from-used + (synapse (c-user-path-exists-p (syn-user from-used) to-user)) + (cell + (or (find to-user (c-users from-used)) + (find-if (lambda (from-used-user) + (c-user-path-exists-p (c-user-true 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))) + (mapcar 'c-users-resort (cd-useds user)) + (cd-useds user)) + +(defun c-users-resort (used) + (typecase used + (synapse (c-users-resort (syn-used used))) + (cell + (when (second (c-users used)) + (setf (c-users used) (sort (c-users used) 'c-user-path-exists-p)) + (trc nil "c-users-resort resorted users > used" used (mapcar 'c-slot-name (c-users used))) + (mapcar 'c-users-resort (c-useds used)))))) + +(defmethod c-useds (other) (declare (ignore other))) +(defmethod c-useds ((c c-dependent)) (cd-useds c)) + + +(defun c-quiesce (c) + (typecase c + (cell + (trc nil "c-quiesce unlinking" c) + (c-unlink-from-used c) + (when (typep c 'cell) + (dolist (user (c-users c)) + (c-unlink-user c user))) + (c-pending-set c nil :c-quiesce) + ;;; (setf (c-waking-state c) nil) + ;;; (when (eql :rpthead (c-model c)) + (trc nil "cell quiesce nulled cell awake" c)))) + +;------------------------- + +(defmethod c-unlink-from-used ((user c-dependent)) + (dolist (used (cd-useds user)) + #+dfdbg (trc user "unlinking from used" user used) + (c-unlink-user used user)) + ;; shouldn't be necessary (setf (cd-useds user) nil) + ) + +(defmethod c-unlink-from-used (other) + (declare (ignore other))) + +;---------------------------------------------------------- + +(defmethod c-unlink-user ((used cell) user) + #+dfdbg (trc user "user unlinking from used" user used) + (setf (c-users used) (delete user (c-users used))) + (c-unlink-used user used)) + +(defmethod c-unlink-user ((syn synapse) user) + (c-assert (eq user (syn-user syn))) + (c-unlink-user (syn-used syn) syn) + (setf (syn-user syn) nil) ;; gc-paranoia? + ) + +;----------------------------------------------------------- + + +(defmethod c-unlink-used ((user c-dependent) used) + (setf (cd-useds user) (delete used (cd-useds user)))) + +(defmethod c-unlink-used ((syn synapse) used) + (c-assert (eq used (syn-used syn))) + (setf (syn-used syn) nil) + (c-unlink-used (syn-user syn) syn)) + +; --- very low-vel abstraction + +(defmethod c-user-true (c) c) +(defmethod c-user-true ((syn synapse)) (syn-user syn)) +(defmethod c-used-true (c) c) +(defmethod c-used-true ((syn synapse)) (syn-used syn))

Index: cells/md-slot-value.lisp diff -u cells/md-slot-value.lisp:1.1.1.1 cells/md-slot-value.lisp:1.2 --- cells/md-slot-value.lisp:1.1.1.1 Sat Nov 8 18:44:28 2003 +++ cells/md-slot-value.lisp Tue Dec 16 10:02:58 2003 @@ -1,153 +1,150 @@ -;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- -;;; -;;; Copyright © 1995,2003 by Kenneth William Tilton. -;;; -;;; Permission is hereby granted, free of charge, to any person obtaining a copy -;;; of this software and associated documentation files (the "Software"), to deal -;;; in the Software without restriction, including without limitation the rights -;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell -;;; copies of the Software, and to permit persons to whom the Software is furnished -;;; to do so, subject to the following conditions: -;;; -;;; The above copyright notice and this permission notice shall be included in -;;; all copies or substantial portions of the Software. -;;; -;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING -;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS -;;; IN THE SOFTWARE. - -(in-package :cells) - -(defun md-slot-cell-flushed (self slot-spec) - (assocv (slot-spec-name slot-spec) (cells-flushed self))) - -(defun md-slot-value (self slot-spec &aux (slot-c (md-slot-cell self slot-spec))) - (when *stop* - (princ #.) - (return-from md-slot-value)) - ;; (count-it :md-slot-value (slot-spec-name slot-spec)) - #+badidea(when (mdead self) - (trc "md-slot-value> model dead" (type-of self) slot-spec) - (return-from md-slot-value nil)) - (when (eql :nascent (md-state self)) - (md-awaken self)) - - ; this next bit is not written (c-relay-value <link> (etypecase slot-c...)) - ; because that would link before accessing possibly an invalid ruled slot - ; (during md-awaken), and after calculating it would propagate to users and - ; re-enter this calculation. Switching the order of the parameters would - ; also work, but we need to document this very specific order of operations - ; anyway, can't just leave that to the left-right thing. - ; - (let ((slot-value (etypecase slot-c - (null (bd-slot-value self slot-spec)) - (c-variable (c-value slot-c)) - (c-ruled (c-ruled-slot-value slot-c))))) - (c-relay-value - (when (car *c-calculators*) - (c-link-ex slot-c)) - slot-value))) - -(defun c-ruled-slot-value (slot-c) - (trc nil "c-ruled-slot-value entry" slot-c) - (assert (not (cmdead slot-c))) - - (cond - ((c-validp slot-c) - (if (c-true-stalep slot-c) - (c-calculate-and-set slot-c) ;; new for 2003-09-14 - (bif (deep (cd-deep-stale slot-c)) - (progn - (trc nil "valid ~a :but-deepstale ~a, cause: ~a. calcing" - slot-c deep *cause*) - (c-calculate-and-set slot-c)) - #+worked (progn - (trc "valid ~a :but-deepstale ~a, cause: ~a. calcing" - slot-c deep *cause*) - (c-calculate-and-set deep) - (bIf (deep2 (cd-deep-stale slot-c)) - (break "deep, deep trouble ~a :deep2 ~a :deep1 ~a, cause: ~a." - slot-c deep2 deep *cause*) - (progn - (trc "cleared valid with deep stale" slot-c) - (c-calculate-and-set slot-c)))) - (c-value slot-c)))) ;; good to go - - (t (let ((*cause* :on-demand)) ; normal path first time asked - (trc (plusp *trcdepth*) "md-slot-value calc" slot-c *c-calculators*) - (c-calculate-and-set slot-c))))) - -;------------------------------------------------------------- - -(defun (setf md-slot-value) (newvalue self slot-spec) - (when (mdead self) - (return-from md-slot-value)) - (let ((c (md-slot-cell self slot-spec))) - - (when *c-debug* - (c-setting-debug self slot-spec c newvalue)) - - (unless c - (cellstop) - (error "(setf md-slot-value)> cellular slot ~a of ~a cannot be setf unless initialized to c-variable" - slot-spec self) - ) - - (if (unst-setting-p c) - (if (unst-cyclic-p c) - newvalue - (error "setf of ~a propagated back; declare as cyclic (cv8...)" c)) - (let ((absorbedvalue (c-absorb-value c newvalue))) - ;;(assert (not (mdead self))) - (with-dataflow-management (c) - (md-slot-value-assume self slot-spec absorbedvalue)) ;; /// uh-oh. calc-n-set uses this return value - absorbedvalue)))) - -;;;(defmethod trcp ((c c-ruled)) -;;; ;;(trc "trcp ruled" (c-slot-name c) (md-name (c-model c))) -;;; (and (eql 'clo::px (c-slot-name c)) -;;; (eql :mklabel (md-name (c-model c))))) - - -(defun md-slot-value-assume (self slot-spec absorbedvalue - &aux - (c (md-slot-cell self slot-spec)) - (priorstate (when c (c-state c))) - (priorvalue (when c (c-value c))) - ) - (when (mdead self) - (return-from md-slot-value-assume nil)) - (md-slot-value-store self (slot-spec-name slot-spec) - (if c - (setf (c-value c) absorbedvalue) - absorbedvalue)) - - (when (typep c 'c-ruled) - (trc nil " setting cellstate :valid" c) - (setf (c-state c) :valid) - (setf (cd-stale-p c) nil) - (setf (c-waking-state c) :awake) - (c-pending-set c nil :sv-assume) - (c-optimize-away?! c)) ;;; put optimize as early as possible - - ;--- propagation ----------- - ; - (unwind-protect - (if (and (eql priorstate :valid) ;; ie, priorvalue meaningful (nil is ambiguous) - (c-no-news c absorbedvalue priorvalue)) - (progn - (trc nil "(setf md-slot-value) >no-news" priorstate (c-no-news c absorbedvalue priorvalue)) - #+not (count-it :no-news)) - (progn - (when (eql '.kids (slot-spec-name slot-spec)) - #+dfdbg (dolist (K absorbedvalue) (trc k "md-slot-value-assume -> kids change" k self)) - (md-kids-change self absorbedvalue priorvalue :md-slot-value-assume)) - (md-propagate self slot-spec absorbedvalue priorvalue (not (eql :unbound priorstate))))) - (when c - (setf (unst-setting-p c) nil))) - absorbedvalue) - +;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- +;;; +;;; Copyright (c) 1995,2003 by Kenneth William Tilton. +;;; +;;; Permission is hereby granted, free of charge, to any person obtaining a copy +;;; of this software and associated documentation files (the "Software"), to deal +;;; in the Software without restriction, including without limitation the rights +;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +;;; copies of the Software, and to permit persons to whom the Software is furnished +;;; to do so, subject to the following conditions: +;;; +;;; The above copyright notice and this permission notice shall be included in +;;; all copies or substantial portions of the Software. +;;; +;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS +;;; IN THE SOFTWARE. + +(in-package :cells) + +(defun md-slot-cell-flushed (self slot-spec) + (cdr (assoc (slot-spec-name slot-spec) (cells-flushed self)))) + +(defun md-slot-value (self slot-spec &aux (slot-c (md-slot-cell self slot-spec))) + (when *stop* + (princ #.) + (return-from md-slot-value)) + ;; (count-it :md-slot-value (slot-spec-name slot-spec)) + #+badidea(when (mdead self) + (trc "md-slot-value> model dead" (type-of self) slot-spec) + (return-from md-slot-value nil)) + (when (eql :nascent (md-state self)) + (md-awaken self)) + + ; this next bit is not written (c-relay-value <link> (etypecase slot-c...)) + ; because that would link before accessing possibly an invalid ruled slot + ; (during md-awaken), and after calculating it would propagate to users and + ; re-enter this calculation. Switching the order of the parameters would + ; also work, but we need to document this very specific order of operations + ; anyway, can't just leave that to the left-right thing. + ; + (let ((slot-value (etypecase slot-c + (null (bd-slot-value self slot-spec)) + (c-variable (c-value slot-c)) + (c-ruled (c-ruled-slot-value slot-c))))) + (c-relay-value + (when (car *c-calculators*) + (c-link-ex slot-c)) + slot-value))) + +(defun c-ruled-slot-value (slot-c) + (trc nil "c-ruled-slot-value entry" slot-c) + (c-assert (not (cmdead slot-c))) + + (cond + ((c-validp slot-c) + (if (c-true-stalep slot-c) + (c-calculate-and-set slot-c) ;; new for 2003-09-14 + (bif (deep (cd-deep-stale slot-c)) + (progn + (trc nil "valid ~a :but-deepstale ~a, cause: ~a. calcing" + slot-c deep *cause*) + (c-calculate-and-set slot-c)) + #+worked (progn + (trc "valid ~a :but-deepstale ~a, cause: ~a. calcing" + slot-c deep *cause*) + (c-calculate-and-set deep) + (bIf (deep2 (cd-deep-stale slot-c)) + (break "deep, deep trouble ~a :deep2 ~a :deep1 ~a, cause: ~a." + slot-c deep2 deep *cause*) + (progn + (trc "cleared valid with deep stale" slot-c) + (c-calculate-and-set slot-c)))) + (c-value slot-c)))) ;; good to go + + (t (let ((*cause* :on-demand)) ; normal path first time asked + (trc (plusp *trcdepth*) "md-slot-value calc" slot-c *c-calculators*) + (c-calculate-and-set slot-c))))) + +;------------------------------------------------------------- + +(defun (setf md-slot-value) (newvalue self slot-spec) + (when (mdead self) + (return-from md-slot-value)) + (let ((c (md-slot-cell self slot-spec))) + + (when *c-debug* + (c-setting-debug self slot-spec c newvalue)) + + (unless c + (c-stop :setf-md-slot-value) + (c-break "(setf md-slot-value)> cellular slot ~a of ~a cannot be setf unless initialized to c-variable" + slot-spec self) + ) + + (if (cv-setting-p c) + (if (cv-cyclic-p c) + newvalue + (c-break "setf of ~a propagated back; declare as cyclic (cv8...)" c)) + (let ((absorbedvalue (c-absorb-value c newvalue))) + ;;(c-assert (not (mdead self))) + (with-dataflow-management (c) + (md-slot-value-assume self slot-spec absorbedvalue)) ;; /// uh-oh. calc-n-set uses this return value + absorbedvalue)))) + +;;;(defmethod trcp ((c c-ruled)) +;;; ;;(trc "trcp ruled" (c-slot-name c) (md-name (c-model c))) +;;; (and (eql 'clo::px (c-slot-name c)) +;;; (eql :mklabel (md-name (c-model c))))) + + +(defun md-slot-value-assume (self slot-spec absorbedvalue + &aux + (c (md-slot-cell self slot-spec)) + (priorstate (when c (c-state c))) + (priorvalue (when c (c-value c))) + ) + (when (mdead self) + (return-from md-slot-value-assume nil)) + (md-slot-value-store self (slot-spec-name slot-spec) + (if c + (setf (c-value c) absorbedvalue) + absorbedvalue)) + + (when (typep c 'c-ruled) + (trc nil " setting cellstate :valid" c) + (setf (c-state c) :valid) + (setf (cd-stale-p c) nil) + (setf (c-waking-state c) :awake) + (c-pending-set c nil :sv-assume) + (c-optimize-away?! c)) ;;; put optimize as early as possible + + ;--- propagation ----------- + ; + (if (and (eql priorstate :valid) ;; ie, priorvalue meaningful (nil is ambiguous) + (c-no-news c absorbedvalue priorvalue)) + (progn + (trc nil "(setf md-slot-value) >no-news" priorstate (c-no-news c absorbedvalue priorvalue)) + #+not (count-it :no-news)) + (progn + (when (eql '.kids (slot-spec-name slot-spec)) + #+dfdbg (dolist (K absorbedvalue) (trc k "md-slot-value-assume -> kids change" k self)) + (md-kids-change self absorbedvalue priorvalue :md-slot-value-assume)) + (md-propagate self slot-spec absorbedvalue priorvalue (not (eql :unbound priorstate))))) + absorbedvalue) +

Index: cells/md-utilities.lisp diff -u cells/md-utilities.lisp:1.1.1.1 cells/md-utilities.lisp:1.2 --- cells/md-utilities.lisp:1.1.1.1 Sat Nov 8 18:44:28 2003 +++ cells/md-utilities.lisp Tue Dec 16 10:02:58 2003 @@ -1,111 +1,111 @@ -;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- -;;; -;;; Copyright © 1995,2003 by Kenneth William Tilton. -;;; -;;; Permission is hereby granted, free of charge, to any person obtaining a copy -;;; of this software and associated documentation files (the "Software"), to deal -;;; in the Software without restriction, including without limitation the rights -;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell -;;; copies of the Software, and to permit persons to whom the Software is furnished -;;; to do so, subject to the following conditions: -;;; -;;; The above copyright notice and this permission notice shall be included in -;;; all copies or substantial portions of the Software. -;;; -;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING -;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS -;;; IN THE SOFTWARE. - -(in-package :cells) - -;;;(defmethod update-instance-for-redefined-class ((self model-object) added lost plist &key) -;;; (declare (ignorable added lost plist)) -;;; (when (slot-boundp self '.md-state) (call-next-method))) - -(defmethod occurence ((self model-object)) - ; - ; whether multiply occuring or not, return index of self - ; within list of likenamed siblings, perhaps mixed amongst others - ; of diff names - ; - (let ((selfindex -1)) - (dolist (kid (kids (fmparent self))) - (when (eql (md-name kid) (md-name self)) - (incf selfindex) - (when (eql self kid) - (return-from occurence selfindex)))))) - - -(defun md-awake (self) (eql :awake (md-state self))) - - -(defun fm-grandparent (md) - (fmparent (fmparent md))) - - -(defmethod md-release (other) - (declare (ignorable other))) - -;___________________ birth / death__________________________________ - -(defmethod not-to-be :around (self) - (trc nil "not-to-be clearing 1 fmparent, eternal-rest" self) - (assert (not (eq (md-state self) :eternal-rest))) - - (call-next-method) - - (setf (fmparent self) nil - (md-state self) :eternal-rest) - (trc nil "not-to-be cleared 2 fmparent, eternal-rest" self)) - -(defmethod not-to-be ((self model-object)) - (trc nil "not to be!!!" self) - (unless (md-untouchable self) - (md-quiesce self))) - -(defmethod md-untouchable (self) ;; would be t for closed-stream under acl - (declare (ignore self)) - nil) - -(defun md-quiesce (self) - (trc nil "md-quiesce doing" self) - (md-map-cells self nil (lambda (c) - (trc nil "quiescing" c) - (assert (not (find c *c-calculators*))) - (c-quiesce c)))) - - -(defmethod not-to-be (other) - other) - - - -(defparameter *to-be-dbg* nil) - -(defun to-be (self) - (trc nil "to-be> entry" self (md-state self)) - - (progn ;;wtrc (0 100 "to-be> entry" self (md-state self) (length *to-be-awakened*)) - (when (eql :nascent (md-state self)) ;; formwithview to-be-primary :after => rv-stitch! => side-effects - (let ((already *to-be-awakened*)) - (setf *to-be-awakened* (nconc *to-be-awakened* (list self))) - (trc nil "to-be deferring awaken" self) - (kids self) ;; sick, just for side effect - (unless already - (trc nil "top to-be awakening deferred" self (length *to-be-awakened*)) - (do* ((mds *to-be-awakened* (cdr mds)) - (md (car mds) (car mds))) - ((null mds)) - (if (eql :nascent (md-state md)) - (md-awaken md) - (trc nil "not md-awakening non-nascent" md))) - (setf *to-be-awakened* nil))))) - self) - -(defun md-make (class &rest kwps) - (to-be (apply #'make-instance class kwps))) - +;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- +;;; +;;; Copyright (c) 1995,2003 by Kenneth William Tilton. +;;; +;;; Permission is hereby granted, free of charge, to any person obtaining a copy +;;; of this software and associated documentation files (the "Software"), to deal +;;; in the Software without restriction, including without limitation the rights +;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +;;; copies of the Software, and to permit persons to whom the Software is furnished +;;; to do so, subject to the following conditions: +;;; +;;; The above copyright notice and this permission notice shall be included in +;;; all copies or substantial portions of the Software. +;;; +;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS +;;; IN THE SOFTWARE. + +(in-package :cells) + +;;;(defmethod update-instance-for-redefined-class ((self model-object) added lost plist &key) +;;; (declare (ignorable added lost plist)) +;;; (when (slot-boundp self '.md-state) (call-next-method))) + +(defmethod occurence ((self model-object)) + ; + ; whether multiply occuring or not, return index of self + ; within list of likenamed siblings, perhaps mixed amongst others + ; of diff names + ; + (let ((selfindex -1)) + (dolist (kid (kids (fm-parent self))) + (when (eql (md-name kid) (md-name self)) + (incf selfindex) + (when (eql self kid) + (return-from occurence selfindex)))))) + + +(defun md-awake (self) (eql :awake (md-state self))) + + +(defun fm-grandparent (md) + (fm-parent (fm-parent md))) + + +(defmethod md-release (other) + (declare (ignorable other))) + +;___________________ birth / death__________________________________ + +(defmethod not-to-be :around (self) + (trc nil "not-to-be clearing 1 fm-parent, eternal-rest" self) + (c-assert (not (eq (md-state self) :eternal-rest))) + + (call-next-method) + + (setf (fm-parent self) nil + (md-state self) :eternal-rest) + (trc nil "not-to-be cleared 2 fm-parent, eternal-rest" self)) + +(defmethod not-to-be ((self model-object)) + (trc nil "not to be!!!" self) + (unless (md-untouchable self) + (md-quiesce self))) + +(defmethod md-untouchable (self) ;; would be t for closed-stream under acl + (declare (ignore self)) + nil) + +(defun md-quiesce (self) + (trc nil "md-quiesce doing" self) + (md-map-cells self nil (lambda (c) + (trc nil "quiescing" c) + (c-assert (not (find c *c-calculators*))) + (c-quiesce c)))) + + +(defmethod not-to-be (other) + other) + + + +(defparameter *to-be-dbg* nil) + +(defun to-be (self) + (trc nil "to-be> entry" self (md-state self)) + + (progn ;;wtrc (0 100 "to-be> entry" self (md-state self) (length *to-be-awakened*)) + (when (eql :nascent (md-state self)) ;; formwithview to-be-primary :after => rv-stitch! => side-effects + (let ((already *to-be-awakened*)) + (setf *to-be-awakened* (nconc *to-be-awakened* (list self))) + (trc nil "to-be deferring awaken" self) + (kids self) ;; sick, just for side effect + (unless already + (trc nil "top to-be awakening deferred" self (length *to-be-awakened*)) + (do* ((mds *to-be-awakened* (cdr mds)) + (md (car mds) (car mds))) + ((null mds)) + (if (eql :nascent (md-state md)) + (md-awaken md) + (trc nil "not md-awakening non-nascent" md))) + (setf *to-be-awakened* nil))))) + self) + +(defun md-make (class &rest kwps) + (to-be (apply #'make-instance class kwps))) +

Index: cells/model-object.lisp diff -u cells/model-object.lisp:1.1.1.1 cells/model-object.lisp:1.2 --- cells/model-object.lisp:1.1.1.1 Sat Nov 8 18:44:28 2003 +++ cells/model-object.lisp Tue Dec 16 10:02:58 2003 @@ -1,193 +1,175 @@ -;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- -;;; -;;; Copyright © 1995,2003 by Kenneth William Tilton. -;;; -;;; Permission is hereby granted, free of charge, to any person obtaining a copy -;;; of this software and associated documentation files (the "Software"), to deal -;;; in the Software without restriction, including without limitation the rights -;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell -;;; copies of the Software, and to permit persons to whom the Software is furnished -;;; to do so, subject to the following conditions: -;;; -;;; The above copyright notice and this permission notice shall be included in -;;; all copies or substantial portions of the Software. -;;; -;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING -;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS -;;; IN THE SOFTWARE. - -(in-package :cells) - -;----------------- model-object ---------------------- - -(eval-when (:compile-toplevel :load-toplevel :execute) - (export '(md-name mdwhen fmparent .parent))) - -(defclass model-object () - ((.md-state :initform nil :accessor md-state) ; [nil | :nascent | :alive | :doomed] - (.md-name :initform nil :initarg :md-name :accessor md-name) - (.mdwhen :initform nil :initarg :mdwhen :accessor mdwhen) - (.fmparent :initform nil :initarg :fmparent :accessor fmparent) - (.cells :initform nil :initarg :cells :accessor cells) - (.cells-flushed :initform nil :initarg cells :accessor cells-flushed - :documentation "cells supplied but un-whenned or optimized-away") - (adopt-ct :initform 0 :accessor adopt-ct))) - -(defmethod print-object ((self model-object) s) - (format s "~a" (or (md-name self) (type-of self)))) - -(define-symbol-macro .parent (fmparent self)) - -(defun md-cell-defs (self) - (get (type-of self) :cell-defs)) - -(defmethod md-slot-cell (self slot-spec) - (assocv (slot-spec-name slot-spec) (cells self))) - -(defun md-slot-cell-type (class-name slot-spec) - (bif (entry (assoc (slot-spec-name slot-spec) (get class-name :cell-defs))) - (cdr entry) - (dolist (super (class-precedence-list (find-class class-name))) - (bIf (entry (assoc (slot-spec-name slot-spec) (get (c-class-name super) :cell-defs))) - (return (cdr entry)))))) - - -(defun (setf md-slot-cell-type) (new-type class-name slot-spec) - (assocv-setf (get class-name :cell-defs) (slot-spec-name slot-spec) new-type)) - -(defmethod md-slot-value-store ((self model-object) slot-spec new-value) - (setf (slot-value self (slot-spec-name slot-spec)) new-value)) - -;----------------- navigation: slot <> initarg <> esd <> cell ----------------- - -#+cmu -(defmethod c-class-name ((class pcl::standard-class)) - (pcl::class-name class)) - -(defmethod c-class-name (other) (declare (ignore other)) nil) - -(defmethod c-class-name ((class standard-class)) - (class-name class)) - -(defmethod cellwhen (other) (declare (ignorable other)) nil) - -(defun (setf md-slot-cell) (newcell self slot-spec) - (bif (entry (assoc (slot-spec-name slot-spec) (cells self))) - (let ((old (cdr entry))) ;; s/b being supplanted by kid-slotter - (assert (null (un-users old))) - (assert (null (cd-useds old))) - (trc nil "replacing in model .cells" old newcell self) - (rplacd entry newcell)) - (progn - (trc nil "adding to model .cells" newcell self) - (push (cons (slot-spec-name slot-spec) newcell) - (cells self))))) - -(defun md-map-cells (self type celldo) - (map type (lambda (cellentry) - (bwhen (cell (cdr cellentry)) - (unless (listp cell) - (funcall celldo cell)))) - (cells self))) - -(defun c-install (self sn c) - (assert (typep c 'cell)) - (trc nil "installing cell" sn c) - (setf - (c-model c) self - (c-slot-spec c) sn - (md-slot-cell self sn) c - (slot-value self sn) (when (typep c 'c-variable) - (c-value c)))) - -;------------------ md obj initialization ------------------ - -(defmethod shared-initialize :after ((self model-object) slotnames - &rest initargs &key fmparent mdwhen - &allow-other-keys) - (declare (ignorable initargs slotnames fmparent mdwhen)) - - (dolist (esd (class-slots (class-of self))) - (let* ((sn (slot-definition-name esd)) - (sv (when (slot-boundp self sn) - (slot-value self sn)))) - (when (typep sv 'cell) - (if (md-slot-cell-type (type-of self) sn) - (c-install self sn sv) - (when *c-debug* - (trc "cell ~a offered for non-cellular model/slot ~a/~a" sv self sn)))))) - - (md-initialize self)) - -;;;(defun pick-if-when-slot (esd mdwhen &aux (cellwhen (cellwhen esd))) -;;; (or (null cellwhen) -;;; (some-x-is-in-y cellwhen mdwhen))) - -(defmethod md-initialize (self) - (when (slot-boundp self '.md-name) - (unless (md-name self) - (setf (md-name self) (c-class-name (class-of self))))) - - (when (fmparent self) - (md-adopt (fmparent self) self)) - - (setf (md-state self) :nascent)) - -(defun cells-clear (self) - "allow gc" - ;; - ;; too extreme? 'close-device went after slot when a class - ;; ended up without cells--should not be a crime 2k0320kt - ;; (slot-makunbound self '.cells) - ;; ... - (setf (cells self) nil) ;; try instead - ) - - -;--------- awaken only when ready (in family, for models) -------- - - -(defmethod md-awaken ((self model-object)) - (trc nil "md-awaken entry" self (md-state self)) - (assert (eql :nascent (md-state self))) - ;; (trc nil "awaken doing") - (count-it :md-awaken) - ;;(count-it 'mdawaken (type-of self)) - (setf (md-state self) :awakening) - ;; (trc "md-awaken entry" self) - (dolist (esd (class-slots (class-of self))) - (trc nil "md-awaken scoping slot" self (slot-definition-name esd)) - (when (md-slot-cell-type (type-of self) (slot-definition-name esd)) - (let ((slot-name (slot-definition-name esd))) - (if (not (c-echo-defined slot-name)) - (progn ;; (count-it :md-awaken :no-echo-slot slot-name) - (trc nil "md-awaken deferring cell-awaken since no echo" self esd)) - - (let ((cell (md-slot-cell self slot-name))) - (trc nil "md-awaken finds md-esd-cell " cell) - (when *c-debug* - ; - ; check to see if cell snuck into actual slot value... - ; - (bwhen (sv (slot-value self slot-name)) - (when (typep sv 'cell) - (error "md-awaken ~a found cell ~a in slot ~a" self sv esd)))) - - (if cell - (if (c-lazy-p cell) - (progn - (trc nil "md-awaken deferring cell-awaken since lazy" self esd)) - (c-awaken cell)) - (progn ;; next bit revised to avoid double-echo of optimized cells - (when (eql '.kids slot-name) - (bwhen (sv (slot-value self '.kids)) - (md-kids-change self sv nil :md-awaken-slot))) - (c-echo-initially self slot-name)))))))) - - (setf (md-state self) :awake) - self) - +;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- +;;; +;;; Copyright (c) 1995,2003 by Kenneth William Tilton. +;;; +;;; Permission is hereby granted, free of charge, to any person obtaining a copy +;;; of this software and associated documentation files (the "Software"), to deal +;;; in the Software without restriction, including without limitation the rights +;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +;;; copies of the Software, and to permit persons to whom the Software is furnished +;;; to do so, subject to the following conditions: +;;; +;;; The above copyright notice and this permission notice shall be included in +;;; all copies or substantial portions of the Software. +;;; +;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS +;;; IN THE SOFTWARE. + +(in-package :cells) + +;----------------- model-object ---------------------- + +(eval-when (:compile-toplevel :load-toplevel :execute) + (export '(md-name mdwhen fm-parent .parent))) + +(defclass model-object () + ((.md-state :initform nil :accessor md-state) ; [nil | :nascent | :alive | :doomed] + (.mdwhen :initform nil :initarg :mdwhen :accessor mdwhen) + (.cells :initform nil :accessor cells) + (.cells-flushed :initform nil :accessor cells-flushed + :documentation "cells supplied but un-whenned or optimized-away") + (adopt-ct :initform 0 :accessor adopt-ct))) + +(defmethod md-slot-cell (self slot-spec) + (cdr (assoc (slot-spec-name slot-spec) (cells self)))) + +(defun md-slot-cell-type (class-name slot-spec) + (bif (entry (assoc (slot-spec-name slot-spec) (get class-name :cell-types))) + (cdr entry) + (dolist (super (class-precedence-list (find-class class-name))) + (bWhen (entry (assoc (slot-spec-name slot-spec) (get (c-class-name super) :cell-types))) + (return (setf (md-slot-cell-type class-name slot-spec) (cdr entry))))))) + +(defun (setf md-slot-cell-type) (new-type class-name slot-spec) + (assocv-setf (get class-name :cell-types) (slot-spec-name slot-spec) new-type)) + +(defmethod md-slot-value-store ((self model-object) slot-spec new-value) + (setf (slot-value self (slot-spec-name slot-spec)) new-value)) + +;----------------- navigation: slot <> initarg <> esd <> cell ----------------- + +#+cmu +(defmethod c-class-name ((class pcl::standard-class)) + (pcl::class-name class)) + +(defmethod c-class-name (other) (declare (ignore other)) nil) + +(defmethod c-class-name ((class standard-class)) + (class-name class)) + +(defmethod cellwhen (other) (declare (ignorable other)) nil) + +(defun (setf md-slot-cell) (newcell self slot-spec) + (bif (entry (assoc (slot-spec-name slot-spec) (cells self))) + (let ((old (cdr entry))) ;; s/b being supplanted by kid-slotter + (c-assert (null (c-users old))) + (c-assert (null (cd-useds old))) + (trc nil "replacing in model .cells" old newcell self) + (rplacd entry newcell)) + (progn + (trc nil "adding to model .cells" newcell self) + (push (cons (slot-spec-name slot-spec) newcell) + (cells self))))) + +(defun md-map-cells (self type celldo) + (map type (lambda (cellentry) + (bwhen (cell (cdr cellentry)) + (unless (listp cell) + (funcall celldo cell)))) + (cells self))) + +(defun c-install (self sn c) + (c-assert (typep c 'cell)) + (trc nil "installing cell" sn c) + (setf + (c-model c) self + (c-slot-spec c) sn + (md-slot-cell self sn) c + (slot-value self sn) (when (typep c 'c-variable) + (c-value c)))) + +;------------------ md obj initialization ------------------ + +(defmethod shared-initialize :after ((self model-object) slotnames + &rest initargs &key fm-parent mdwhen + &allow-other-keys) + (declare (ignorable initargs slotnames fm-parent mdwhen)) + + (dolist (esd (class-slots (class-of self))) + (let* ((sn (slot-definition-name esd)) + (sv (when (slot-boundp self sn) + (slot-value self sn)))) + (when (typep sv 'cell) + (if (md-slot-cell-type (type-of self) sn) + (c-install self sn sv) + (when *c-debug* + (trc "warning: cell ~a offered for non-cellular model/slot ~a/~a" sv self sn)))))) + + (md-initialize self)) + +;;;(defun pick-if-when-slot (esd mdwhen &aux (cellwhen (cellwhen esd))) +;;; (or (null cellwhen) +;;; (some-x-is-in-y cellwhen mdwhen))) + +(defmethod md-initialize (self) + (setf (md-state self) :nascent)) + +(defun cells-clear (self) + "allow gc" + ;; + ;; too extreme? 'close-device went after slot when a class + ;; ended up without cells--should not be a crime 2k0320kt + ;; (slot-makunbound self '.cells) + ;; ... + (setf (cells self) nil) ;; try instead + ) + + +;--------- awaken only when ready (in family, for models) -------- + + +(defmethod md-awaken ((self model-object)) + (trc nil "md-awaken entry" self (md-state self)) + (c-assert (eql :nascent (md-state self))) + ;; (trc nil "awaken doing") + (count-it :md-awaken) + ;;(count-it 'mdawaken (type-of self)) + (setf (md-state self) :awakening) + ;; (trc "md-awaken entry" self) + (dolist (esd (class-slots (class-of self))) + (trc nil "md-awaken scoping slot" self (slot-definition-name esd)) + (when (md-slot-cell-type (type-of self) (slot-definition-name esd)) + (let ((slot-name (slot-definition-name esd))) + (if (not (c-echo-defined slot-name)) + (progn ;; (count-it :md-awaken :no-echo-slot slot-name) + (trc nil "md-awaken deferring cell-awaken since no echo" self esd)) + + (let ((cell (md-slot-cell self slot-name))) + (trc nil "md-awaken finds md-esd-cell " cell) + (when *c-debug* + ; + ; check to see if cell snuck into actual slot value... + ; + (bwhen (sv (slot-value self slot-name)) + (when (typep sv 'cell) + (c-break "md-awaken ~a found cell ~a in slot ~a" self sv esd)))) + + (if cell + (if (c-lazy-p cell) + (progn + (trc nil "md-awaken deferring cell-awaken since lazy" self esd)) + (c-awaken cell)) + (progn ;; next bit revised to avoid double-echo of optimized cells + (when (eql '.kids slot-name) + (bwhen (sv (slot-value self '.kids)) + (md-kids-change self sv nil :md-awaken-slot))) + (c-echo-initially self slot-name)))))))) + + (setf (md-state self) :awake) + self) +

Index: cells/optimization.lisp diff -u cells/optimization.lisp:1.1.1.1 cells/optimization.lisp:1.2 --- cells/optimization.lisp:1.1.1.1 Sat Nov 8 18:44:28 2003 +++ cells/optimization.lisp Tue Dec 16 10:02:58 2003 @@ -1,83 +1,83 @@ -;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- -;;; -;;; Copyright © 1995,2003 by Kenneth William Tilton. -;;; -;;; Permission is hereby granted, free of charge, to any person obtaining a copy -;;; of this software and associated documentation files (the "Software"), to deal -;;; in the Software without restriction, including without limitation the rights -;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell -;;; copies of the Software, and to permit persons to whom the Software is furnished -;;; to do so, subject to the following conditions: -;;; -;;; The above copyright notice and this permission notice shall be included in -;;; all copies or substantial portions of the Software. -;;; -;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING -;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS -;;; IN THE SOFTWARE. - -(in-package :cells) - -;____________ cell when ____________________ - -(defparameter *c-whentime* nil) - -(defun call-with-when-time? (whentimes function &aux old) - (rotatef old *c-whentime* whentimes) - ;; (trc "setting *c-whentime* to" *c-whentime*) - (unwind-protect - (funcall function) - (setf *c-whentime* old))) - -;---------- optimizing away cells whose dependents all turn out to be constant ---------------- -; - -(defun c-optimize-away?! (c) - - (typecase c - #+old-code - (c-nested (trc nil "optimize-away nested") - (when (and (null (cd-useds c))) - (rplaca (member c (cellnestedcells (cellaggregatecell c))) (c-value c)) - t)) - (c-dependent - (if (and *c-optimizep* - (c-validp c) - (null (cd-useds c))) - - (progn - (trc nil "optimizing away" c) - (count-it :c-optimized) - - (setf (c-state c) :optimized-away) - - (let ((entry (rassoc c (cells (c-model c))))) ; move from cells to cells-flushed - (assert entry) - (setf (cells (c-model c)) (delete entry (cells (c-model c)))) - (push entry (cells-flushed (c-model c)))) - - (dolist (user (un-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))) - - (setf ; drop foreign refs to aid gc (gc paranoia?) - (c-model c) nil - (un-users c) nil) - - t) - - (progn - (trc nil "not optimizing away" *c-optimizep* (car (cd-useds c)) (c-validp c)) - #+no (dolist (used (cd-useds c)) - (assert (member c (un-users used))) - ;;; (trc nil "found as user of" used) - ) - ; (count-it :c-not-optimize) - ; (count-it (intern-keyword "noopti-" #+nah (c-model c) "-" (symbol-name (c-slot-name c)))) - ))))) +;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- +;;; +;;; Copyright (c) 1995,2003 by Kenneth William Tilton. +;;; +;;; Permission is hereby granted, free of charge, to any person obtaining a copy +;;; of this software and associated documentation files (the "Software"), to deal +;;; in the Software without restriction, including without limitation the rights +;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +;;; copies of the Software, and to permit persons to whom the Software is furnished +;;; to do so, subject to the following conditions: +;;; +;;; The above copyright notice and this permission notice shall be included in +;;; all copies or substantial portions of the Software. +;;; +;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS +;;; IN THE SOFTWARE. + +(in-package :cells) + +;____________ cell when ____________________ + +(defparameter *c-whentime* nil) + +(defun call-with-when-time? (whentimes function &aux old) + (rotatef old *c-whentime* whentimes) + ;; (trc "setting *c-whentime* to" *c-whentime*) + (unwind-protect + (funcall function) + (setf *c-whentime* old))) + +;---------- optimizing away cells whose dependents all turn out to be constant ---------------- +; + +(defun c-optimize-away?! (c) + + (typecase c + #+old-code + (c-nested (trc nil "optimize-away nested") + (when (and (null (cd-useds c))) + (rplaca (member c (cellnestedcells (cellaggregatecell c))) (c-value c)) + t)) + (c-dependent + (if (and *c-optimizep* + (c-validp c) + (null (cd-useds c))) + + (progn + (trc nil "optimizing away" c) + (count-it :c-optimized) + + (setf (c-state c) :optimized-away) + + (let ((entry (rassoc c (cells (c-model c))))) ; move from cells to cells-flushed + (c-assert entry) + (setf (cells (c-model c)) (delete entry (cells (c-model c)))) + (push entry (cells-flushed (c-model c)))) + + (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))) + + (setf ; drop foreign refs to aid gc (gc paranoia?) + (c-model c) nil + (c-users c) nil) + + t) + + (progn + (trc nil "not optimizing away" *c-optimizep* (car (cd-useds c)) (c-validp c)) + #+no (dolist (used (cd-useds c)) + (c-assert (member c (c-users used))) + ;;; (trc nil "found as user of" used) + ) + ; (count-it :c-not-optimize) + ; (count-it (intern-keyword "noopti-" #+nah (c-model c) "-" (symbol-name (c-slot-name c)))) + )))))

Index: cells/propagate.lisp diff -u cells/propagate.lisp:1.1.1.1 cells/propagate.lisp:1.2 --- cells/propagate.lisp:1.1.1.1 Sat Nov 8 18:44:34 2003 +++ cells/propagate.lisp Tue Dec 16 10:02:58 2003 @@ -1,310 +1,308 @@ -;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- -;;; -;;; Copyright © 1995,2003 by Kenneth William Tilton. -;;; -;;; Permission is hereby granted, free of charge, to any person obtaining a copy -;;; of this software and associated documentation files (the "Software"), to deal -;;; in the Software without restriction, including without limitation the rights -;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell -;;; copies of the Software, and to permit persons to whom the Software is furnished -;;; to do so, subject to the following conditions: -;;; -;;; The above copyright notice and this permission notice shall be included in -;;; all copies or substantial portions of the Software. -;;; -;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING -;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS -;;; IN THE SOFTWARE. - -(in-package :cells) - -(defparameter *echodone* nil) - -(defun c-echo-defined (slot-name) - (getf (symbol-plist slot-name) :echo-defined)) - -(defmethod (setf c-true-stalep) (newvalue (user c-ruled)) - #+dfdbg (trc user "setting c-true-stalep" user newvalue) - (assert (find user (cells (c-model user)) :key #'cdr)) - (setf (cd-stale-p user) newvalue)) - -(defmethod (setf c-true-stalep) (newvalue (usersyn synapse)) - #+dfdbg (trc (syn-user usersyn) "synapse setting c-true-stalep" (syn-user usersyn) newvalue usersyn) - (setf (cd-stale-p (syn-user usersyn)) newvalue)) - -(defmethod (setf c-true-stalep) (newvalue other) - (declare (ignore other)) - newvalue) - -(defun c-echo-initially (self slot-spec) - "call during instance init. if echo is defined for slot, and value is non-nil (controversial) force initial echo." - (trc nil "c-echo-initially" self slot-spec - (c-echo-defined (slot-spec-name slot-spec)) - (md-slot-cell self slot-spec)) - (if (c-echo-defined (slot-spec-name slot-spec)) - (bif (c (md-slot-cell self slot-spec)) - (etypecase c - (c-variable (md-propagate self slot-spec (c-value c) nil nil)) - (c-ruled (md-slot-value self slot-spec))) ;; this will echo after calculating if not nil - ; - ; new for 22-03-07: echo even if slot value is nil... - (c-echo-slot-name (slot-spec-name slot-spec) - self - (bd-slot-value self slot-spec) - nil nil)) - (bwhen (c (md-slot-cell self slot-spec)) - (c-ephemeral-reset c)))) - -#-(or cormanlisp clisp) -(defgeneric c-echo-slot-name (slotname self new old old-boundp) (:method-combination progn)) - - -(defmethod c-echo-slot-name - #-(or cormanlisp clisp) progn - #+(or cormanlisp clisp) :before - (slot-name self new old old-boundp) - (declare (ignorable slot-name self new old old-boundp))) - -#+(or cormanlisp clisp) -(defmethod c-echo-slot-name (slot-name self new old old-boundp) - (declare (ignorable slot-name self new old old-boundp))) - -;--------------- propagate ---------------------------- -; -; n.b. 990414kt the cell argument may have been optimized away, -; though it is still receiving final processing here. -; - -(defun md-propagate (self slot-spec newvalue priorvalue priorvalue-supplied) - (when (mdead self) - (trc nil "md-propagate n-opping dead" self) - (return-from md-propagate nil)) - - (let (*c-calculators* - (*c-prop-depth* (1+ *c-prop-depth*)) - (c (md-slot-cell self slot-spec))) - ; - ;------ debug stuff --------- - ; - (when *stop* - (princ #.)(princ #!) - (return-from md-propagate)) - - (when c - (trc nil "md-propagate> propping" self slot-spec (length (un-users c)) c) - ) - - (when *c-debug* - (when (> *c-prop-depth* 250) - (trc "md-propagate deep" *c-prop-depth* self (slot-spec-name slot-spec) #+nah c)) - (when (> *c-prop-depth* 300) - (break "md-propagate looping" c) - )) - - (when c - ; ------ flag dependents as stale ------------ - ; do before echo in case echo gets back to some user - ; - (dolist (user (un-users c)) - #+dfdbg (trc user "md-prop now setting stale (changer, stale):" c user) - (when (c-user-cares user) - (setf (c-true-stalep user) c)))) - - ; --- manifest new value as needed ----------- - (when (c-echo-defined (slot-spec-name slot-spec)) ;; /// faster than just dispatching? - (when c (trc nil "md-prop now echoing" c)) - (c-echo-slot-name (slot-spec-name slot-spec) - self - newvalue - priorvalue - priorvalue-supplied) - (when (mdead self) ;; hopefully expiration on perishable class - (return-from md-propagate))) - - (when c ; --- now propagate to dependents ------------ - (trc nil "md-prop checking dependents" c (un-users c)) - (let ((*cause* c)) - (dolist (user (un-users c)) - (unless (cmdead user) - (when (c-user-cares user) - (if (c-user-lazy user) - (progn - (trc nil "lazy user not being propagated to" user :by c) - (dolist (u (un-users user)) - (c-propagate-staleness u))) - (progn - (c-rethink user) - (when (mdead self) - (trc nil "md-propagate> self now dead after rethink user: ~a" self user) - (return-from md-propagate nil)) - ))))) - (c-ephemeral-reset c))))) - -(defmethod c-propagate-staleness ((c c-ruled)) - (trc nil "inheriting staleness" c) - (dolist (u (cr-users c)) - (c-propagate-staleness u))) - -(defmethod c-propagate-staleness ((s synapse)) - (trc "I hope this synapse isn't for efficiency" s) - (break) - (c-propagate-staleness (syn-user s))) - -(defmethod c-propagate-staleness (c) - (declare (ignorable c)) - (trc "not inheriting or proagating staleness" c) - ) - -(defmethod c-user-cares (c) c) ;; ie, t -(defmethod c-user-cares ((s synapse)) - (syn-relevant s)) - -(defmethod c-user-lazy (c) (declare (ignore c)) nil) -(defmethod c-user-lazy ((c c-ruled)) - (cr-lazy c)) - - -(defun c-ephemeral-reset (c) - (when c - (when (c-ephemeral-p c) - (trc nil "c-ephemeral-reset resetting:" c) - (setf (c-value c) nil)))) ;; good q: what does (setf <ephem> 'x) return? historically nil, but...? - -;----------------- change detection --------------------------------- - -(defun c-no-news (c newvalue oldvalue) - ;;; (trc nil "c-no-news > checking news between" newvalue oldvalue) - - (if (unst-delta-p c) - (c-identity-p newvalue) - (bIf (test (c-unchanged-test (c-model c) (c-slot-name c))) - (funcall test newvalue oldvalue) - (eql newvalue oldvalue)))) - -(defmacro def-c-unchanged-test ((class slotname) &body test) - `(defmethod c-unchanged-test ((self ,class) (slotname (eql ',slotname))) - ,@test)) - -(defmethod c-unchanged-test (self slotname) - (declare (ignore self slotname)) - nil) - -(defmethod c-identity-p ((value null)) t) -(defmethod c-identity-p ((value number)) (zerop value)) -(defmethod c-identity-p ((value cons)) - ;; this def a little suspect? - (and (c-identity-p (car value)) - (c-identity-p (cdr value)))) - - -;------------------- re think --------------------------------- - -(defun cmdead (c) - (if (typep c 'synapse) - (cmdead (syn-user c)) - (if (null (c-model c)) - (not (c-optimized-away-p c)) - (mdead (c-model c))))) - -(defun mdead (m) (eq :eternal-rest (md-state m))) - -(defun c-rethink (c) - (when *stop* - (princ #.) - (return-from c-rethink)) - ;;(trc "rethink entry: c, true-stale" c (c-true-stalep c)) - (assert (not (cmdead c))() "rethink entry cmdead ~a" c) - (unless (c-true-stalep c) - (return-from c-rethink)) - - (when *rethink-deferred* - (trc nil "bingo!!!!!! rethink deferring" c *cause*) - (push (list c *cause*) *rethink-deferred*) - (return-from c-rethink)) - - (assert (not (cmdead c))() "rethink here?? cmdead ~a" c) - - ; looking ahead for interference avoids JIT detection, which where a dependency - ; already exists causes re-entrance into the rule, which should calculate the same - ; value twice and echo only once, but still seems like something to avoid since - ; we do already have the technology. - ; - - (bIf (interf (sw-detect-interference c nil)) - (progn - (trc "!!!!!!!!!! rethink of " c :held-up-by interf) - (c-pending-set c interf :interfered) - #+dfdbg (when (trcp c) - (trc "!!!!!!!!!! rethink of " c :held-up-by interf) - #+nah (dump-stale-path interf) - ) - (return-from c-rethink)) - (when (sw-pending c) - (trc nil "no interference now for " c) - (c-pending-set c nil :dis-interfered))) - - (when (cmdead c) - (trc nil "woohoo!!! interference checking finished model off" c) - (return-from c-rethink)) - - (unless (c-true-stalep c) - (trc nil "woohoo!!! interference checking refreshed" c) - (return-from c-rethink)) - - (typecase c - (c-ruled (c-calculate-and-set c)) - - (synapse - (trc nil "c-rethink > testing rethink of: syn,salv,valu" c salvage (c-value (syn-used c))) - (if (funcall (syn-fire-p c) c (c-value (syn-used c))) - (progn - (trc nil "c-rethink> decide yes on rethink on syn, valu" c (c-value (syn-used c))) - (c-rethink (syn-user c))) - (trc nil "c-rethink> decide nooooo on rethink on synapse" c (syn-user c) salvage))) - )) - -(defmacro def-c-echo (slotname - (&optional (selfarg 'self) (newvarg 'new-value) - (oldvarg 'old-value) (oldvargboundp 'old-value-boundp)) - &body echobody) - ;;;(trc "echo body" echobody) - `(progn - (eval-when (:compile-toplevel :load-toplevel :execute) - (setf (get ',slotname :echo-defined) t)) - ,(if (eql (last1 echobody) :test) - (let ((temp1 (gensym)) - (loc-self (gensym))) - `(defmethod c-echo-slot-name #-(or clisp cormanlisp) progn ((slotname (eql ',slotname)) ,selfarg ,newvarg ,oldvarg ,oldvargboundp) - (let ((,temp1 (bump-echo-count ,slotname)) - (,loc-self ,(if (listp selfarg) - (car selfarg) - selfarg))) - (when (and ,oldvargboundp ,oldvarg) - (format t "~&echo ~d (~a ~a) old: ~a" ,temp1 ',slotname ,loc-self ,oldvarg)) - (format t "~&echo ~d (~a ~a) new: ~a" ,temp1 ',slotname ,loc-self ,newvarg)))) - `(defmethod c-echo-slot-name - #-(or clisp cormanlisp) progn - ((slotname (eql ',slotname)) ,selfarg ,newvarg ,oldvarg ,oldvargboundp) - (declare (ignorable ,(etypecase selfarg - (list (car selfarg)) - (atom selfarg)) - ,(etypecase newvarg - (list (car newvarg)) - (atom newvarg)) - ,(etypecase oldvarg - (list (car oldvarg)) - (atom oldvarg)) - ,(etypecase oldvargboundp - (list (car oldvargboundp)) - (atom oldvargboundp)))) - ,@echobody)))) - -(defmacro bump-echo-count (slotname) ;; pure test func - `(if (get ',slotname :echos) - (incf (get ',slotname :echos)) - (setf (get ',slotname :echos) 1))) - +;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- +;;; +;;; Copyright (c) 1995,2003 by Kenneth William Tilton. +;;; +;;; Permission is hereby granted, free of charge, to any person obtaining a copy +;;; of this software and associated documentation files (the "Software"), to deal +;;; in the Software without restriction, including without limitation the rights +;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +;;; copies of the Software, and to permit persons to whom the Software is furnished +;;; to do so, subject to the following conditions: +;;; +;;; The above copyright notice and this permission notice shall be included in +;;; all copies or substantial portions of the Software. +;;; +;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS +;;; IN THE SOFTWARE. + +(in-package :cells) + +(defparameter *echodone* nil) + +(defun c-echo-defined (slot-name) + (getf (symbol-plist slot-name) :echo-defined)) + +(defmethod (setf c-true-stalep) (newvalue (user c-ruled)) + #+dfdbg (trc user "setting c-true-stalep" user newvalue) + (c-assert (find user (cells (c-model user)) :key #'cdr)) + (setf (cd-stale-p user) newvalue)) + +(defmethod (setf c-true-stalep) (newvalue (usersyn synapse)) + #+dfdbg (trc (syn-user usersyn) "synapse setting c-true-stalep" (syn-user usersyn) newvalue usersyn) + (setf (cd-stale-p (syn-user usersyn)) newvalue)) + +(defmethod (setf c-true-stalep) (newvalue other) + (declare (ignore other)) + newvalue) + +(defun c-echo-initially (self slot-spec) + "call during instance init. if echo is defined for slot, and value is non-nil (controversial) force initial echo." + (trc nil "c-echo-initially" self slot-spec + (c-echo-defined (slot-spec-name slot-spec)) + (md-slot-cell self slot-spec)) + (if (c-echo-defined (slot-spec-name slot-spec)) + (bif (c (md-slot-cell self slot-spec)) + (etypecase c + (c-variable (md-propagate self slot-spec (c-value c) nil nil)) + (c-ruled (md-slot-value self slot-spec))) ;; this will echo after calculating if not nil + ; + ; new for 22-03-07: echo even if slot value is nil... + (c-echo-slot-name (slot-spec-name slot-spec) + self + (bd-slot-value self slot-spec) + nil nil)) + (bwhen (c (md-slot-cell self slot-spec)) + (c-ephemeral-reset c)))) + +#-(or cormanlisp clisp) +(defgeneric c-echo-slot-name (slotname self new old old-boundp) (:method-combination progn)) + + +(defmethod c-echo-slot-name + #-(or cormanlisp clisp) progn + #+(or cormanlisp clisp) :before + (slot-name self new old old-boundp) + (declare (ignorable slot-name self new old old-boundp))) + +#+(or cormanlisp clisp) +(defmethod c-echo-slot-name (slot-name self new old old-boundp) + (declare (ignorable slot-name self new old old-boundp))) + +;--------------- propagate ---------------------------- +; +; n.b. 990414kt the cell argument may have been optimized away, +; though it is still receiving final processing here. +; + +(defun md-propagate (self slot-spec newvalue priorvalue priorvalue-supplied) + (when (mdead self) + (trc nil "md-propagate n-opping dead" self) + (return-from md-propagate nil)) + + (let (*c-calculators* + (*c-prop-depth* (1+ *c-prop-depth*)) + (c (md-slot-cell self slot-spec))) + ; + ;------ debug stuff --------- + ; + (when *stop* + (princ #.)(princ #!) + (return-from md-propagate)) + + (when c + (trc nil "md-propagate> propping" self slot-spec (length (c-users c)) c) + ) + + (when *c-debug* + (when (> *c-prop-depth* 250) + (trc "md-propagate deep" *c-prop-depth* self (slot-spec-name slot-spec) #+nah c)) + (when (> *c-prop-depth* 300) + (c-break "md-propagate looping ~c" c) + )) + + (when c + ; ------ flag dependents as stale ------------ + ; do before echo in case echo gets back to some user + ; + (dolist (user (c-users c)) + #+dfdbg (trc user "md-prop now setting stale (changer, stale):" c user) + (when (c-user-cares user) + (setf (c-true-stalep user) c)))) + + ; --- manifest new value as needed ----------- + (when (c-echo-defined (slot-spec-name slot-spec)) ;; /// faster than just dispatching? + (when c (trc nil "md-prop now echoing" c)) + (c-echo-slot-name (slot-spec-name slot-spec) + self + newvalue + priorvalue + priorvalue-supplied) + (when (mdead self) ;; hopefully expiration on perishable class + (return-from md-propagate))) + + (when c ; --- now propagate to dependents ------------ + (trc nil "md-prop checking dependents" c (c-users c)) + (let ((*cause* c)) + (dolist (user (c-users c)) + (unless (cmdead user) + (when (c-user-cares user) + (if (c-user-lazy user) + (progn + (trc nil "lazy user not being propagated to" user :by c) + (dolist (u (c-users user)) + (c-propagate-staleness u))) + (progn + (c-rethink user) + (when (mdead self) + (trc nil "md-propagate> self now dead after rethink user: ~a" self user) + (return-from md-propagate nil)) + ))))) + (c-ephemeral-reset c))))) + +(defmethod c-propagate-staleness ((c c-ruled)) + (trc nil "inheriting staleness" c) + (dolist (u (cr-users c)) + (c-propagate-staleness u))) + +(defmethod c-propagate-staleness ((s synapse)) + (trc "I hope this synapse isn't for efficiency" s) + (break) + (c-propagate-staleness (syn-user s))) + +(defmethod c-propagate-staleness (c) + (declare (ignorable c)) + (trc "not inheriting or proagating staleness" c) + ) + +(defmethod c-user-cares (c) c) ;; ie, t +(defmethod c-user-cares ((s synapse)) + (syn-relevant s)) + +(defmethod c-user-lazy (c) (declare (ignore c)) nil) +(defmethod c-user-lazy ((c c-ruled)) + (cr-lazy c)) + + +(defun c-ephemeral-reset (c) + (when c + (when (c-ephemeral-p c) + (trc nil "c-ephemeral-reset resetting:" c) + (setf (c-value c) nil)))) ;; good q: what does (setf <ephem> 'x) return? historically nil, but...? + +;----------------- change detection --------------------------------- + +(defun c-no-news (c newvalue oldvalue) + ;;; (trc nil "c-no-news > checking news between" newvalue oldvalue) + + (bIf (test (c-unchanged-test (c-model c) (c-slot-name c))) + (funcall test newvalue oldvalue) + (eql newvalue oldvalue))) + +(defmacro def-c-unchanged-test ((class slotname) &body test) + `(defmethod c-unchanged-test ((self ,class) (slotname (eql ',slotname))) + ,@test)) + +(defmethod c-unchanged-test (self slotname) + (declare (ignore self slotname)) + nil) + +(defmethod c-identity-p ((value null)) t) +(defmethod c-identity-p ((value number)) (zerop value)) +(defmethod c-identity-p ((value cons)) + ;; this def a little suspect? + (and (c-identity-p (car value)) + (c-identity-p (cdr value)))) + + +;------------------- re think --------------------------------- + +(defun cmdead (c) + (if (typep c 'synapse) + (cmdead (syn-user c)) + (if (null (c-model c)) + (not (c-optimized-away-p c)) + (mdead (c-model c))))) + +(defun mdead (m) (eq :eternal-rest (md-state m))) + +(defun c-rethink (c) + (when *stop* + (princ #.) + (return-from c-rethink)) + ;;(trc "rethink entry: c, true-stale" c (c-true-stalep c)) + (c-assert (not (cmdead c))() "rethink entry cmdead ~a" c) + (unless (c-true-stalep c) + (return-from c-rethink)) + + (when *rethink-deferred* + (trc nil "bingo!!!!!! rethink deferring" c *cause*) + (push (list c *cause*) *rethink-deferred*) + (return-from c-rethink)) + + (c-assert (not (cmdead c))() "rethink here?? cmdead ~a" c) + + ; looking ahead for interference avoids JIT detection, which where a dependency + ; already exists causes re-entrance into the rule, which should calculate the same + ; value twice and echo only once, but still seems like something to avoid since + ; we do already have the technology. + ; + + (bIf (interf (sw-detect-interference c nil)) + (progn + (trc "!!!!!!!!!! rethink of " c :held-up-by interf) + (c-pending-set c interf :interfered) + #+dfdbg (when (trcp c) + (trc "!!!!!!!!!! rethink of " c :held-up-by interf) + #+nah (dump-stale-path interf) + ) + (return-from c-rethink)) + (when (sw-pending c) + (trc nil "no interference now for " c) + (c-pending-set c nil :dis-interfered))) + + (when (cmdead c) + (trc nil "woohoo!!! interference checking finished model off" c) + (return-from c-rethink)) + + (unless (c-true-stalep c) + (trc nil "woohoo!!! interference checking refreshed" c) + (return-from c-rethink)) + + (typecase c + (c-ruled (c-calculate-and-set c)) + + (synapse + (trc nil "c-rethink > testing rethink of: syn,salv,valu" c salvage (c-value (syn-used c))) + (if (funcall (syn-fire-p c) c (c-value (syn-used c))) + (progn + (trc nil "c-rethink> decide yes on rethink on syn, valu" c (c-value (syn-used c))) + (c-rethink (syn-user c))) + (trc nil "c-rethink> decide nooooo on rethink on synapse" c (syn-user c) salvage))) + )) + +(defmacro def-c-echo (slotname + (&optional (selfarg 'self) (newvarg 'new-value) + (oldvarg 'old-value) (oldvargboundp 'old-value-boundp)) + &body echobody) + ;;;(trc "echo body" echobody) + `(progn + (eval-when (:compile-toplevel :load-toplevel :execute) + (setf (get ',slotname :echo-defined) t)) + ,(if (eql (last1 echobody) :test) + (let ((temp1 (gensym)) + (loc-self (gensym))) + `(defmethod c-echo-slot-name #-(or clisp cormanlisp) progn ((slotname (eql ',slotname)) ,selfarg ,newvarg ,oldvarg ,oldvargboundp) + (let ((,temp1 (bump-echo-count ,slotname)) + (,loc-self ,(if (listp selfarg) + (car selfarg) + selfarg))) + (when (and ,oldvargboundp ,oldvarg) + (format t "~&echo ~d (~a ~a) old: ~a" ,temp1 ',slotname ,loc-self ,oldvarg)) + (format t "~&echo ~d (~a ~a) new: ~a" ,temp1 ',slotname ,loc-self ,newvarg)))) + `(defmethod c-echo-slot-name + #-(or clisp cormanlisp) progn + ((slotname (eql ',slotname)) ,selfarg ,newvarg ,oldvarg ,oldvargboundp) + (declare (ignorable ,(etypecase selfarg + (list (car selfarg)) + (atom selfarg)) + ,(etypecase newvarg + (list (car newvarg)) + (atom newvarg)) + ,(etypecase oldvarg + (list (car oldvarg)) + (atom oldvarg)) + ,(etypecase oldvargboundp + (list (car oldvargboundp)) + (atom oldvargboundp)))) + ,@echobody)))) + +(defmacro bump-echo-count (slotname) ;; pure test func + `(if (get ',slotname :echos) + (incf (get ',slotname :echos)) + (setf (get ',slotname :echos) 1))) +

Index: cells/qells.lisp diff -u cells/qells.lisp:1.1.1.1 cells/qells.lisp:1.2 --- cells/qells.lisp:1.1.1.1 Sat Nov 8 18:44:34 2003 +++ cells/qells.lisp Tue Dec 16 10:02:58 2003 @@ -1,326 +1,326 @@ -;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- -;;; -;;; Copyright © 1995,2003 by Kenneth William Tilton. -;;; -;;; Permission is hereby granted, free of charge, to any person obtaining a copy -;;; of this software and associated documentation files (the "Software"), to deal -;;; in the Software without restriction, including without limitation the rights -;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell -;;; copies of the Software, and to permit persons to whom the Software is furnished -;;; to do so, subject to the following conditions: -;;; -;;; The above copyright notice and this permission notice shall be included in -;;; all copies or substantial portions of the Software. -;;; -;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING -;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS -;;; IN THE SOFTWARE. - -(in-package :cells) - - -(defconstant *c-optimizep* t) -(defvar *c-prop-depth* 0) -(defvar *rethinker* nil) -(defvar *rethink-deferred* nil) -(defvar *synapse-factory* nil) -(defvar *sw-looping* nil) - -(defun cell-reset () - (kwt-reset) - (setf - *c-prop-depth* 0 - *sw-looping* nil - *to-be-awakened* nil - )) - - -(defun cellstop () - (break :in-cell-stop) - (setf *stop* t)) - -(defun cellbrk (&optional (tag :anon)) - (unless (or *stop*) - ;; daring move, hoping having handler at outside stops the game (cellstop) - (print `(cell break , tag)) - (break))) - -(defparameter *c-debug* - #+runtime-system nil - #-runtime-system nil) ;; make latter t when in trouble - - -(defvar *c-calculators* nil) - -(defmacro without-c-dependency (&body body) - `(let (*c-calculators*) ,@body)) - -(defun slot-spec-name (slot-spec) - slot-spec) - -(cc-defstruct (cell (:conc-name c-)) - waking-state - model - slot-spec - value - ) - -(defun c-slot-name (c) - (slot-spec-name (c-slot-spec c))) - -(defun c-validate (self c) - (when (not (and (c-slot-spec c) (c-model c))) -;;; (setf *stop* t) - (format t "~&unadopted cell: ~s md:~s, awake:~s" c self (c-waking-state self)) - (error 'c-unadopted :cell c))) - -(defmethod c-when (other) - (declare (ignorable other)) nil) ;; /// needs work - -(cc-defstruct (synapse - (:include cell) - (:conc-name syn-)) - user - used - fire-p - relay-value) - -(defmacro mksynapse ((&rest closeovervars) &key fire-p relay-value) - (let ((used (copy-symbol 'used)) (user (copy-symbol 'user))) - `(lambda (,used ,user) - ;; (trc "making synapse between user" ,user :and :used ,used) - (let (,@closeovervars) - (make-synapse - :used ,used - ;;; 210207kt why? use (c-model (syn-used <syn>)) :c-model (c-model ,used) - :user ,user - - :fire-p ,fire-p - :relay-value ,relay-value))))) - -(defmethod print-object ((syn synapse) stream) - (format stream "{syn ~s ==> ~s" (syn-used syn) (syn-user syn))) - - -(defmethod c-true-stalep ((syn synapse)) - (cd-stale-p (syn-user syn))) - -(cc-defstruct (c-user-notifying - (:include cell) - (:conc-name un-)) - (users nil :type list)) - -(cc-defstruct (c-unsteady - (:include c-user-notifying) - (:conc-name unst-)) - cyclic-p - delta-p - setting-p) - -(cc-defstruct (c-variable - (:include c-unsteady))) - -(cc-defstruct (c-ruled - (:include c-unsteady) - (:conc-name cr-)) - (state :unbound :type symbol) - (rethinking 0 :type number) - rule) - -(defun c-optimized-away-p (c) - (eql :optimized-away (c-state c))) - -;---------------------------- - - -(defmethod c-true-stalep (c) - (declare (ignore c))) - -(cc-defstruct (c-independent - ;; - ;; these do not optimize away, because also these can be set after initial evaluation of the rule, - ;; so users better stay tuned. - ;; the whole idea here is that the old idea of having cv bodies evaluated immediately finally - ;; broke down when we wanted to say :kids (cv (list (fm-other vertex))) - ;; - (:include c-ruled))) - -;;;(defmethod trcp ((c c-dependent)) -;;; (trcp (c-model c))) - -(cc-defstruct (c-dependent - (:include c-ruled) - (:conc-name cd-)) - (useds nil :type list) - (code nil :type list) ;; /// feature this out on production build - (usage (make-array *cd-usagect* :element-type 'bit - :initial-element 0) :type vector) - stale-p - ) - - -(defmethod c-true-stalep ((c c-dependent)) - (cd-stale-p c)) - -(cc-defstruct (c-stream - (:include c-ruled) - (:conc-name cs-)) - values) - -;;; (defmacro cell~ (&body body) -;;; `(make-c-stream -;;; :rule (lambda ,@*c-lambda* -;;; ,@body))) - -(cc-defstruct (c-drifter - (:include c-dependent))) - -(cc-defstruct (c-drifter-absolute - (:include c-drifter))) - -;_____________________ accessors __________________________________ - - -(defun (setf c-state) (new-value c) - (if (typep c 'c-ruled) - (setf (cr-state c) new-value) - new-value)) - -(defun c-state (c) - (if (typep c 'c-ruled) - (cr-state c) - :valid)) - -(defun c-unboundp (c) - (eql :unbound (c-state c))) - -(defun c-validp (c) - (find (c-state c) '(:valid :optimized-away))) - -;_____________________ print __________________________________ - -(defmethod print-object :before ((c c-variable) stream) - (declare (ignorable c)) - (format stream "[var:")) - -(defmethod print-object :before ((c c-dependent) stream) - (declare (ignorable c)) - (format stream "[dep~a:" (cond - ((null (c-model c)) #\0) - ((eq :eternal-rest (md-state (c-model c))) #_) - ((cd-stale-p c) ##) - ((sw-pending c) #?) - (t #\space)))) - -(defmethod print-object :before ((c c-independent) stream) - (declare (ignorable c)) - (format stream "[ind:")) - -(defmethod print-object ((c cell) stream) - (c-print-value c stream) - (format stream "=~a/~a]" - (symbol-name (or (c-slot-name c) :anoncell)) - (or (c-model c) :anonmd)) - #+dfdbg (unless *stop* - (assert (find c (cells (c-model c)) :key #'cdr))) - ) - - -;__________________ - -(defmethod c-print-value ((c c-ruled) stream) - (format stream "~a" (cond ((unst-setting-p c) "<^^^>") - ((c-validp c) "<vld>") - ((c-unboundp c) "<unb>") - ((cd-stale-p c) "<obs>") - (t "<err>")))) - -(defmethod c-print-value (c stream) - (declare (ignore c stream))) - - -;____________________ constructors _______________________________ - -(defmacro c? (&body body) - `(make-c-dependent - :code ',body - :rule (lambda (c &aux (self (c-model c))) - (declare (ignorable self c)) - ,@body))) - (define-symbol-macro .cache. (c-value c)) - -(defmacro c?? ((&key (tagp nil) (in nil) (trigger nil) (out t))&body body) - (let ((result (copy-symbol 'result)) - (thetag (gensym))) - `(make-c-dependent - :code ',body - :rule (lambda (c &aux (self (c-model c))) - (declare (ignorable self c)) - (let ((,thetag (gensym "tag")) - (*trcdepth* (1+ *trcdepth*)) - ) - (declare (ignorable self ,thetag)) - ,(when in - `(trc "c??> entry" (c-slot-name c) (c-model c) (when ,tagp ,thetag))) - ,(when trigger `(trc "c??> trigger" *rethinker* c)) - (count-it :c?? (c-slot-name c) (md-name (c-model c))) - (let ((,result (progn ,@body))) - ,(when out `(trc "c?? result:" ,result (c-slot-name c) (when ,tagp ,thetag))) - ,result)))))) - - -(defmacro cv (defn) - `(make-c-variable - :value ,defn)) ;; use c-independent if need deferred execution - -(defmacro cv8 (defn) - `(make-c-variable - :cyclic-p t - :value ,defn)) ;; use c-independent if need deferred execution - - -(defmacro c... ((value) &body body) - `(make-c-drifter - :code ',body - :value ,value - :rule (lambda (c &aux (self (c-model c))) - (declare (ignorable self c)) - ,@body))) - -(defmacro c-abs (value &body body) - `(make-c-drifter-absolute - :code ',body - :value ,value - :rule (lambda (c &aux (self (c-model c))) - (declare (ignorable self c)) - ,@body))) - - -;;; (defmacro c?v (&body body) -;;; `(make-c-independent -;;; :rule (lambda ,@*c-lambda* -;;; (declare (ignorable self askingcells)) -;;; ,@body))) -;;; -;;; (defmacro cvpi ((&body options) defn) -;;; `(make-c-variable :value ,defn -;;; ,@options)) -;;; -;;; (defmacro ts? (&body body) -;;; `(lambda (self) -;;; (declare (ignorable self)) -;;; ,@body)) -;;; -(defmacro c8 (&body body) - `(make-c-dependent - :cyclic-p t - :rule (lambda (c) - (let ((self (c-model c)) - (*c-calculators* (cons c *c-calculators*)) - *synapse-factory* ;; clear then re-estab via with-synapse on specific dependencies - ) - ,@body)))) +;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- +;;; +;;; Copyright (c) 1995,2003 by Kenneth William Tilton. +;;; +;;; Permission is hereby granted, free of charge, to any person obtaining a copy +;;; of this software and associated documentation files (the "Software"), to deal +;;; in the Software without restriction, including without limitation the rights +;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +;;; copies of the Software, and to permit persons to whom the Software is furnished +;;; to do so, subject to the following conditions: +;;; +;;; The above copyright notice and this permission notice shall be included in +;;; all copies or substantial portions of the Software. +;;; +;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS +;;; IN THE SOFTWARE. + +(in-package :cells) + + +(defconstant *c-optimizep* t) +(defvar *c-prop-depth* 0) +(defvar *rethinker* nil) +(defvar *rethink-deferred* nil) +(defvar *synapse-factory* nil) +(defvar *sw-looping* nil) + +(defun cell-reset () + (kwt-reset) + (setf + *c-prop-depth* 0 + *sw-looping* nil + *to-be-awakened* nil + )) + + +(defun cellstop () + (break :in-cell-stop) + (setf *stop* t)) + +(defun cellbrk (&optional (tag :anon)) + (unless (or *stop*) + ;; daring move, hoping having handler at outside stops the game (cellstop) + (print `(cell break , tag)) + (break))) + +(defparameter *c-debug* + #+runtime-system nil + #-runtime-system nil) ;; make latter t when in trouble + + +(defvar *c-calculators* nil) + +(defmacro without-c-dependency (&body body) + `(let (*c-calculators*) ,@body)) + +(defun slot-spec-name (slot-spec) + slot-spec) + +(cc-defstruct (cell (:conc-name c-)) + waking-state + model + slot-spec + value + ) + +(defun c-slot-name (c) + (slot-spec-name (c-slot-spec c))) + +(defun c-validate (self c) + (when (not (and (c-slot-spec c) (c-model c))) +;;; (setf *stop* t) + (format t "~&unadopted cell: ~s md:~s, awake:~s" c self (c-waking-state self)) + (error 'c-unadopted :cell c))) + +(defmethod c-when (other) + (declare (ignorable other)) nil) ;; /// needs work + +(cc-defstruct (synapse + (:include cell) + (:conc-name syn-)) + user + used + fire-p + relay-value) + +(defmacro mksynapse ((&rest closeovervars) &key fire-p relay-value) + (let ((used (copy-symbol 'used)) (user (copy-symbol 'user))) + `(lambda (,used ,user) + ;; (trc "making synapse between user" ,user :and :used ,used) + (let (,@closeovervars) + (make-synapse + :used ,used + ;;; 210207kt why? use (c-model (syn-used <syn>)) :c-model (c-model ,used) + :user ,user + + :fire-p ,fire-p + :relay-value ,relay-value))))) + +(defmethod print-object ((syn synapse) stream) + (format stream "{syn ~s ==> ~s" (syn-used syn) (syn-user syn))) + + +(defmethod c-true-stalep ((syn synapse)) + (cd-stale-p (syn-user syn))) + +(cc-defstruct (c-user-notifying + (:include cell) + (:conc-name un-)) + (users nil :type list)) + +(cc-defstruct (c-unsteady + (:include c-user-notifying) + (:conc-name unst-)) + cyclic-p + delta-p + setting-p) + +(cc-defstruct (c-variable + (:include c-unsteady))) + +(cc-defstruct (c-ruled + (:include c-unsteady) + (:conc-name cr-)) + (state :unbound :type symbol) + (rethinking 0 :type number) + rule) + +(defun c-optimized-away-p (c) + (eql :optimized-away (c-state c))) + +;---------------------------- + + +(defmethod c-true-stalep (c) + (declare (ignore c))) + +(cc-defstruct (c-independent + ;; + ;; these do not optimize away, because also these can be set after initial evaluation of the rule, + ;; so users better stay tuned. + ;; the whole idea here is that the old idea of having cv bodies evaluated immediately finally + ;; broke down when we wanted to say :kids (cv (list (fm-other vertex))) + ;; + (:include c-ruled))) + +;;;(defmethod trcp ((c c-dependent)) +;;; (trcp (c-model c))) + +(cc-defstruct (c-dependent + (:include c-ruled) + (:conc-name cd-)) + (useds nil :type list) + (code nil :type list) ;; /// feature this out on production build + (usage (make-array *cd-usagect* :element-type 'bit + :initial-element 0) :type vector) + stale-p + ) + + +(defmethod c-true-stalep ((c c-dependent)) + (cd-stale-p c)) + +(cc-defstruct (c-stream + (:include c-ruled) + (:conc-name cs-)) + values) + +;;; (defmacro cell~ (&body body) +;;; `(make-c-stream +;;; :rule (lambda ,@*c-lambda* +;;; ,@body))) + +(cc-defstruct (c-drifter + (:include c-dependent))) + +(cc-defstruct (c-drifter-absolute + (:include c-drifter))) + +;_____________________ accessors __________________________________ + + +(defun (setf c-state) (new-value c) + (if (typep c 'c-ruled) + (setf (cr-state c) new-value) + new-value)) + +(defun c-state (c) + (if (typep c 'c-ruled) + (cr-state c) + :valid)) + +(defun c-unboundp (c) + (eql :unbound (c-state c))) + +(defun c-validp (c) + (find (c-state c) '(:valid :optimized-away))) + +;_____________________ print __________________________________ + +(defmethod print-object :before ((c c-variable) stream) + (declare (ignorable c)) + (format stream "[var:")) + +(defmethod print-object :before ((c c-dependent) stream) + (declare (ignorable c)) + (format stream "[dep~a:" (cond + ((null (c-model c)) #\0) + ((eq :eternal-rest (md-state (c-model c))) #_) + ((cd-stale-p c) ##) + ((sw-pending c) #?) + (t #\space)))) + +(defmethod print-object :before ((c c-independent) stream) + (declare (ignorable c)) + (format stream "[ind:")) + +(defmethod print-object ((c cell) stream) + (c-print-value c stream) + (format stream "=~a/~a]" + (symbol-name (or (c-slot-name c) :anoncell)) + (or (c-model c) :anonmd)) + #+dfdbg (unless *stop* + (assert (find c (cells (c-model c)) :key #'cdr))) + ) + + +;__________________ + +(defmethod c-print-value ((c c-ruled) stream) + (format stream "~a" (cond ((unst-setting-p c) "<^^^>") + ((c-validp c) "<vld>") + ((c-unboundp c) "<unb>") + ((cd-stale-p c) "<obs>") + (t "<err>")))) + +(defmethod c-print-value (c stream) + (declare (ignore c stream))) + + +;____________________ constructors _______________________________ + +(defmacro c? (&body body) + `(make-c-dependent + :code ',body + :rule (lambda (c &aux (self (c-model c))) + (declare (ignorable self c)) + ,@body))) + (define-symbol-macro .cache. (c-value c)) + +(defmacro c?? ((&key (tagp nil) (in nil) (trigger nil) (out t))&body body) + (let ((result (copy-symbol 'result)) + (thetag (gensym))) + `(make-c-dependent + :code ',body + :rule (lambda (c &aux (self (c-model c))) + (declare (ignorable self c)) + (let ((,thetag (gensym "tag")) + (*trcdepth* (1+ *trcdepth*)) + ) + (declare (ignorable self ,thetag)) + ,(when in + `(trc "c??> entry" (c-slot-name c) (c-model c) (when ,tagp ,thetag))) + ,(when trigger `(trc "c??> trigger" *rethinker* c)) + (count-it :c?? (c-slot-name c) (md-name (c-model c))) + (let ((,result (progn ,@body))) + ,(when out `(trc "c?? result:" ,result (c-slot-name c) (when ,tagp ,thetag))) + ,result)))))) + + +(defmacro cv (defn) + `(make-c-variable + :value ,defn)) ;; use c-independent if need deferred execution + +(defmacro cv8 (defn) + `(make-c-variable + :cyclic-p t + :value ,defn)) ;; use c-independent if need deferred execution + + +(defmacro c... ((value) &body body) + `(make-c-drifter + :code ',body + :value ,value + :rule (lambda (c &aux (self (c-model c))) + (declare (ignorable self c)) + ,@body))) + +(defmacro c-abs (value &body body) + `(make-c-drifter-absolute + :code ',body + :value ,value + :rule (lambda (c &aux (self (c-model c))) + (declare (ignorable self c)) + ,@body))) + + +;;; (defmacro c?v (&body body) +;;; `(make-c-independent +;;; :rule (lambda ,@*c-lambda* +;;; (declare (ignorable self askingcells)) +;;; ,@body))) +;;; +;;; (defmacro cvpi ((&body options) defn) +;;; `(make-c-variable :value ,defn +;;; ,@options)) +;;; +;;; (defmacro ts? (&body body) +;;; `(lambda (self) +;;; (declare (ignorable self)) +;;; ,@body)) +;;; +(defmacro c8 (&body body) + `(make-c-dependent + :cyclic-p t + :rule (lambda (c) + (let ((self (c-model c)) + (*c-calculators* (cons c *c-calculators*)) + *synapse-factory* ;; clear then re-estab via with-synapse on specific dependencies + ) + ,@body))))

Index: cells/qrock.lisp diff -u cells/qrock.lisp:1.1.1.1 cells/qrock.lisp:1.2 --- cells/qrock.lisp:1.1.1.1 Sat Nov 8 18:44:46 2003 +++ cells/qrock.lisp Tue Dec 16 10:02:58 2003 @@ -1,83 +1,83 @@ -;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- -;;; -;;; -;;; Copyright © 1995,2003 by Kenneth William Tilton. -;;; -;;; Permission is hereby granted, free of charge, to any person obtaining a copy -;;; of this software and associated documentation files (the "Software"), to deal -;;; in the Software without restriction, including without limitation the rights -;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell -;;; copies of the Software, and to permit persons to whom the Software is furnished -;;; to do so, subject to the following conditions: -;;; -;;; The above copyright notice and this permission notice shall be included in -;;; all copies or substantial portions of the Software. -;;; -;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING -;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS -;;; IN THE SOFTWARE. - - -(in-package :cells) - -(defstruct (qrock (:include strudel-object)(:conc-name nil)) - (.accel 32) - (.elapsed (cv 0)) - (.dist (c? (floor (* (qaccel self)(expt (elapsed self) 2)) 2)))) - -(defun qaccel (self) - (q-slot-value (.accel self))) - -(defun (setf qaccel) (newvalue self) - (setf (md-slot-value self '.accel) newvalue)) - -(defun elapsed (self) - (q-slot-value (.elapsed self))) - -(defun (setf elapsed) (newvalue self) - (setf (md-slot-value self '.elapsed) newvalue)) - -(defun dist (self) - (q-slot-value (.dist self))) - -(defun (setf dist) (newvalue self) - (setf (md-slot-value self '.dist) newvalue)) - -(def-c-echo .accel () (trc ".accel" self new-value old-value)) -(def-c-echo .elapsed () - (when (typep new-value 'cell) (break)) - (trc ".elapsed" self new-value old-value)) -(def-c-echo .dist () (trc ".dist" self new-value old-value)) - -(progn - (setf (md-slot-cell-type 'qrock '.accel) t) - (setf (md-slot-cell-type 'qrock '.elapsed) t) - (setf (md-slot-cell-type 'qrock '.dist) t)) - -(defun make-cell-qrock (&rest iargs) - (let ((self (apply #'make-qrock iargs))) - (strudel-initialize self) - (trc "qcs" (q-cells self)) - self)) - -#+test -(let (*to-be-awakened*) - (let ((r (to-be (make-cell-qrock)))) - (dotimes (n 5) - (trc "--------------- time " n) - (setf (elapsed r) n)))) - -(defmethod strudel-initialize :around ((self qrock)) - (flet ((ci (sn sv) - (when (typep sv 'cell) - (q-install self sn sv)))) - (ci '.accel (.accel self)) - (ci '.elapsed (.elapsed self)) - (ci '.dist (.dist self))) - (call-next-method)) - - +;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- +;;; +;;; +;;; Copyright (c) 1995,2003 by Kenneth William Tilton. +;;; +;;; Permission is hereby granted, free of charge, to any person obtaining a copy +;;; of this software and associated documentation files (the "Software"), to deal +;;; in the Software without restriction, including without limitation the rights +;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +;;; copies of the Software, and to permit persons to whom the Software is furnished +;;; to do so, subject to the following conditions: +;;; +;;; The above copyright notice and this permission notice shall be included in +;;; all copies or substantial portions of the Software. +;;; +;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS +;;; IN THE SOFTWARE. + + +(in-package :cells) + +(defstruct (qrock (:include strudel-object)(:conc-name nil)) + (.accel 32) + (.elapsed (cv 0)) + (.dist (c? (floor (* (qaccel self)(expt (elapsed self) 2)) 2)))) + +(defun qaccel (self) + (q-slot-value (.accel self))) + +(defun (setf qaccel) (newvalue self) + (setf (md-slot-value self '.accel) newvalue)) + +(defun elapsed (self) + (q-slot-value (.elapsed self))) + +(defun (setf elapsed) (newvalue self) + (setf (md-slot-value self '.elapsed) newvalue)) + +(defun dist (self) + (q-slot-value (.dist self))) + +(defun (setf dist) (newvalue self) + (setf (md-slot-value self '.dist) newvalue)) + +(def-c-echo .accel () (trc ".accel" self new-value old-value)) +(def-c-echo .elapsed () + (when (typep new-value 'cell) (break)) + (trc ".elapsed" self new-value old-value)) +(def-c-echo .dist () (trc ".dist" self new-value old-value)) + +(progn + (setf (md-slot-cell-type 'qrock '.accel) t) + (setf (md-slot-cell-type 'qrock '.elapsed) t) + (setf (md-slot-cell-type 'qrock '.dist) t)) + +(defun make-cell-qrock (&rest iargs) + (let ((self (apply #'make-qrock iargs))) + (strudel-initialize self) + (trc "qcs" (q-cells self)) + self)) + +#+test +(let (*to-be-awakened*) + (let ((r (to-be (make-cell-qrock)))) + (dotimes (n 5) + (trc "--------------- time " n) + (setf (elapsed r) n)))) + +(defmethod strudel-initialize :around ((self qrock)) + (flet ((ci (sn sv) + (when (typep sv 'cell) + (q-install self sn sv)))) + (ci '.accel (.accel self)) + (ci '.elapsed (.elapsed self)) + (ci '.dist (.dist self))) + (call-next-method)) + +

Index: cells/slot-utilities.lisp diff -u cells/slot-utilities.lisp:1.1.1.1 cells/slot-utilities.lisp:1.2 --- cells/slot-utilities.lisp:1.1.1.1 Sat Nov 8 18:44:46 2003 +++ cells/slot-utilities.lisp Tue Dec 16 10:02:58 2003 @@ -1,91 +1,95 @@ -;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- -;;; -;;; Copyright © 1995,2003 by Kenneth William Tilton. -;;; -;;; Permission is hereby granted, free of charge, to any person obtaining a copy -;;; of this software and associated documentation files (the "Software"), to deal -;;; in the Software without restriction, including without limitation the rights -;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell -;;; copies of the Software, and to permit persons to whom the Software is furnished -;;; to do so, subject to the following conditions: -;;; -;;; The above copyright notice and this permission notice shall be included in -;;; all copies or substantial portions of the Software. -;;; -;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING -;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS -;;; IN THE SOFTWARE. - -(in-package :cells) - -(defun c-setting-debug (self slot-spec c newvalue) - (declare (ignorable newvalue)) - (if (null c) - (progn - (format t "c-setting-debug > constant ~a in ~a may not be altered..init to (cv nil)" - slot-spec self) - (error "setting-const-cell")) - (let ((self (c-model c)) - (slot-spec (c-slot-spec c))) - ;(trc "c-setting-debug sees" c newvalue self slot-spec) - (when (and c (not (and slot-spec self))) - ;; cv-test handles errors, so don't set *stop* (cellstop) - (error 'c-unadopted :cell c)) - (typecase c - (c-variable) - (c-independent) - (c-dependent - ;(trc "setting c-dependent" c newvalue) - (format t "c-setting-debug > ruled ~a in ~a may not be setf'ed" - (c-slot-name c) self) - (error "setting-ruled-cell")) - )))) - -(defun c-absorb-value (c value) - (typecase c - (c-drifter-absolute (c-value-incf c value 0)) ;; strange but true - (c-drifter (c-value-incf c (c-value c) value)) - (t value))) - -(defmethod c-value-incf (c (envaluer c-envaluer) delta) - (assert (c-model c)) - (c-value-incf c (funcall (envaluerule envaluer) (c-model c)) - delta)) - -(defmethod c-value-incf (c (base number) delta) - (declare (ignore c)) - (if delta - (+ base delta) - base)) - - -;---------------------------------------------------------------------- - -(defun bd-slot-value (self slot-spec) - (slot-value self (slot-spec-name slot-spec))) - -(defun (setf bd-slot-value) (newvalue self slot-spec) - (setf (slot-value self (slot-spec-name slot-spec)) newvalue)) - -(defun bd-bound-slot-value (self slot-spec callerid) - (declare (ignorable callerid)) - (when (bd-slot-boundp self (slot-spec-name slot-spec)) - (bd-slot-value self (slot-spec-name slot-spec)))) - -(defun bd-slot-boundp (self slot-spec) - (slot-boundp self (slot-spec-name slot-spec))) - -(defun bd-slot-makunbound (self slot-spec) - (slot-makunbound self (slot-spec-name slot-spec))) - -#| sample incf -(defmethod c-value-incf ((base fpoint) delta) - (declare (ignore model)) - (if delta - (fp-add base delta) - base)) -|# +;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- +;;; +;;; Copyright (c) 1995,2003 by Kenneth William Tilton. +;;; +;;; Permission is hereby granted, free of charge, to any person obtaining a copy +;;; of this software and associated documentation files (the "Software"), to deal +;;; in the Software without restriction, including without limitation the rights +;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +;;; copies of the Software, and to permit persons to whom the Software is furnished +;;; to do so, subject to the following conditions: +;;; +;;; The above copyright notice and this permission notice shall be included in +;;; all copies or substantial portions of the Software. +;;; +;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS +;;; IN THE SOFTWARE. + +(in-package :cells) + +(defun c-setting-debug (self slot-spec c newvalue) + (declare (ignorable newvalue)) + (if (null c) + (progn + (format t "c-setting-debug > constant ~a in ~a may not be altered..init to (cv nil)" + slot-spec self) + + (c-break "setting-const-cell") + (error "setting-const-cell")) + (let ((self (c-model c)) + (slot-spec (c-slot-spec c))) + ;(trc "c-setting-debug sees" c newvalue self slot-spec) + (when (and c (not (and slot-spec self))) + ;; cv-test handles errors, so don't set *stop* (c-stop) + (c-break "unadopted ~a for self ~a spec ~a" c self slot-spec) + (error 'c-unadopted :cell c)) + (typecase c + (c-variable) + (c-dependent + ;(trc "setting c-dependent" c newvalue) + (format t "c-setting-debug > ruled ~a in ~a may not be setf'ed" + (c-slot-name c) self) + + (c-break "setting-ruled-cell") + (error "setting-ruled-cell")) + )))) + +(defun c-absorb-value (c value) + (typecase c + (c-drifter-absolute (c-value-incf c value 0)) ;; strange but true + (c-drifter (c-value-incf c (c-value c) value)) + (t value))) + +(defmethod c-value-incf (c (envaluer c-envaluer) delta) + (c-assert (c-model c)) + (c-value-incf c (funcall (envaluerule envaluer) c) + delta)) + +(defmethod c-value-incf (c (base number) delta) + (declare (ignore c)) + (if delta + (+ base delta) + base)) + + +;---------------------------------------------------------------------- + +(defun bd-slot-value (self slot-spec) + (slot-value self (slot-spec-name slot-spec))) + +(defun (setf bd-slot-value) (newvalue self slot-spec) + (setf (slot-value self (slot-spec-name slot-spec)) newvalue)) + +(defun bd-bound-slot-value (self slot-spec callerid) + (declare (ignorable callerid)) + (when (bd-slot-boundp self (slot-spec-name slot-spec)) + (bd-slot-value self (slot-spec-name slot-spec)))) + +(defun bd-slot-boundp (self slot-spec) + (slot-boundp self (slot-spec-name slot-spec))) + +(defun bd-slot-makunbound (self slot-spec) + (slot-makunbound self (slot-spec-name slot-spec))) + +#| sample incf +(defmethod c-value-incf ((base fpoint) delta) + (declare (ignore model)) + (if delta + (fp-add base delta) + base)) +|#

Index: cells/strings.lisp diff -u cells/strings.lisp:1.1.1.1 cells/strings.lisp:1.2 --- cells/strings.lisp:1.1.1.1 Sat Nov 8 18:44:46 2003 +++ cells/strings.lisp Tue Dec 16 10:02:58 2003 @@ -1,204 +1,204 @@ -;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- -;;; -;;; Copyright © 1995,2003 by Kenneth William Tilton. -;;; -;;; Permission is hereby granted, free of charge, to any person obtaining a copy -;;; of this software and associated documentation files (the "Software"), to deal -;;; in the Software without restriction, including without limitation the rights -;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell -;;; copies of the Software, and to permit persons to whom the Software is furnished -;;; to do so, subject to the following conditions: -;;; -;;; The above copyright notice and this permission notice shall be included in -;;; all copies or substantial portions of the Software. -;;; -;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING -;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS -;;; IN THE SOFTWARE. - -(in-package :cells) - -(eval-when (compile load eval) - (export '(case$ strloc$ make$ space$ char$ conclist$ conc$ - left$ mid$ seg$ right$ insert$ remove$ - trim$ trunc$ abbrev$ empty$ find$ num$ - normalize$ down$ lower$ up$ upper$ equal$ - min$ numeric$ alpha$ assoc$ member$ match-left$ - +return$+ +LF$+))) - -(defmacro case$ (stringForm &rest cases) - (let ((v$ (gensym)) - (default (or (find 'otherwise cases :key #'car) - (find 'otherwise cases :key #'car)))) - (when default - (setf cases (delete default cases))) - `(let ((,v$ ,stringForm)) - (cond - ,@(mapcar (lambda (caseForms) - `((string-equal ,v$ ,(car caseForms)) ,@(rest caseForms))) - cases) - (t ,@(or (cdr default) `(nil))))))) - -;-------- - -(defmethod shortc (other) - (declare (ignorable other)) - (concatenate 'string "noshortc" (symbol-name (class-name (class-of other))))) - -(defmethod longc (other) (shortc other)) - -(defmethod shortc ((nada null)) nil) -(defmethod shortc ((many list)) - (if (consp (cdr many)) - (mapcar #'shortc many) - (conc$ (shortc (car many)) " " (shortc (cdr many))))) -(defmethod shortc ((self string)) self) -(defmethod shortc ((self symbol)) (string self)) -(defmethod shortc ((self number)) (num$ self)) -(defmethod shortc ((self character)) (string self)) - -;----------------------- - -(defun strloc$ (substr str) - (when (and substr str (not (string= substr ""))) - (search substr str))) - -(defun make$ (&optional (size 0) (char #\space)) - (make-string size :initial-element (etypecase char - (character char) - (number (code-char char))))) - -(DEFUN space$ (size) - (make$ size)) - -(defun char$ (char) - (make$ 1 char)) - -(defun conclist$ (ss) - (when ss - (reduce (lambda (s1 s2) (concatenate 'string s1 s2)) ss))) - -(defun conc$ (&rest ss) - (with-output-to-string (stream) - (dolist (s ss) - (when s - (princ (shortc s) stream))))) - -(defun left$ (s n) - (subseq s 0 (max (min n (length s)) 0))) - -(defun mid$ (s offset length) - (let* ((slen (length s)) - (start (min slen (max offset 0))) - (end (max start (min (+ offset length) slen)))) - (subseq s start end))) - -(defun seg$ (s offset end) - (let* ((slen (length s)) - (start (min slen (max offset 0))) - (end (max start (min end slen)))) - (subseq s start end))) - -(defun right$ (s n) - (subseq s (min n (length s)))) - -(defun insert$ (s c &optional (offset (length s))) - (conc$ (subseq s 0 offset) - (string c) - (subseq s offset))) - -(defun remove$ (s offset) - (conc$ (subseq s 0 (1- offset)) - (subseq s offset))) - -(defun trim$ (s) - (assert (or (null s) (stringp s))) - (string-trim '(#\space) s)) - -(defun trunc$ (s char) - (let ((pos (position char s))) - (if pos - (subseq s 0 pos) - s))) - -(defun abbrev$ (long$ max) - (if (<= (length long$) max) - long$ - (conc$ (left$ long$ (- max 3)) "..."))) - -(defmethod empty ((nada null)) t) -(defmethod empty ((c cons)) - (and (empty (car c)) - (empty (cdr c)))) -(defmethod empty ((s string)) (empty$ s)) -(defmethod empty (other) (declare (ignorable other)) nil) - -(defun empty$ (s) - (or (null s) - (if (stringp s) - (string-equal "" (trim$ s)) - #+not (trc nil "empty$> sees non-string" (type-of s))) - )) - -(defmacro find$ (it where &rest args) - `(find ,it ,where ,@args :test #'string-equal)) - -(defmethod num$ ((n number)) - (format nil "~d" n)) - -(defmethod num$ (n) - (format nil "~d" n)) - -(defun normalize$ (s) - (etypecase s - (null "") - (string (string-downcase s)) - (symbol (string-downcase (symbol-name s))))) - -(defun down$ (s) - (string-downcase s)) - -(defun lower$ (s) - (string-downcase s)) - -(defun up$ (s) - (string-upcase s)) - -(defun upper$ (s) - (string-upcase s)) - -(defun equal$ (s1 s2) - (if (empty$ s1) - (empty$ s2) - (when s2 - (string-equal s1 s2)))) - -(defun min$ (&rest ss) - (cond - ((null ss) nil) - ((null (cdr ss)) (car ss)) - (t (let ((rmin$ (apply #'min$ (cdr ss)))) - (if (string< (car ss) rmin$) - (car ss) rmin$))))) - -(defun numeric$ (s &optional trimmed) - (every (lambda (c) (digit-char-p c)) (if trimmed (Trim$ s) s))) - -(defun alpha$ (s) - (every (lambda (c) (alpha-char-p c)) s)) - -(defmacro assoc$ (item alist &rest kws) - `(assoc ,item ,alist :test #'equal ,@kws)) - -(defmacro member$ (item list &rest kws) - `(member ,item ,list :test #'string= ,@kws)) - -(defun match-left$ (a b) - (string-equal a (subseq b 0 (length a)))) - -(defparameter *return$* (conc$ (char$ #\return) (char$ #\linefeed))) -(defparameter *LF$* (string #\linefeed)) +;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- +;;; +;;; Copyright (c) 1995,2003 by Kenneth William Tilton. +;;; +;;; Permission is hereby granted, free of charge, to any person obtaining a copy +;;; of this software and associated documentation files (the "Software"), to deal +;;; in the Software without restriction, including without limitation the rights +;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +;;; copies of the Software, and to permit persons to whom the Software is furnished +;;; to do so, subject to the following conditions: +;;; +;;; The above copyright notice and this permission notice shall be included in +;;; all copies or substantial portions of the Software. +;;; +;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS +;;; IN THE SOFTWARE. + +(in-package :cells) + +(eval-when (compile load eval) + (export '(case$ strloc$ make$ space$ char$ conclist$ conc$ + left$ mid$ seg$ right$ insert$ remove$ + trim$ trunc$ abbrev$ empty$ find$ num$ + normalize$ down$ lower$ up$ upper$ equal$ + min$ numeric$ alpha$ assoc$ member$ match-left$ + +return$+ +LF$+))) + +(defmacro case$ (stringForm &rest cases) + (let ((v$ (gensym)) + (default (or (find 'otherwise cases :key #'car) + (find 'otherwise cases :key #'car)))) + (when default + (setf cases (delete default cases))) + `(let ((,v$ ,stringForm)) + (cond + ,@(mapcar (lambda (caseForms) + `((string-equal ,v$ ,(car caseForms)) ,@(rest caseForms))) + cases) + (t ,@(or (cdr default) `(nil))))))) + +;-------- + +(defmethod shortc (other) + (declare (ignorable other)) + (concatenate 'string "noshortc" (symbol-name (class-name (class-of other))))) + +(defmethod longc (other) (shortc other)) + +(defmethod shortc ((nada null)) nil) +(defmethod shortc ((many list)) + (if (consp (cdr many)) + (mapcar #'shortc many) + (conc$ (shortc (car many)) " " (shortc (cdr many))))) +(defmethod shortc ((self string)) self) +(defmethod shortc ((self symbol)) (string self)) +(defmethod shortc ((self number)) (num$ self)) +(defmethod shortc ((self character)) (string self)) + +;----------------------- + +(defun strloc$ (substr str) + (when (and substr str (not (string= substr ""))) + (search substr str))) + +(defun make$ (&optional (size 0) (char #\space)) + (make-string size :initial-element (etypecase char + (character char) + (number (code-char char))))) + +(DEFUN space$ (size) + (make$ size)) + +(defun char$ (char) + (make$ 1 char)) + +(defun conclist$ (ss) + (when ss + (reduce (lambda (s1 s2) (concatenate 'string s1 s2)) ss))) + +(defun conc$ (&rest ss) + (with-output-to-string (stream) + (dolist (s ss) + (when s + (princ (shortc s) stream))))) + +(defun left$ (s n) + (subseq s 0 (max (min n (length s)) 0))) + +(defun mid$ (s offset length) + (let* ((slen (length s)) + (start (min slen (max offset 0))) + (end (max start (min (+ offset length) slen)))) + (subseq s start end))) + +(defun seg$ (s offset end) + (let* ((slen (length s)) + (start (min slen (max offset 0))) + (end (max start (min end slen)))) + (subseq s start end))) + +(defun right$ (s n) + (subseq s (min n (length s)))) + +(defun insert$ (s c &optional (offset (length s))) + (conc$ (subseq s 0 offset) + (string c) + (subseq s offset))) + +(defun remove$ (s offset) + (conc$ (subseq s 0 (1- offset)) + (subseq s offset))) + +(defun trim$ (s) + (c-assert (or (null s) (stringp s))) + (string-trim '(#\space) s)) + +(defun trunc$ (s char) + (let ((pos (position char s))) + (if pos + (subseq s 0 pos) + s))) + +(defun abbrev$ (long$ max) + (if (<= (length long$) max) + long$ + (conc$ (left$ long$ (- max 3)) "..."))) + +(defmethod empty ((nada null)) t) +(defmethod empty ((c cons)) + (and (empty (car c)) + (empty (cdr c)))) +(defmethod empty ((s string)) (empty$ s)) +(defmethod empty (other) (declare (ignorable other)) nil) + +(defun empty$ (s) + (or (null s) + (if (stringp s) + (string-equal "" (trim$ s)) + #+not (trc nil "empty$> sees non-string" (type-of s))) + )) + +(defmacro find$ (it where &rest args) + `(find ,it ,where ,@args :test #'string-equal)) + +(defmethod num$ ((n number)) + (format nil "~d" n)) + +(defmethod num$ (n) + (format nil "~d" n)) + +(defun normalize$ (s) + (etypecase s + (null "") + (string (string-downcase s)) + (symbol (string-downcase (symbol-name s))))) + +(defun down$ (s) + (string-downcase s)) + +(defun lower$ (s) + (string-downcase s)) + +(defun up$ (s) + (string-upcase s)) + +(defun upper$ (s) + (string-upcase s)) + +(defun equal$ (s1 s2) + (if (empty$ s1) + (empty$ s2) + (when s2 + (string-equal s1 s2)))) + +(defun min$ (&rest ss) + (cond + ((null ss) nil) + ((null (cdr ss)) (car ss)) + (t (let ((rmin$ (apply #'min$ (cdr ss)))) + (if (string< (car ss) rmin$) + (car ss) rmin$))))) + +(defun numeric$ (s &optional trimmed) + (every (lambda (c) (digit-char-p c)) (if trimmed (Trim$ s) s))) + +(defun alpha$ (s) + (every (lambda (c) (alpha-char-p c)) s)) + +(defmacro assoc$ (item alist &rest kws) + `(assoc ,item ,alist :test #'equal ,@kws)) + +(defmacro member$ (item list &rest kws) + `(member ,item ,list :test #'string= ,@kws)) + +(defun match-left$ (a b) + (string-equal a (subseq b 0 (length a)))) + +(defparameter *return$* (conc$ (char$ #\return) (char$ #\linefeed))) +(defparameter *LF$* (string #\linefeed))

Index: cells/strudel-object.lisp diff -u cells/strudel-object.lisp:1.1.1.1 cells/strudel-object.lisp:1.2 --- cells/strudel-object.lisp:1.1.1.1 Sat Nov 8 18:44:46 2003 +++ cells/strudel-object.lisp Tue Dec 16 10:02:58 2003 @@ -1,145 +1,145 @@ -;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- -;;; -;;; -;;; Copyright © 1995,2003 by Kenneth William Tilton. -;;; -;;; Permission is hereby granted, free of charge, to any person obtaining a copy -;;; of this software and associated documentation files (the "Software"), to deal -;;; in the Software without restriction, including without limitation the rights -;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell -;;; copies of the Software, and to permit persons to whom the Software is furnished -;;; to do so, subject to the following conditions: -;;; -;;; The above copyright notice and this permission notice shall be included in -;;; all copies or substantial portions of the Software. -;;; -;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING -;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS -;;; IN THE SOFTWARE. - -(in-package :cells) - -;----------------- model-object ---------------------- - -(eval-when (:compile-toplevel :load-toplevel :execute) - (export '(strudel-object))) - -(cc-defstruct (strudel-object (:conc-name nil)) - (q-state :nascent :type keyword) ; [nil | :nascent | :alive | :doomed] - (q-name nil :type symbol) - (q-parent nil) - (q-cells nil :type list) - (q-cells-flushed nil :type list) - (q-adopt-ct 0 :type fixnum)) - -(defmethod strudel-initialize (self) - (unless (q-name self) - (setf (q-name self) (class-name (class-of self)))) - - #+wait (when (q-parent self) - (q-adopt (q-parent self) self)) - self) - -(defmethod cells ((self strudel-object)) - (q-cells self)) - -(defmethod (setf cells) (new-value (self strudel-object)) - (setf (q-cells self) new-value)) - -(defmethod kids ((other strudel-object)) nil) - -(defun q-install (self sn c) - (assert (typep c 'cell)) - (trc nil "installing cell" sn c) - (setf - (c-model c) self - (c-slot-spec c) sn - (md-slot-cell self sn) c)) - -(defmethod (setf md-state) (newv (self strudel-object)) - (setf (q-state self) newv)) - -(defmethod md-state ((self strudel-object)) - (q-state self)) - -(defmethod md-name ((self strudel-object)) (q-name self)) -(defmethod fmparent ((self strudel-object)) (q-parent self)) - -(defmethod print-object ((self strudel-object) s) - (format s "~a" (or (md-name self) (type-of self)))) - -(defun q-slot-value (slot-c) - (when *stop* - (princ #.) - (return-from q-slot-value)) - ;; (count-it :q-slot-value slot-name slot-spec)) - -;;; (when (eql :nascent (q-state self)) -;;; (md-awaken self)) - - (let ((slot-value (typecase slot-c - (c-variable (c-value slot-c)) - - (c-ruled (cond - ((c-validp slot-c) (c-value slot-c)) ;; good to go - - ((find slot-c *c-calculators*) ;; circularity - (setf *stop* t) - (trc "q-slot-value breaking on circlularity" slot-c *c-calculators*) - (error "cell ~a midst askers: ~a" slot-c *c-calculators*)) - - (t (let ((*cause* :on-demand)) ; normal path first time asked - (trc nil "md-slot-value calc" self slot-spec *c-calculators*) - (c-calculate-and-set slot-c))))) - (otherwise (return-from q-slot-value slot-c))))) - - (bif (synapse (when (car *c-calculators*) - (c-link-ex slot-c))) - (c-relay-value synapse slot-value) - slot-value))) - - - - -(defmethod md-awaken :around ((self strudel-object)) - (trc nil "md-awaken entry" self (md-state self)) - (assert (eql :nascent (md-state self))) - ;; (trc nil "awaken doing") - (count-it :md-awaken) - ;;(count-it 'mdawaken (type-of self)) - (setf (md-state self) :awakening) - ;; (trc "md-awaken entry" self) - (dolist (esd (class-slots (class-of self))) - ;;(trc "md-awaken scoping slot" self (slot-definition-name esd)) - (when (md-slot-cell-type (type-of self) (slot-definition-name esd)) - (let ((slot-name (slot-definition-name esd))) - (if (not (c-echo-defined slot-name)) - (progn ;; (count-it :md-awaken :no-echo-slot slot-name) - (trc nil "md-awaken deferring cell-awaken since no echo" self esd)) - - (let ((cell (md-slot-cell self slot-name))) - (trc nil "md-awaken finds md-esd-cell " self slot-name cell) - - - (if cell - (c-awaken cell) - ; - ; next bit revised to avoid double-echo of optimized cells - ; - (progn - (when (eql '.kids slot-name) - (bwhen (sv (slot-value self '.kids)) - (md-kids-change self sv nil :md-awaken-slot))) - (c-echo-initially self slot-name))))))) - ) - - (setf (md-state self) :awake) - self) - -(defmethod md-slot-value-store ((self strudel-object) slot-spec new-value) - (declare (ignorable slot-spec)) +;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- +;;; +;;; +;;; Copyright (c) 1995,2003 by Kenneth William Tilton. +;;; +;;; Permission is hereby granted, free of charge, to any person obtaining a copy +;;; of this software and associated documentation files (the "Software"), to deal +;;; in the Software without restriction, including without limitation the rights +;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +;;; copies of the Software, and to permit persons to whom the Software is furnished +;;; to do so, subject to the following conditions: +;;; +;;; The above copyright notice and this permission notice shall be included in +;;; all copies or substantial portions of the Software. +;;; +;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS +;;; IN THE SOFTWARE. + +(in-package :cells) + +;----------------- model-object ---------------------- + +(eval-when (:compile-toplevel :load-toplevel :execute) + (export '(strudel-object))) + +(cc-defstruct (strudel-object (:conc-name nil)) + (q-state :nascent :type keyword) ; [nil | :nascent | :alive | :doomed] + (q-name nil :type symbol) + (q-parent nil) + (q-cells nil :type list) + (q-cells-flushed nil :type list) + (q-adopt-ct 0 :type fixnum)) + +(defmethod strudel-initialize (self) + (unless (q-name self) + (setf (q-name self) (class-name (class-of self)))) + + #+wait (when (q-parent self) + (q-adopt (q-parent self) self)) + self) + +(defmethod cells ((self strudel-object)) + (q-cells self)) + +(defmethod (setf cells) (new-value (self strudel-object)) + (setf (q-cells self) new-value)) + +(defmethod kids ((other strudel-object)) nil) + +(defun q-install (self sn c) + (assert (typep c 'cell)) + (trc nil "installing cell" sn c) + (setf + (c-model c) self + (c-slot-spec c) sn + (md-slot-cell self sn) c)) + +(defmethod (setf md-state) (newv (self strudel-object)) + (setf (q-state self) newv)) + +(defmethod md-state ((self strudel-object)) + (q-state self)) + +(defmethod md-name ((self strudel-object)) (q-name self)) +(defmethod fm-parent ((self strudel-object)) (q-parent self)) + +(defmethod print-object ((self strudel-object) s) + (format s "~a" (or (md-name self) (type-of self)))) + +(defun q-slot-value (slot-c) + (when *stop* + (princ #.) + (return-from q-slot-value)) + ;; (count-it :q-slot-value slot-name slot-spec)) + +;;; (when (eql :nascent (q-state self)) +;;; (md-awaken self)) + + (let ((slot-value (typecase slot-c + (c-variable (c-value slot-c)) + + (c-ruled (cond + ((c-validp slot-c) (c-value slot-c)) ;; good to go + + ((find slot-c *c-calculators*) ;; circularity + (setf *stop* t) + (trc "q-slot-value breaking on circlularity" slot-c *c-calculators*) + (error "cell ~a midst askers: ~a" slot-c *c-calculators*)) + + (t (let ((*cause* :on-demand)) ; normal path first time asked + (trc nil "md-slot-value calc" self slot-spec *c-calculators*) + (c-calculate-and-set slot-c))))) + (otherwise (return-from q-slot-value slot-c))))) + + (bif (synapse (when (car *c-calculators*) + (c-link-ex slot-c))) + (c-relay-value synapse slot-value) + slot-value))) + + + + +(defmethod md-awaken :around ((self strudel-object)) + (trc nil "md-awaken entry" self (md-state self)) + (assert (eql :nascent (md-state self))) + ;; (trc nil "awaken doing") + (count-it :md-awaken) + ;;(count-it 'mdawaken (type-of self)) + (setf (md-state self) :awakening) + ;; (trc "md-awaken entry" self) + (dolist (esd (class-slots (class-of self))) + ;;(trc "md-awaken scoping slot" self (slot-definition-name esd)) + (when (md-slot-cell-type (type-of self) (slot-definition-name esd)) + (let ((slot-name (slot-definition-name esd))) + (if (not (c-echo-defined slot-name)) + (progn ;; (count-it :md-awaken :no-echo-slot slot-name) + (trc nil "md-awaken deferring cell-awaken since no echo" self esd)) + + (let ((cell (md-slot-cell self slot-name))) + (trc nil "md-awaken finds md-esd-cell " self slot-name cell) + + + (if cell + (c-awaken cell) + ; + ; next bit revised to avoid double-echo of optimized cells + ; + (progn + (when (eql '.kids slot-name) + (bwhen (sv (slot-value self '.kids)) + (md-kids-change self sv nil :md-awaken-slot))) + (c-echo-initially self slot-name))))))) + ) + + (setf (md-state self) :awake) + self) + +(defmethod md-slot-value-store ((self strudel-object) slot-spec new-value) + (declare (ignorable slot-spec)) new-value)

Index: cells/synapse.lisp diff -u cells/synapse.lisp:1.1.1.1 cells/synapse.lisp:1.2 --- cells/synapse.lisp:1.1.1.1 Sat Nov 8 18:44:46 2003 +++ cells/synapse.lisp Tue Dec 16 10:02:58 2003 @@ -1,213 +1,213 @@ -;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- -;;; -;;; Copyright © 1995,2003 by Kenneth William Tilton. -;;; -;;; Permission is hereby granted, free of charge, to any person obtaining a copy -;;; of this software and associated documentation files (the "Software"), to deal -;;; in the Software without restriction, including without limitation the rights -;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell -;;; copies of the Software, and to permit persons to whom the Software is furnished -;;; to do so, subject to the following conditions: -;;; -;;; The above copyright notice and this permission notice shall be included in -;;; all copies or substantial portions of the Software. -;;; -;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING -;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS -;;; IN THE SOFTWARE. - -(in-package :cells) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (export '(mksynapse fDelta fSensitivity fPlusp fZerop fDifferent))) - -; ___________________________ cell relay value ___________________________________ - -(defparameter *relayspeak* nil) -(defmethod c-relay-value ((syn synapse) value) - ;(trc "c-relay-value> syn, raw value:" syn value) - (let ((res (funcall (syn-relay-value syn) syn value))) - ;(trc "c-relay-value> cell, filtered value:" syn res) - res)) - -(defmethod c-relay-value (cell value) - (declare (ignorable cell)) - (when *relayspeak* - (trc "c-relay-value unspecial > cell value" cell value) - (setf *relayspeak* nil)) - value) - -;__________________________________________________________________________________ -; -(defmethod delta-diff ((new number) (old number) subtypename) - (declare (ignore subtypename)) - (- new old)) - -(defmethod delta-identity ((dispatcher number) subtypename) - (declare (ignore subtypename)) - 0) - -(defmethod delta-abs ((n number) subtypename) - (declare (ignore subtypename)) - (abs n)) - -(defmethod delta-exceeds ((d1 number) (d2 number) subtypename) - (declare (ignore subtypename)) - (> d1 d2)) - -(defmethod delta-greater-or-equal ((d1 number) (d2 number) subtypename) - (declare (ignore subtypename)) - (>= d1 d2)) - -;_________________________________________________________________________________ -; -(defmethod delta-diff (new old (subtypename (eql 'boolean))) - (if new - (if old - :unchanged - :on) - (if old - :off - :unchanged))) - - -(defmethod delta-identity (dispatcher (subtypename (eql 'boolean))) - (declare (ignore dispatcher)) - :unchanged) - -;______________________________________________________________ - -(defun fdeltalist (&key (test #'true)) - (mksynapse (priorlist) - :fire-p (lambda (syn newlist) - (declare (ignorable syn)) - (or (find-if (lambda (new) - ;--- gaining one? ---- - (and (not (member new priorlist)) - (funcall test new))) - newlist) - (find-if (lambda (old) - ;--- losing one? ---- - (not (member old newlist))) ;; all olds have passed test, so skip test here - priorlist))) - - :relay-value (lambda (syn newlist) - (declare (ignorable syn)) - ;/// excess consing on long lists - (setf priorlist (remove-if-not test newlist))))) - -;_______________________________________________________________ - -(defun ffindonce (finderfn) - (mksynapse (bingo bingobound) - - :fire-p (lambda (syn newlist) - (declare (ignorable syn)) - (unless bingo ;; once found, yer done - (setf bingobound t - bingo (find-if finderfn newlist)))) - - :relay-value (lambda (syn newlist) - (declare (ignorable syn)) - (or bingo - (and (not bingobound) ;; don't bother if fire? already looked - (find-if finderfn newlist)))))) - -;___________________________________________________________________ - -(defun fsensitivity (sensitivity &optional subtypename) - (mksynapse (priorrelayvalue) - :fire-p (lambda (syn newvalue) - (declare (ignorable syn)) - (trc nil "fire-p decides" priorrelayvalue sensitivity) - (or (xor priorrelayvalue newvalue) - (eko (nil "fire-p decides" newvalue priorrelayvalue sensitivity) - (delta-greater-or-equal - (delta-abs (delta-diff newvalue priorrelayvalue subtypename) subtypename) - (delta-abs sensitivity subtypename) - subtypename)))) - - :relay-value (lambda (syn newvalue) - (declare (ignorable syn)) - (eko (nil "fsensitivity relays") - (setf priorrelayvalue newvalue)) ;; no modulation of value, but do record for next time - ))) - -(defun fPlusp () - (mksynapse (priorrelayvalue) - :fire-p (lambda (syn new-basis) - (declare (ignorable syn)) - (eko (nil "fPlusp fire-p decides" priorrelayvalue sensitivity) - (xor priorrelayvalue (plusp new-basis)))) - - :relay-value (lambda (syn new-basis) - (declare (ignorable syn)) - (eko (nil "fPlusp relays") - (setf priorrelayvalue (plusp new-basis))) ;; no modulation of value, but do record for next time - ))) - -(defun fZerop () - (mksynapse (priorrelayvalue) - :fire-p (lambda (syn new-basis) - (declare (ignorable syn)) - (eko (nil "fZerop fire-p decides") - (xor priorrelayvalue (zerop new-basis)))) - - :relay-value (lambda (syn new-basis) - (declare (ignorable syn)) - (eko (nil "fZerop relays") - (setf priorrelayvalue (zerop new-basis))) - ))) - -(defun fDifferent () - (mksynapse (prior-object) - :fire-p (lambda (syn new-object) - (declare (ignorable syn)) - (trc nil "fDiff: prior,new" (not (eql new-object prior-object)) - prior-object new-object) - (not (eql new-object prior-object))) - - :relay-value (lambda (syn new-object) - (declare (ignorable syn)) - (unless (eql new-object prior-object) - (setf prior-object new-object))) - )) -; -;____________________ synapse constructors _______________________________ -; -(defun fdelta (&key sensitivity (type 'number)) - (mksynapse (lastrelaybasis lastboundp) - :fire-p (lambda (syn newbasis) - (declare (ignorable syn)) - (eko (nil "delta fire-p") - (or (null sensitivity) - (let ((delta (delta-diff newbasis lastrelaybasis type))) - (delta-exceeds delta sensitivity type))))) - - :relay-value (lambda (syn newbasis) - (declare (ignorable syn)) - (prog1 - (if lastboundp - (delta-diff newbasis lastrelaybasis type) - (delta-identity newbasis type)) - ;(trc "filter yields to user, value" (c-slot-name user) (c-slot-spec syn) relayvalue) - ;(trc "fdelta > ********************* new lastrelay! " syn lastrelaybasis) - (setf lastboundp t) - (setf lastrelaybasis newbasis))) - )) - - - -(defmethod delta-exceeds (booldelta sensitivity (subtypename (eql 'boolean))) - (unless (eql booldelta :unchanged) - (or (eq sensitivity t) - (eq sensitivity booldelta)))) - -(defun fboolean (&optional (sensitivity 't)) - (fdelta :sensitivity sensitivity :type 'boolean)) - - +;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- +;;; +;;; Copyright (c) 1995,2003 by Kenneth William Tilton. +;;; +;;; Permission is hereby granted, free of charge, to any person obtaining a copy +;;; of this software and associated documentation files (the "Software"), to deal +;;; in the Software without restriction, including without limitation the rights +;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +;;; copies of the Software, and to permit persons to whom the Software is furnished +;;; to do so, subject to the following conditions: +;;; +;;; The above copyright notice and this permission notice shall be included in +;;; all copies or substantial portions of the Software. +;;; +;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS +;;; IN THE SOFTWARE. + +(in-package :cells) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (export '(mksynapse fDelta fSensitivity fPlusp fZerop fDifferent))) + +; ___________________________ cell relay value ___________________________________ + +(defparameter *relayspeak* nil) +(defmethod c-relay-value ((syn synapse) value) + ;(trc "c-relay-value> syn, raw value:" syn value) + (let ((res (funcall (syn-relay-value syn) syn value))) + ;(trc "c-relay-value> cell, filtered value:" syn res) + res)) + +(defmethod c-relay-value (cell value) + (declare (ignorable cell)) + (when *relayspeak* + (trc "c-relay-value unspecial > cell value" cell value) + (setf *relayspeak* nil)) + value) + +;__________________________________________________________________________________ +; +(defmethod delta-diff ((new number) (old number) subtypename) + (declare (ignore subtypename)) + (- new old)) + +(defmethod delta-identity ((dispatcher number) subtypename) + (declare (ignore subtypename)) + 0) + +(defmethod delta-abs ((n number) subtypename) + (declare (ignore subtypename)) + (abs n)) + +(defmethod delta-exceeds ((d1 number) (d2 number) subtypename) + (declare (ignore subtypename)) + (> d1 d2)) + +(defmethod delta-greater-or-equal ((d1 number) (d2 number) subtypename) + (declare (ignore subtypename)) + (>= d1 d2)) + +;_________________________________________________________________________________ +; +(defmethod delta-diff (new old (subtypename (eql 'boolean))) + (if new + (if old + :unchanged + :on) + (if old + :off + :unchanged))) + + +(defmethod delta-identity (dispatcher (subtypename (eql 'boolean))) + (declare (ignore dispatcher)) + :unchanged) + +;______________________________________________________________ + +(defun fdeltalist (&key (test #'true)) + (mksynapse (priorlist) + :fire-p (lambda (syn newlist) + (declare (ignorable syn)) + (or (find-if (lambda (new) + ;--- gaining one? ---- + (and (not (member new priorlist)) + (funcall test new))) + newlist) + (find-if (lambda (old) + ;--- losing one? ---- + (not (member old newlist))) ;; all olds have passed test, so skip test here + priorlist))) + + :relay-value (lambda (syn newlist) + (declare (ignorable syn)) + ;/// excess consing on long lists + (setf priorlist (remove-if-not test newlist))))) + +;_______________________________________________________________ + +(defun ffindonce (finderfn) + (mksynapse (bingo bingobound) + + :fire-p (lambda (syn newlist) + (declare (ignorable syn)) + (unless bingo ;; once found, yer done + (setf bingobound t + bingo (find-if finderfn newlist)))) + + :relay-value (lambda (syn newlist) + (declare (ignorable syn)) + (or bingo + (and (not bingobound) ;; don't bother if fire? already looked + (find-if finderfn newlist)))))) + +;___________________________________________________________________ + +(defun fsensitivity (sensitivity &optional subtypename) + (mksynapse (priorrelayvalue) + :fire-p (lambda (syn newvalue) + (declare (ignorable syn)) + (trc nil "fire-p decides" priorrelayvalue sensitivity) + (or (xor priorrelayvalue newvalue) + (eko (nil "fire-p decides" newvalue priorrelayvalue sensitivity) + (delta-greater-or-equal + (delta-abs (delta-diff newvalue priorrelayvalue subtypename) subtypename) + (delta-abs sensitivity subtypename) + subtypename)))) + + :relay-value (lambda (syn newvalue) + (declare (ignorable syn)) + (eko (nil "fsensitivity relays") + (setf priorrelayvalue newvalue)) ;; no modulation of value, but do record for next time + ))) + +(defun fPlusp () + (mksynapse (priorrelayvalue) + :fire-p (lambda (syn new-basis) + (declare (ignorable syn)) + (eko (nil "fPlusp fire-p decides" priorrelayvalue sensitivity) + (xor priorrelayvalue (plusp new-basis)))) + + :relay-value (lambda (syn new-basis) + (declare (ignorable syn)) + (eko (nil "fPlusp relays") + (setf priorrelayvalue (plusp new-basis))) ;; no modulation of value, but do record for next time + ))) + +(defun fZerop () + (mksynapse (priorrelayvalue) + :fire-p (lambda (syn new-basis) + (declare (ignorable syn)) + (eko (nil "fZerop fire-p decides") + (xor priorrelayvalue (zerop new-basis)))) + + :relay-value (lambda (syn new-basis) + (declare (ignorable syn)) + (eko (nil "fZerop relays") + (setf priorrelayvalue (zerop new-basis))) + ))) + +(defun fDifferent () + (mksynapse (prior-object) + :fire-p (lambda (syn new-object) + (declare (ignorable syn)) + (trc nil "fDiff: prior,new" (not (eql new-object prior-object)) + prior-object new-object) + (not (eql new-object prior-object))) + + :relay-value (lambda (syn new-object) + (declare (ignorable syn)) + (unless (eql new-object prior-object) + (setf prior-object new-object))) + )) +; +;____________________ synapse constructors _______________________________ +; +(defun fdelta (&key sensitivity (type 'number)) + (mksynapse (lastrelaybasis lastboundp) + :fire-p (lambda (syn newbasis) + (declare (ignorable syn)) + (eko (nil "delta fire-p") + (or (null sensitivity) + (let ((delta (delta-diff newbasis lastrelaybasis type))) + (delta-exceeds delta sensitivity type))))) + + :relay-value (lambda (syn newbasis) + (declare (ignorable syn)) + (prog1 + (if lastboundp + (delta-diff newbasis lastrelaybasis type) + (delta-identity newbasis type)) + ;(trc "filter yields to user, value" (c-slot-name user) (c-slot-spec syn) relayvalue) + ;(trc "fdelta > ********************* new lastrelay! " syn lastrelaybasis) + (setf lastboundp t) + (setf lastrelaybasis newbasis))) + )) + + + +(defmethod delta-exceeds (booldelta sensitivity (subtypename (eql 'boolean))) + (unless (eql booldelta :unchanged) + (or (eq sensitivity t) + (eq sensitivity booldelta)))) + +(defun fboolean (&optional (sensitivity 't)) + (fdelta :sensitivity sensitivity :type 'boolean)) + +