November 2007 - cells-cvs@common-lisp.net

[cells-cvs] CVS cells
by ktilton 30 Nov '07

30 Nov '07

Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv30806 Modified Files: family.lisp Log Message: --- /project/cells/cvsroot/cells/family.lisp 2007/11/30 16:51:18 1.20 +++ /project/cells/cvsroot/cells/family.lisp 2007/11/30 22:52:36 1.21 @@ -25,8 +25,7 @@ (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) - (.value :initform nil :accessor value :initarg :value) - (zdbg :initform nil :accessor dbg :initarg :dbg))) + (.value :initform nil :accessor value :initarg :value))) (defmethod fm-parent (other) (declare (ignore other))

1 0

[cells-cvs] CVS cells/doc
by ktilton 30 Nov '07

30 Nov '07

Update of /project/cells/cvsroot/cells/doc In directory clnet:/tmp/cvs-serv30806/doc Modified Files: 01-Cell-basics.lisp Log Message: --- /project/cells/cvsroot/cells/doc/01-Cell-basics.lisp 2006/11/04 20:52:01 1.5 +++ /project/cells/cvsroot/cells/doc/01-Cell-basics.lisp 2007/11/30 22:52:36 1.6 @@ -335,11 +335,12 @@ () (:default-initargs :kids (c-in nil) ;; or we cannot add any addend kids later - :value (c? (reduce #'+ (kids self) + :value (c? (trc "val rule runs") + (reduce #'+ (kids self) :initial-value 0 :key #'value)))) -(defobserver value ((self summer)) +(defobserver .value ((self summer)) (trc "the sum of the values of the kids is" new-value)) (defobserver .kids ((self summer))

1 0

[cells-cvs] CVS cells
by ktilton 30 Nov '07

30 Nov '07

Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv27387 Modified Files: cells.lisp integrity.lisp md-slot-value.lisp Log Message: --- /project/cells/cvsroot/cells/cells.lisp 2007/11/30 16:51:18 1.21 +++ /project/cells/cvsroot/cells/cells.lisp 2007/11/30 22:29:06 1.22 @@ -156,7 +156,7 @@ ) (c-stop args) (format t "c-break > stopping > ~a" args) - (apply 'break args)))) + (apply 'error args)))) --- /project/cells/cvsroot/cells/integrity.lisp 2007/11/30 16:51:18 1.18 +++ /project/cells/cvsroot/cells/integrity.lisp 2007/11/30 22:29:06 1.19 @@ -44,9 +44,6 @@ *within-integrity*) (defun call-with-integrity (opcode defer-info action) - (when (eq opcode :change) - (when (eq defer-info :focus) - (break "cwi focus change"))) (when *stop* (return-from call-with-integrity)) (if *within-integrity* --- /project/cells/cvsroot/cells/md-slot-value.lisp 2007/11/30 16:51:18 1.35 +++ /project/cells/cvsroot/cells/md-slot-value.lisp 2007/11/30 22:29:06 1.36 @@ -153,7 +153,7 @@ (setf caller-reiterated (eq caller c))) (c-break ;; break is problem when testing cells on some CLs "cell ~a midst askers (see above)" c) - (break "see listener for cell rule cycle diagnotics")) + (error "see listener for cell rule cycle diagnotics")) (multiple-value-bind (raw-value propagation-code) (calculate-and-link c)

1 0

[cells-cvs] CVS cells/cells-test
by ktilton 30 Nov '07

30 Nov '07

Update of /project/cells/cvsroot/cells/cells-test In directory clnet:/tmp/cvs-serv27387/cells-test Modified Files: cells-test.lpr person.lisp test.lisp Log Message: --- /project/cells/cvsroot/cells/cells-test/cells-test.lpr 2007/11/30 16:51:19 1.7 +++ /project/cells/cvsroot/cells/cells-test/cells-test.lpr 2007/11/30 22:29:06 1.8 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.1 [Windows] (Sep 29, 2007 20:23)"; cg: "1.103.2.10"; -*- +;; -*- lisp-version: "8.1 [Windows] (Oct 30, 2007 12:37)"; cg: "1.103.2.10"; -*- (in-package :cg-user) --- /project/cells/cvsroot/cells/cells-test/person.lisp 2006/03/16 05:22:08 1.3 +++ /project/cells/cvsroot/cells/cells-test/person.lisp 2007/11/30 22:29:06 1.4 @@ -167,8 +167,8 @@ ;; - all cells accessed are constant. ;; (ct-assert (null (md-slot-cell p 'speech))) - (ct-assert (md-slot-cell-flushed p 'speech)) - (ct-assert (c-optimized-away-p (md-slot-cell-flushed p 'speech))) + (ct-assert (assoc 'speech (cells-flushed p))) + (ct-assert (c-optimized-away-p (cdr (assoc 'speech (cells-flushed p))))) (ct-assert (not (c-optimized-away-p (md-slot-cell p 'thought)))) ;; pulse is variable, so cannot opti (ct-assert (eql 1 (length (cd-useds (md-slot-cell p 'thought))))) ;; but speech is opti, so only 1 used @@ -205,7 +205,7 @@ (length (names self))))) nil) (t (error) - (trc "error" error) + (describe error) (setf *stop* nil) t))) ) --- /project/cells/cvsroot/cells/cells-test/test.lisp 2007/11/30 16:51:19 1.10 +++ /project/cells/cvsroot/cells/cells-test/test.lisp 2007/11/30 22:29:06 1.11 @@ -71,7 +71,7 @@ (defun test-cells () (loop for test in (reverse *cell-tests*) - when (eq 'm-syn-bool test) + when t ; (eq 'cv-test-person-5 test) do (cell-test-init test) (funcall test)) (print (make-string 40 :initial-element #\*))

1 0

[cells-cvs] CVS cells/utils-kt
by ktilton 30 Nov '07

30 Nov '07

Update of /project/cells/cvsroot/cells/utils-kt In directory clnet:/tmp/cvs-serv21379/utils-kt Added Files: split-sequence.lisp Log Message: --- /project/cells/cvsroot/cells/utils-kt/split-sequence.lisp 2007/11/30 21:58:40 NONE +++ /project/cells/cvsroot/cells/utils-kt/split-sequence.lisp 2007/11/30 21:58:40 1.1 ;;;; SPLIT-SEQUENCE ;;; ;;; This code was based on Arthur Lemmens' in ;;; <URL:http://groups.google.com/groups?as_umsgid=39F36F1A.B8F19D20%40simplex.nl>; ;;; ;;; changes include: ;;; ;;; * altering the behaviour of the :from-end keyword argument to ;;; return the subsequences in original order, for consistency with ;;; CL:REMOVE, CL:SUBSTITUTE et al. (:from-end being non-NIL only ;;; affects the answer if :count is less than the number of ;;; subsequences, by analogy with the above-referenced functions). ;;; ;;; * changing the :maximum keyword argument to :count, by analogy ;;; with CL:REMOVE, CL:SUBSTITUTE, and so on. ;;; ;;; * naming the function SPLIT-SEQUENCE rather than PARTITION rather ;;; than SPLIT. ;;; ;;; * adding SPLIT-SEQUENCE-IF and SPLIT-SEQUENCE-IF-NOT. ;;; ;;; * The second return value is now an index rather than a copy of a ;;; portion of the sequence; this index is the `right' one to feed to ;;; CL:SUBSEQ for continued processing. ;;; There's a certain amount of code duplication here, which is kept ;;; to illustrate the relationship between the SPLIT-SEQUENCE ;;; functions and the CL:POSITION functions. ;;; Examples: ;;; ;;; * (split-sequence #\; "a;;b;c") ;;; -> ("a" "" "b" "c"), 6 ;;; ;;; * (split-sequence #\; "a;;b;c" :from-end t) ;;; -> ("a" "" "b" "c"), 0 ;;; ;;; * (split-sequence #\; "a;;b;c" :from-end t :count 1) ;;; -> ("c"), 4 ;;; ;;; * (split-sequence #\; "a;;b;c" :remove-empty-subseqs t) ;;; -> ("a" "b" "c"), 6 ;;; ;;; * (split-sequence-if (lambda (x) (member x '(#\a #\b))) "abracadabra") ;;; -> ("" "" "r" "c" "d" "" "r" ""), 11 ;;; ;;; * (split-sequence-if-not (lambda (x) (member x '(#\a #\b))) "abracadabra") ;;; -> ("ab" "a" "a" "ab" "a"), 11 ;;; ;;; * (split-sequence #\; ";oo;bar;ba;" :start 1 :end 9) ;;; -> ("oo" "bar" "b"), 9 ;; cl-utilities note: the license of this file is unclear, and I don't ;; even know whom to contact to clarify it. If anybody objects to my ;; assumption that it is public domain, please contact me so I can do ;; something about it. Previously I required the split-sequence ; package as a dependency, but that was so unwieldy that it was *the* ;; sore spot sticking out in the design of cl-utilities. -Peter Scott (in-package :utils-kt) (export! split-sequence) (defun split-sequence (delimiter seq &key (count nil) (remove-empty-subseqs nil) (from-end nil) (start 0) (end nil) (test nil test-supplied) (test-not nil test-not-supplied) (key nil key-supplied)) "Return a list of subsequences in seq delimited by delimiter. If :remove-empty-subseqs is NIL, empty subsequences will be included in the result; otherwise they will be discarded. All other keywords work analogously to those for CL:SUBSTITUTE. In particular, the behaviour of :from-end is possibly different from other versions of this function; :from-end values of NIL and T are equivalent unless :count is supplied. The second return value is an index suitable as an argument to CL:SUBSEQ into the sequence indicating where processing stopped." (let ((len (length seq)) (other-keys (nconc (when test-supplied (list :test test)) (when test-not-supplied (list :test-not test-not)) (when key-supplied (list :key key))))) (unless end (setq end len)) (if from-end (loop for right = end then left for left = (max (or (apply #'position delimiter seq :end right :from-end t other-keys) -1) (1- start)) unless (and (= right (1+ left)) remove-empty-subseqs) ; empty subseq we don't want if (and count (>= nr-elts count)) ;; We can't take any more. Return now. return (values (nreverse subseqs) right) else collect (subseq seq (1+ left) right) into subseqs and sum 1 into nr-elts until (< left start) finally (return (values (nreverse subseqs) (1+ left)))) (loop for left = start then (+ right 1) for right = (min (or (apply #'position delimiter seq :start left other-keys) len) end) unless (and (= right left) remove-empty-subseqs) ; empty subseq we don't want if (and count (>= nr-elts count)) ;; We can't take any more. Return now. return (values subseqs left) else collect (subseq seq left right) into subseqs and sum 1 into nr-elts until (>= right end) finally (return (values subseqs right)))))) (defun split-sequence-if (predicate seq &key (count nil) (remove-empty-subseqs nil) (from-end nil) (start 0) (end nil) (key nil key-supplied)) "Return a list of subsequences in seq delimited by items satisfying predicate. If :remove-empty-subseqs is NIL, empty subsequences will be included in the result; otherwise they will be discarded. All other keywords work analogously to those for CL:SUBSTITUTE-IF. In particular, the behaviour of :from-end is possibly different from other versions of this function; :from-end values of NIL and T are equivalent unless :count is supplied. The second return value is an index suitable as an argument to CL:SUBSEQ into the sequence indicating where processing stopped." (let ((len (length seq)) (other-keys (when key-supplied (list :key key)))) (unless end (setq end len)) (if from-end (loop for right = end then left for left = (max (or (apply #'position-if predicate seq :end right :from-end t other-keys) -1) (1- start)) unless (and (= right (1+ left)) remove-empty-subseqs) ; empty subseq we don't want if (and count (>= nr-elts count)) ;; We can't take any more. Return now. return (values (nreverse subseqs) right) else collect (subseq seq (1+ left) right) into subseqs and sum 1 into nr-elts until (< left start) finally (return (values (nreverse subseqs) (1+ left)))) (loop for left = start then (+ right 1) for right = (min (or (apply #'position-if predicate seq :start left other-keys) len) end) unless (and (= right left) remove-empty-subseqs) ; empty subseq we don't want if (and count (>= nr-elts count)) ;; We can't take any more. Return now. return (values subseqs left) else collect (subseq seq left right) into subseqs and sum 1 into nr-elts until (>= right end) finally (return (values subseqs right)))))) (defun split-sequence-if-not (predicate seq &key (count nil) (remove-empty-subseqs nil) (from-end nil) (start 0) (end nil) (key nil key-supplied)) "Return a list of subsequences in seq delimited by items satisfying (CL:COMPLEMENT predicate). If :remove-empty-subseqs is NIL, empty subsequences will be included in the result; otherwise they will be discarded. All other keywords work analogously to those for CL:SUBSTITUTE-IF-NOT. In particular, the behaviour of :from-end is possibly different from other versions of this function; :from-end values of NIL and T are equivalent unless :count is supplied. The second return value is an index suitable as an argument to CL:SUBSEQ into the sequence indicating where processing stopped." ; Emacs syntax highlighting is broken, and this helps: " (let ((len (length seq)) (other-keys (when key-supplied (list :key key)))) (unless end (setq end len)) (if from-end (loop for right = end then left for left = (max (or (apply #'position-if-not predicate seq :end right :from-end t other-keys) -1) (1- start)) unless (and (= right (1+ left)) remove-empty-subseqs) ; empty subseq we don't want if (and count (>= nr-elts count)) ;; We can't take any more. Return now. return (values (nreverse subseqs) right) else collect (subseq seq (1+ left) right) into subseqs and sum 1 into nr-elts until (< left start) finally (return (values (nreverse subseqs) (1+ left)))) (loop for left = start then (+ right 1) for right = (min (or (apply #'position-if-not predicate seq :start left other-keys) len) end) unless (and (= right left) remove-empty-subseqs) ; empty subseq we don't want if (and count (>= nr-elts count)) ;; We can't take any more. Return now. return (values subseqs left) else collect (subseq seq left right) into subseqs and sum 1 into nr-elts until (>= right end) finally (return (values subseqs right)))))) (pushnew :split-sequence *features*)

1 0

[cells-cvs] CVS cells/utils-kt
by ktilton 30 Nov '07

30 Nov '07

Update of /project/cells/cvsroot/cells/utils-kt In directory clnet:/tmp/cvs-serv2729/utils-kt Modified Files: datetime.lisp debug.lisp defpackage.lisp detritus.lisp flow-control.lisp strings.lisp utils-kt.lpr Added Files: core.lisp Log Message: --- /project/cells/cvsroot/cells/utils-kt/datetime.lisp 2006/07/06 22:10:03 1.3 +++ /project/cells/cvsroot/cells/utils-kt/datetime.lisp 2007/11/30 16:51:20 1.4 @@ -197,5 +197,8 @@ (defun hyphenated-time-string () (substitute #\- #\: (ymdhmsh))) + +#+test +(hyphenated-time-string) --- /project/cells/cvsroot/cells/utils-kt/debug.lisp 2007/01/29 06:44:04 1.14 +++ /project/cells/cvsroot/cells/utils-kt/debug.lisp 2007/11/30 16:51:20 1.15 @@ -27,6 +27,7 @@ (defvar *stop* nil) (defun utils-kt-reset () + (clock-off :ukt-reset) (setf *count* nil *stop* nil *dbg* nil) @@ -121,3 +122,21 @@ ,form-measured) ,@postlude)) +(export! clock clock-0 clock-off) + +(defvar *clock*) + +(defun clock-off (key) + (when (boundp '*clock*) + (print (list :clock-off key)) + (makunbound '*clock*))) + +(defun clock-0 (key &aux (now (get-internal-real-time))) + (setf *clock* (cons now now)) + (print (list :clock-initialized-by key))) + +(defun clock (&rest keys &aux (now (get-internal-real-time))) + (when (boundp '*clock*) + (print (list* :clock (- now (cdr *clock*)) :tot (- now (car *clock*)) :at keys)) + (setf (cdr *clock*) now))) + --- /project/cells/cvsroot/cells/utils-kt/defpackage.lisp 2006/09/05 18:40:48 1.6 +++ /project/cells/cvsroot/cells/utils-kt/defpackage.lisp 2007/11/30 16:51:20 1.7 @@ -17,6 +17,9 @@ (in-package :cl-user) +(eval-when (:compile-toplevel :load-toplevel :execute) + (setf *features* (delete :its-alive! *features*))) + (defpackage :utils-kt (:nicknames #:ukt) (:use #:common-lisp @@ -41,26 +44,3 @@ #+(and mcl (not openmcl-partial-mop)) #:class-slots )) -(in-package :utils-kt) - -(defmacro eval-now! (&body body) - `(eval-when (:compile-toplevel :load-toplevel :execute) - ,@body)) - -(defmacro export! (&rest symbols) - `(eval-when (:compile-toplevel :load-toplevel :execute) - (export ',symbols))) - -(defmacro define-constant (name value &optional docstring) - "Define a constant properly. If NAME is unbound, DEFCONSTANT -it to VALUE. If it is already bound, and it is EQUAL to VALUE, -reuse the SYMBOL-VALUE of NAME. Otherwise, DEFCONSTANT it again, -resulting in implementation-specific behavior." - `(defconstant ,name - (if (not (boundp ',name)) - ,value - (let ((value ,value)) - (if (equal value (symbol-value ',name)) - (symbol-value ',name) - value))) - ,@(when docstring (list docstring)))) --- /project/cells/cvsroot/cells/utils-kt/detritus.lisp 2007/01/29 06:44:04 1.13 +++ /project/cells/cvsroot/cells/utils-kt/detritus.lisp 2007/11/30 16:51:20 1.14 @@ -49,10 +49,7 @@ (defun xor (c1 c2) (if c1 (not c2) c2)) -(export! push-end collect collect-if) - -(defmacro push-end (item place ) - `(setf ,place (nconc ,place (list ,item)))) +(export! collect collect-if) (defun collect (x list &key (key 'identity) (test 'eql)) (loop for i in list @@ -60,10 +57,22 @@ collect i)) (defun collect-if (test list) - (loop for i in list - when (funcall test i) - collect i)) + (remove-if-not test list)) + +(defun test-setup () + #-its-alive! + (ide.base::find-new-prompt-command + (cg.base::find-window :listener-frame))) + +#+test +(test-setup) + +(defun test-prep () + (test-setup)) +(defun test-init () + (test-setup)) +(export! test-setup test-prep test-init) ;;; --- FIFO Queue ----------------------------- @@ -142,7 +151,8 @@ do (bwhen (fname (pathname-name file)) (format t "~&~v,8t~a ~,40t~d" (1+ depth) fname lines)) summing lines))) - (format t "~&~v,8t~a ~,50t~d" depth (pathname-directory path) directory-lines) + (unless (zerop directory-lines) + (format t "~&~v,8t~a ~,50t~d" depth (pathname-directory path) directory-lines)) directory-lines)) ((find (pathname-type path) '("cl" "lisp" "c" "h" "java") @@ -162,7 +172,14 @@ #+(or) (line-count (make-pathname :device "c" - :directory `(:absolute "0dev" "Algebra")) t) + :directory `(:absolute "0dev"))) + +#+(or) +(loop for d1 in '("cl-s3" "kpax" "puri-1.5.1" "s-base64" "s-http-client" "s-http-server" "s-sysdeps" "s-utils" "s-xml") + summing (line-count (make-pathname + :device "c" + :directory `(:absolute "1-devtools" ,d1)))) + (export! tree-includes tree-traverse tree-intersect) --- /project/cells/cvsroot/cells/utils-kt/flow-control.lisp 2007/01/29 06:44:04 1.10 +++ /project/cells/cvsroot/cells/utils-kt/flow-control.lisp 2007/11/30 16:51:20 1.11 @@ -59,6 +59,10 @@ (defun tree-flatten (tree) (list-flatten! (copy-tree tree))) +(export! push-end) +(defmacro push-end (item place ) + `(setf ,place (nconc ,place (list ,item)))) + (defun pair-off (list &optional (test 'eql)) (loop with pairs and copy = (copy-list list) while (cdr copy) @@ -184,8 +188,9 @@ (export! without-repeating) - (let ((generators (make-hash-table :test 'equalp))) + (defun reset-without-repeating () + (setf generators (make-hash-table :test 'equalp))) (defun without-repeating (key all &optional (decent-interval (floor (length all) 2))) (funcall (or (gethash key generators) (setf (gethash key generators) --- /project/cells/cvsroot/cells/utils-kt/strings.lisp 2006/09/05 18:40:50 1.6 +++ /project/cells/cvsroot/cells/utils-kt/strings.lisp 2007/11/30 16:51:20 1.7 @@ -90,6 +90,9 @@ (defun left$ (s n) (subseq s 0 (max (min n (length s)) 0))) +(export! cc$) +(defun cc$ (code) (string (code-char code))) + (defun mid$ (s offset length) (let* ((slen (length s)) (start (min slen (max offset 0))) --- /project/cells/cvsroot/cells/utils-kt/utils-kt.lpr 2007/01/29 06:44:04 1.22 +++ /project/cells/cvsroot/cells/utils-kt/utils-kt.lpr 2007/11/30 16:51:20 1.23 @@ -1,16 +1,10 @@ -;; -*- lisp-version: "8.0 [Windows] (Jan 22, 2007 8:01)"; cg: "1.81"; -*- +;; -*- lisp-version: "8.1 [Windows] (Sep 29, 2007 20:23)"; cg: "1.103.2.10"; -*- (in-package :cg-user) -(defpackage :COMMON-LISP - (:export #:list - #:make-instance - #:t - #:nil - #:quote)) - (define-project :name :utils-kt :modules (list (make-instance 'module :name "defpackage.lisp") + (make-instance 'module :name "core.lisp") (make-instance 'module :name "debug.lisp") (make-instance 'module :name "flow-control.lisp") (make-instance 'module :name "detritus.lisp") @@ -28,12 +22,13 @@ :runtime-modules nil :splash-file-module (make-instance 'build-module :name "") :icon-file-module (make-instance 'build-module :name "") - :include-flags '(:local-name-info) - :build-flags '(:allow-debug :purify) + :include-flags (list :local-name-info) + :build-flags (list :allow-debug :purify) :autoload-warning t :full-recompile-for-runtime-conditionalizations nil + :include-manifest-file-for-visual-styles t :default-command-line-arguments "+cx +t \"Initializing\"" - :additional-build-lisp-image-arguments '(:read-init-files nil) + :additional-build-lisp-image-arguments (list :read-init-files nil) :old-space-size 256000 :new-space-size 6144 :runtime-build-option :standard --- /project/cells/cvsroot/cells/utils-kt/core.lisp 2007/11/30 16:51:26 NONE +++ /project/cells/cvsroot/cells/utils-kt/core.lisp 2007/11/30 16:51:26 1.1 #| Utils-kt core Copyright (C) 1995, 2006 by Kenneth Tilton This library is free software; you can redistribute it and/or modify it under the terms of the Lisp Lesser GNU Public License (http://opensource.franz.com/preamble.html) known as the LLGPL. This library is distributed WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the Lisp Lesser GNU Public License for more details. |# (in-package :utils-kt) (defmacro eval-now! (&body body) `(eval-when (:compile-toplevel :load-toplevel :execute) ,@body)) (defmacro export! (&rest symbols) `(eval-when (:compile-toplevel :load-toplevel :execute) (export ',symbols))) (defmacro define-constant (name value &optional docstring) "Define a constant properly. If NAME is unbound, DEFCONSTANT it to VALUE. If it is already bound, and it is EQUAL to VALUE, reuse the SYMBOL-VALUE of NAME. Otherwise, DEFCONSTANT it again, resulting in implementation-specific behavior." `(defconstant ,name (if (not (boundp ',name)) ,value (let ((value ,value)) (if (equal value (symbol-value ',name)) (symbol-value ',name) value))) ,@(when docstring (list docstring)))) (export! exe-path exe-dll font-path) (defun exe-path () #+its-alive! (excl:current-directory) #-its-alive! (excl:path-pathname (ide.base::project-file ide.base:*current-project*))) (defun font-path () (merge-pathnames (make-pathname :directory #+its-alive! (list :relative "font") #-its-alive! (append (butlast (pathname-directory (exe-path))) (list "TY Extender" "font"))) (exe-path))) #+test (list (exe-path)(font-path)) (defmacro exe-dll (&optional filename) (assert filename) (concatenate 'string filename ".dll")) #+chya (defun exe-dll (&optional filename) (merge-pathnames (make-pathname :name filename :type "DLL" :directory (append (butlast (pathname-directory (exe-path))) (list "dll"))) (exe-path))) #+test (probe-file (exe-dll "openal32"))

1 0

[cells-cvs] CVS cells/gui-geometry
by ktilton 30 Nov '07

30 Nov '07

Update of /project/cells/cvsroot/cells/gui-geometry In directory clnet:/tmp/cvs-serv2729/gui-geometry Modified Files: geo-data-structures.lisp geo-family.lisp geometer.lisp gui-geometry.lpr Log Message: --- /project/cells/cvsroot/cells/gui-geometry/geo-data-structures.lisp 2006/12/12 15:58:42 1.9 +++ /project/cells/cvsroot/cells/gui-geometry/geo-data-structures.lisp 2007/11/30 16:51:19 1.10 @@ -17,7 +17,7 @@ (in-package :gui-geometry) (eval-now! - (export '(v2 mkv2))) + (export '(v2 mkv2 v2=))) ;----------------------------- (defstruct v2 --- /project/cells/cvsroot/cells/gui-geometry/geo-family.lisp 2006/11/13 05:28:08 1.11 +++ /project/cells/cvsroot/cells/gui-geometry/geo-family.lisp 2007/11/30 16:51:19 1.12 @@ -102,6 +102,47 @@ (^prior-sib-pr self (spacing .parent))))))))))) +(defun ^prior-sib-pb (self &optional (spacing 0)) ;; just keeping with -pt variant till both converted to defun + (bif (psib (find-prior self (kids .parent) + :test (lambda (sib) + (not (collapsed sib))))) + (eko (nil "^prior-sib-pb spc pb-psib -lt" (- (abs spacing)) (pb psib) (- (^lt))) + (+ (- (abs spacing)) ;; force spacing to minus(= down for OpenGL) + (pb psib))) + 0)) + +(defun centered-h? () + (c? (px-maintain-pl (round (- (inset-width .parent) (l-width self)) 2)))) + +(defun centered-v? () + (c? (py-maintain-pt (round (- (l-height .parent) (l-height self)) -2)))) + +;--------------- geo.row.flow ---------------------------- +(export! geo-row-flow) + +(defmodel geo-row-flow (geo-inline) + ((spacing-hz :cell nil :initarg :spacing-hz :initform 0 :reader spacing-hz) + (spacing-vt :cell nil :initarg :spacing-vt :initform 0 :reader spacing-vt) + (aligned :cell nil :initarg :aligned :initform nil :reader aligned)) + (:default-initargs + :lb (c? (geo-kid-wrap self 'pb)) + :kid-slots (lambda (self) + (declare (ignore self)) + + (list + (mk-kid-slot (py) + (c? (py-maintain-pt + (let ((ph (^prior-sib-pr self (spacing-hz .parent) (aligned .parent)))) + (if (> (+ ph (l-width self)(outset .parent)) (l-width .parent)) + (^prior-sib-pb self (spacing-vt .parent)) + (^prior-sib-pt self)))))) + (mk-kid-slot (px) + (c? (px-maintain-pl + (let ((ph (^prior-sib-pr self (spacing-hz .parent) (aligned .parent)))) + (if (> (+ ph (l-width self)(outset .parent)) (l-width .parent)) + 0 + ph))))))))) + #| archive (defmodel geo-row-fv (family-values geo-row)()) @@ -136,28 +177,8 @@ (pt psib)) 0)))))))) -;--------------- IGRowFlow ---------------------------- +|# + + -(defmodel geo-row-flow (geo-row) - ((spacing-hz :cell nil :initarg :spacing-hz :initform 0 :reader spacing-hz) - (spacing-vt :cell nil :initarg :spacing-vt :initform 0 :reader spacing-vt) - (aligned :cell nil :initarg :aligned :initform nil :reader aligned)) - (:default-initargs - :lb (c? (geo-kid-wrap self 'pb)) - :kid-slots (lambda (self) - (declare (ignore self)) - (list - (mk-kid-slot (py) - (c? (py-maintain-pt - (let ((ph (^prior-sib-pr self (spacing-hz .parent) (aligned .parent)))) - (if (> (+ ph (l-width self)) (l-width .parent)) - (^prior-sib-pb self (spacing-vt .parent)) - (^prior-sib-pt self)))))) - (mk-kid-slot (px) - (c? (px-maintain-pl - (let ((ph (^prior-sib-pr self (spacing-hz .parent) (aligned .parent)))) - (if (> (+ ph (l-width self)) (l-width .parent)) - 0 - ph))))))))) -|# --- /project/cells/cvsroot/cells/gui-geometry/geometer.lisp 2006/11/13 05:28:08 1.12 +++ /project/cells/cvsroot/cells/gui-geometry/geometer.lisp 2007/11/30 16:51:19 1.13 @@ -87,18 +87,7 @@ ;(trc "inner outer" inner outer) )) -(defmacro ^offset-within (inner outer) - (let ((offset-h (gensym)) (offset-v (gensym)) (from (gensym))) - `(let ((,offset-h 0) - (,offset-v 0)) - (do ((,from ,inner (fm-parent ,from))) - ((or (null ,from) - (eql ,from ,outer)) - ; - (mkv2 ,offset-h ,offset-v)) - - (incf ,offset-h (px ,from)) - (incf ,offset-v (py ,from)))))) + ;----------- OfKids ----------------------- ; @@ -127,6 +116,8 @@ (v2-subtract outer-v2 (mkv2 (px inner) (py inner)))))) +(export! h-xlate v-xlate) + (defun h-xlate (outer inner outer-h) (if (eql outer inner) outer-h @@ -212,18 +203,6 @@ ;--------------------------------- -(defmacro ^ll-width (width) - `(- (lr self) ,width)) - -(defmacro ^lr-width (width) - `(+ (ll self) ,width)) - -(defmacro ^lt-height (height) - `(- (lb self) ,height)) - -(defmacro ^lb-height (height) - `(+ (lt self) ,height)) - ;---------------------------------- (export! geo-kid-wrap) @@ -235,108 +214,6 @@ ((pr pt) 'fm-max-kid)) self bound) (outset self))) -(defmacro ll-maintain-pL (pl) - `(- ,pL (^px))) - -(defmacro lr-maintain-pr (pr) - `(- ,pr (^px))) - -(defmacro ^fill-right (upperType &optional (padding 0)) - `(call-^fillRight self (upper self ,upperType) ,padding)) - -;recalc local top based on pT and offset -(defmacro lt-maintain-pT (pT) - `(- ,pT (^py))) - -;recalc local bottom based on pB and offset -(defmacro lb-maintain-pB (pB) - `(- ,pB (^py))) - -;-------------- -;recalc offset based on p and local -(defmacro px-maintain-pL (pL) - (let ((lL (gensym))) - `(- ,pL (let ((,lL (^lL))) - (c-assert ,lL () "^px-maintain-pL sees nil lL for ~a" self) - ,lL)))) - -(defmacro px-maintain-pR (pR) - `(- ,pR (^lR))) - -(defmacro py-maintain-pT (pT) - `(- ,pT (^lT))) - -(defmacro py-maintain-pB (pB) - `(- ,pB (^lB))) - -(defmacro centered-h? () - `(c? (px-maintain-pl (round (- (l-width .parent) (l-width self)) 2)))) - -(defmacro ^centered-v? () - `(c? (py-maintain-pt (round (- (l-height .parent) (l-height self)) 2)))) - -(defmacro ^fill-down (upper-type &optional (padding 0)) - (let ((filled (gensym))) - `(let ((,filled (upper self ,upper-type))) - #+qt (trc "^fillDown sees filledLR less offH" - (lb ,filled) - ,padding - (v2-v (offset-within self ,filled))) - (- (lb ,filled) - ,padding - (v2-v (offset-within self ,filled)))))) - -(defmacro ^lbmax? (&optional (padding 0)) - `(c? (lb-maintain-pb (- (inset-lb .parent) - ,padding)))) - -(defmacro ^lrmax? (&optional (padding 0)) - `(c? (lr-maintain-pr (- (inset-lr .parent) - ,padding)))) - -(defun ^prior-sib-pb (self &optional (spacing 0)) - (bif (psib (find-prior self (kids .parent) - :test (lambda (sib) - (not (collapsed sib))))) - (eko (nil "^prior-sib-pb spc pb-psib -lt" (- (abs spacing)) (pb psib) (- (^lt))) - (+ (- (abs spacing)) ;; force spacing to minus(= down for OpenGL) - (pb psib))) - 0)) - -(defmacro ^prior-sib-pt (self &optional (spacing 0)) - (let ((kid (gensym)) - (psib (gensym))) - `(let* ((,kid ,self) - (,psib (find-prior ,kid (kids (fm-parent ,kid))))) - ;(trc "^priorSib-pb > kid, sib" ,kid ,pSib) - (if ,psib - (+ (- (abs ,spacing)) (pt ,psib)) - 0)))) - -; "...return the sib's pL [if ,alignment is :left] or pR, plus optional spacing" - -(defmacro ^prior-sib-pr (self &optional (spacing 0) alignment) - (let ((kid (gensym)) - (psib (gensym))) - `(let* ((,kid ,self) - (,psib (find-prior ,kid (kids (fm-parent ,kid)) :test (lambda (k) (not (collapsed k)))))) - (if ,psib - (case ,alignment - (:left (+ ,spacing (pl ,psib))) - (otherwise (+ ,spacing (pr ,psib)))) - 0)))) - -(defmacro ^px-stay-right-of (other &key (by '0)) - `(px-maintain-pl (+ (pr (fm-other ,other)) ,by))) - -; in use; adjust offset to maintain pL based on ,justify -(defmacro ^px-self-centered (justify) - `(px-maintain-pl - (ecase ,justify - (:left 0) - (:center (floor (- (inset-width .parent) (l-width self)) 2)) - (:right (- (inset-lr .parent) (l-width self)))))) - ; in use; same idea for pT (defun py-self-centered (self justify) (py-maintain-pt @@ -345,9 +222,3 @@ (:center (floor (- (inset-height .parent) (l-height self)) -2)) (:bottom (downs (- (inset-height .parent) (l-height self))))))) -(defmacro ^fill-parent-right (&optional (inset 0)) - `(lr-maintain-pr (- (inset-lr .parent) ,inset))) - -(defmacro ^fill-parent-down () - `(lb-maintain-pb (inset-lb .parent))) - --- /project/cells/cvsroot/cells/gui-geometry/gui-geometry.lpr 2007/01/29 06:44:03 1.8 +++ /project/cells/cvsroot/cells/gui-geometry/gui-geometry.lpr 2007/11/30 16:51:19 1.9 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.0 [Windows] (Jan 22, 2007 8:01)"; cg: "1.81"; -*- +;; -*- lisp-version: "8.0 [Windows] (Jan 29, 2007 18:02)"; cg: "1.81"; -*- (in-package :cg-user) @@ -6,6 +6,7 @@ (define-project :name :gui-geometry :modules (list (make-instance 'module :name "defpackage.lisp") + (make-instance 'module :name "geo-macros.lisp") (make-instance 'module :name "geo-data-structures.lisp") (make-instance 'module :name "coordinate-xform.lisp")

1 0

[cells-cvs] CVS cells
by ktilton 30 Nov '07

30 Nov '07

Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv2729 Modified Files: cell-types.lisp cells-manifesto.txt cells.lisp cells.lpr constructors.lisp defmodel.lisp defpackage.lisp family.lisp fm-utilities.lisp integrity.lisp link.lisp md-slot-value.lisp md-utilities.lisp model-object.lisp propagate.lisp synapse-types.lisp synapse.lisp test-synapse.lisp trc-eko.lisp Log Message: --- /project/cells/cvsroot/cells/cell-types.lisp 2007/01/29 06:43:48 1.25 +++ /project/cells/cvsroot/cells/cell-types.lisp 2007/11/30 16:51:18 1.26 @@ -166,7 +166,7 @@ ;__________________ (defmethod c-print-value ((c c-ruled) stream) - (format stream "~a" (cond ((c-validp c) "<vld>") + (format stream "~a" (cond ((c-validp c) (cons (c-value c) "<vld>")) ((c-unboundp c) "<unb>") ((not (c-currentp c)) "dirty") (t "<err>")))) --- /project/cells/cvsroot/cells/cells-manifesto.txt 2006/10/11 22:16:20 1.10 +++ /project/cells/cvsroot/cells/cells-manifesto.txt 2007/11/30 16:51:18 1.11 @@ -181,7 +181,7 @@ is guaranteed to be called at least once during intialization even if a cell slot is bound to a constant or if it is an input or ruled Cell that never changes value. -It is legal for observer code to assign to input Cells, but (a) special syntax is required to defer executuion +It is legal for observer code to assign to input Cells, but (a) special syntax is required to defer execution until the observed state change has fully propagated; and (b) doing so compromises the declarative quality of an application -- one can no longer look to one rule to see how a slot (in this case the input slot being assigned by the observer) gets its value. A reasonable usage might be one with @@ -205,8 +205,8 @@ by the change to X and will not be recomputed. - recomputations, when they read other datapoints, must see only values current with the new value of X. - Example: if A depends on B and X, and B depends on X, when A reads B it must return a value recomputed from - the new value of X. + Example: if A depends on B and X, and B depends on X, when X changes and A reads B and X to compute a + new value, B must return a value recomputed from the new value of X. - similarly, client observer callbacks must see only values current with the new value of X; and @@ -285,11 +285,19 @@ to Lisp-land. See the Cells-Gtk or Celtk projects. Also, a persistent CLOS implementation that must echo CLOS instance data into, say, SQL tables. -Prior Art +Prior Art (in increasing order of priorness (age)) --------- +Functional reactive programming: + This looks to be the most active, current, and vibrant subset of folks working on this sort of stuff. + Links: + FlapJax (FRP-powered web apps) http://www.flapjax-lang.org/ + http://lambda-the-ultimate.org/node/1771 + http://www.haskell.org/frp/ + FrTime (scheme FRP implementation, no great links) http://pre.plt-scheme.org/plt/collects/frtime/doc.txt + Adobe Adam, originally developed only to manage complex GUIs. [Adam] -COSI, a class-based Cells-alike used at STSCI to in software used to +COSI, a class-based Cells-alike used at STSCI in software used to schedule Hubble telescope viewing time. [COSI] Garnet's KR: http://www.cs.cmu.edu/~garnet/ @@ -304,13 +312,12 @@ http://www.cs.utk.edu/~bvz/quickplan.html Sutherland, I. Sketchpad: A Man Machine Graphical Communication System. PhD thesis, MIT, 1963. -Steele himself cites Sketchpad as inexlicably unappreciated prior +Steele himself cites Sketchpad as inexplicably unappreciated prior art to his Constraints system: See also: The spreadsheet paradigm: http://www.cs.utk.edu/~bvz/active-value-spreadsheet.html The dataflow paradigm: http://en.wikipedia.org/wiki/Dataflow - Reactive programming: http://www.haskell.org/yampa/AFPLectureNotes.pdf Frame-based programming Definitive-programming --- /project/cells/cvsroot/cells/cells.lisp 2007/01/29 06:43:52 1.20 +++ /project/cells/cvsroot/cells/cells.lisp 2007/11/30 16:51:18 1.21 @@ -19,8 +19,12 @@ (eval-when (compile load) (proclaim '(optimize (speed 2) (safety 1) (space 1) (debug 3)))) + + (in-package :cells) + + (defparameter *c-prop-depth* 0) (defparameter *causation* nil) @@ -32,6 +36,9 @@ (defparameter *client-queue-handler* nil) (defparameter *unfinished-business* nil) +#+test +(cells-reset) + (defun cells-reset (&optional client-queue-handler &key debug) (utils-kt-reset) (setf @@ -55,6 +62,11 @@ (defun c-stopped () *stop*) +(export! .stopped) + +(define-symbol-macro .stopped + (c-stopped)) + (defmacro c-assert (assertion &optional places fmt$ &rest fmt-args) (declare (ignorable assertion places fmt$ fmt-args)) #+(or)`(progn) --- /project/cells/cvsroot/cells/cells.lpr 2007/01/29 06:43:59 1.27 +++ /project/cells/cvsroot/cells/cells.lpr 2007/11/30 16:51:18 1.28 @@ -1,8 +1,8 @@ -;; -*- lisp-version: "8.0 [Windows] (Jan 22, 2007 8:01)"; cg: "1.81"; -*- +;; -*- lisp-version: "8.0 [Windows] (Sep 14, 2007 21:56)"; cg: "1.81"; -*- (in-package :cg-user) -(defpackage :CELLS) +(defpackage :cells) (define-project :name :cells :modules (list (make-instance 'module :name "defpackage.lisp") --- /project/cells/cvsroot/cells/constructors.lisp 2007/01/29 06:43:59 1.16 +++ /project/cells/cvsroot/cells/constructors.lisp 2007/11/30 16:51:18 1.17 @@ -26,7 +26,7 @@ (defmacro c-lambda (&body body) `(c-lambda-var (slot-c) ,@body)) -(export! .cache-bound-p) +(export! .cache-bound-p c?+n) (defmacro c-lambda-var ((c) &body body) `(lambda (,c &aux (self (c-model ,c)) @@ -49,6 +49,13 @@ :value-state :unevaluated :rule (c-lambda ,@body))) +(defmacro c?+n (&body body) + `(make-c-dependent + :inputp t + :code ',body + :value-state :unevaluated + :rule (c-lambda ,@body))) + (defmacro c?n (&body body) `(make-c-dependent :code '(without-c-dependency ,@body) --- /project/cells/cvsroot/cells/defmodel.lisp 2006/12/12 15:58:42 1.12 +++ /project/cells/cvsroot/cells/defmodel.lisp 2007/11/30 16:51:18 1.13 @@ -17,7 +17,6 @@ |# (in-package :cells) - (defmacro defmodel (class directsupers slotspecs &rest options) ;;(print `(defmodel sees directsupers ,directsupers using ,(or directsupers :model-object))) (assert (not (find class directsupers))() "~a cannot be its own superclass" class) @@ -197,3 +196,6 @@ (ddd (c-in nil) :cell :ephemeral) :superx 42 ;; default-initarg (:documentation "as if!"))) + + + --- /project/cells/cvsroot/cells/defpackage.lisp 2006/11/04 20:52:01 1.9 +++ /project/cells/cvsroot/cells/defpackage.lisp 2007/11/30 16:51:18 1.10 @@ -58,6 +58,6 @@ #:fm-kid-containing #:fm-find-if #:fm-ascendant-if #:c-abs #:fm-collect-if #:psib #:not-to-be #:ssibno #:c-debug #:c-break #:c-assert #:c-stop #:c-stopped #:c-assert #:.stop #:delta-diff - ) + #:wtrc #:wnotrc #:eko-if #:trc #:wtrc #:eko #:ekx #:trcp #:trcx) #+allegro (:shadowing-import-from #:excl #:fasl-write #:fasl-read #:gc) ) --- /project/cells/cvsroot/cells/family.lisp 2007/01/29 06:43:59 1.19 +++ /project/cells/cvsroot/cells/family.lisp 2007/11/30 16:51:18 1.20 @@ -28,7 +28,6 @@ (.value :initform nil :accessor value :initarg :value) (zdbg :initform nil :accessor dbg :initarg :dbg))) - (defmethod fm-parent (other) (declare (ignore other)) nil) --- /project/cells/cvsroot/cells/fm-utilities.lisp 2007/01/29 06:43:59 1.15 +++ /project/cells/cvsroot/cells/fm-utilities.lisp 2007/11/30 16:51:18 1.16 @@ -87,11 +87,11 @@ (or (funcall some-function parent) (fm-ascendant-some (fm-parent parent) some-function)))) -(defun fm-ascendant-if (self if-function) - (when (and self if-function) - (or (when (funcall if-function self) +(defun fm-ascendant-if (self test) + (when (and self test) + (or (when (funcall test self) self) - (fm-ascendant-if .parent if-function)))) + (fm-ascendant-if .parent test)))) (defun fm-descendant-if (self test) (when (and self test) @@ -105,11 +105,13 @@ (when (fm-includes node d2) node)))) -(defun fm-collect-if (tree test) +(defun fm-collect-if (tree test &optional skip-top dependently) (let (collection) (fm-traverse tree (lambda (node) - (when (funcall test node) - (push node collection)))) + (unless (and skip-top (eq node tree)) + (when (funcall test node) + (push node collection)))) + :with-dependency dependently) (nreverse collection))) (defun fm-value-dictionary (tree value-fn &optional include-top) @@ -159,6 +161,39 @@ (without-c-dependency (tv)))))) (values)) +(export! fm-traverse-bf) +(defun fm-traverse-bf (family applied-fn &optional (cq (make-fifo-queue))) + (when family + (flet ((process-node (fm) + (funcall applied-fn fm) + (when (kids fm) + (fifo-add cq (kids fm))))) + (process-node family) + (loop for x = (fifo-pop cq) + while x + do (mapcar #'process-node x))))) + +#+test-bf +(progn + (defmd bftree (family) + (depth 0 :cell nil) + (id (c? (klin self))) + :kids (c? (when (< (depth self) 4) + (loop repeat (1+ (depth self)) + collecting (make-kid 'bftree :depth (1+ (depth self))))))) + + (defun klin (self) + (when self + (if .parent + (cons (kid-no self) (klin .parent)) + (list 0)))) + + (defun test-bf () + (let ((self (make-instance 'bftree))) + (fm-traverse-bf self + (lambda (node) + (print (id node))))))) + (defun fm-ordered-p (n1 n2 &aux (top (fm-ascendant-common n1 n2))) (assert top) (fm-traverse top (lambda (n) @@ -213,7 +248,7 @@ ;; should be modified to go through 'gather', which should be the real fm-find-all ;; -(export! fm-do-up) +(export! fm-do-up fm-find-next fm-find-prior) (defun fm-do-up (self &optional (fn 'identity)) (when self @@ -554,7 +589,8 @@ (count-it :fm-find-one) (flet ((matcher (fm) (when diag - (trc "fm-find-one matcher sees name" (md-name fm) :ofthing fm :seeking md-name)) + (trc nil + "fm-find-one matcher sees name" (md-name fm) :ofthing (type-of fm) :seeking md-name global-search)) (when (and (eql (name-root md-name)(md-name fm)) (or (null (name-subscript md-name)) (eql (name-subscript md-name) (fm-pos fm))) --- /project/cells/cvsroot/cells/integrity.lisp 2007/01/29 06:44:00 1.17 +++ /project/cells/cvsroot/cells/integrity.lisp 2007/11/30 16:51:18 1.18 @@ -44,6 +44,9 @@ *within-integrity*) (defun call-with-integrity (opcode defer-info action) + (when (eq opcode :change) + (when (eq defer-info :focus) + (break "cwi focus change"))) (when *stop* (return-from call-with-integrity)) (if *within-integrity* @@ -76,7 +79,7 @@ (defun ufb-add (opcode continuation) (assert (find opcode *ufb-opcodes*)) - (when (and *no-tell* (eq opcode :tell-dependents)) + #+trythis (when (and *no-tell* (eq opcode :tell-dependents)) (break "truly queueing tell under no-tell")) (trc nil "ufb-add deferring" opcode (when (eql opcode :client)(car continuation))) (fifo-add (ufb-queue-ensure opcode) continuation)) @@ -109,27 +112,38 @@ ; (bwhen (uqp (fifo-peek (ufb-queue :tell-dependents))) (trcx finish-business uqp) - (DOlist (b (fifo-data (ufb-queue :tell-dependents))) + (dolist (b (fifo-data (ufb-queue :tell-dependents))) (trc "unhandled :tell-dependents" (car b) (c-callers (car b)))) (break "unexpected 1> ufb needs to tell dependnents after telling dependents")) (let ((*no-tell* t)) (just-do-it :awaken) ;--- md-awaken new instances --- - ) + ) ; - ; we do not go back to check for a need to :tell-dependents because (a) the original propagation + ; OLD THINKING, preserved for the record, but NO LONGER TRUE: + ; we do not go back to check for a need to :tell-dependents because (a) the original propagation ; and processing of the :tell-dependents queue is a full propagation; no rule can ask for a cell that ; then decides it needs to recompute and possibly propagate; and (b) the only rules forced awake during ; awakening need that precisely because no one asked for their values, so there can be no dependents ; to "tell". I think. :) So... + ; END OF OLD THINKING ; + ; We now allow :awaken to change things so more dependents need to be told. The problem is the implicit + ; dependence on the /life/ of a model whenever there is a dependence on any /cell/ of that model. + ; md-quiesce currently just flags such slots as uncurrent -- maybe /that/ should change and those should + ; recalculate at once -- and then an /observer/ can run and ask for a new value from such an uncurrent cell, + ; which now knows it must recalculate. And that recalculation of course can and likely will come up with a new value + ; and perforce need to tell its dependents. So... + ; + ; I /could/ explore something other than the "uncurrent" kludge, but NCTM 2007 is coming up and + ; to be honest the idea of not allowing nested tells was enforcing a /guess/ that that should not + ; arise, and there was not even any perceived integrity whole being closed, it was just a gratuitous + ; QA trick, and indeed for a long time many nested tells were avoidable. But the case of the quiesced + ; dependent reverses the arrow and puts the burden on the prosecution to prove nested tells are a problem. + (bwhen (uqp (fifo-peek (ufb-queue :tell-dependents))) - (trcx finish-business uqp) - (DOlist (b (fifo-data (ufb-queue :tell-dependents))) - (trc "unhandled :tell-dependents" (car b) (c-callers (car b)))) - (break "unexpected 2> ufb needs to tell dependnents after awakening")) - - (assert (null (fifo-peek (ufb-queue :tell-dependents)))) - + (trc "retelling dependenst, one new one being" uqp) + (go tell-dependents)) + ;--- process client queue ------------------------------ ; (when *stop* (return-from finish-business)) @@ -141,7 +155,7 @@ (just-do-it clientq)) (when (fifo-peek (ufb-queue :client)) #+shhh (ukt::fifo-browse (ufb-queue :client) (lambda (entry) - (trc "surprise client" entry))) + (trc "surprise client" entry))) (go handle-clients))) ;--- now we can reset ephemerals -------------------- ; --- /project/cells/cvsroot/cells/link.lisp 2007/01/29 06:44:01 1.23 +++ /project/cells/cvsroot/cells/link.lisp 2007/11/30 16:51:18 1.24 @@ -67,7 +67,8 @@ (zerop (sbit usage rpos))) (progn (count-it :unlink-unused) - (trc nil "c-unlink-unused" c :dropping-used (car useds)) + #+save (when (eq 'mathx::progress (c-slot-name c)) + (trc "c-unlink-unused" c :dropping-used (car useds)) ) (c-unlink-caller (car useds) c) (rplaca useds nil)) (progn --- /project/cells/cvsroot/cells/md-slot-value.lisp 2007/01/29 06:44:01 1.34 +++ /project/cells/cvsroot/cells/md-slot-value.lisp 2007/11/30 16:51:18 1.35 @@ -64,6 +64,8 @@ ;;; (mathx::show-time t) ;;; (ctk::app-time t)))) +(defvar *trc-ensure* nil) + (defun ensure-value-is-current (c debug-id ensurer) ; ; ensurer can be used cell propagating to callers, or an existing caller who wants to make sure @@ -78,7 +80,7 @@ (cond ((c-currentp c) - (trc nil "c-currentp" c)) ;; used to follow c-inputp, but I am toying with letting ephemerals (inputs) fall obsolete + (trc nil "EVIC yep: c-currentp" c)) ;; used to follow c-inputp, but I am toying with letting ephemerals (inputs) fall obsolete ;; and then get reset here (ie, ((c-input-p c) (ephemeral-reset c))). ie, do not assume inputs are never obsolete ;; ((and (c-inputp c) @@ -100,15 +102,23 @@ (or (check-reversed (cdr useds)) (let ((used (car useds))) (ensure-value-is-current used :nested c) - (trc nil "comparing pulses (ensurer, used, used-changed): " c debug-id used (c-pulse-last-changed used)) + #+slow (trc c "comparing pulses (ensurer, used, used-changed): " c debug-id used (c-pulse-last-changed used)) (when (> (c-pulse-last-changed used)(c-pulse c)) - (trc nil "used changed and newer !!!!!!" c debug-id used) + #+slow (trc c "used changed and newer !!!!!!" c :oldpulse (c-pulse used) debug-id used :lastchg (c-pulse-last-changed used)) + #+shhh (when (trcp c) + (describe used)) t)))))) (assert (typep c 'c-dependent)) (check-reversed (cd-useds c)))) - (trc nil "kicking off calc-set of" (c-slot-name c) :pulse *data-pulse-id*) + #+slow (trc c "kicking off calc-set of" (c-validp c) (c-slot-name c) :vstate (c-value-state c) + :stamped (c-pulse c) :current-pulse *data-pulse-id*) (calculate-and-set c)) + ((mdead (c-value c)) + (trc "ensure-value-is-current> trying recalc of ~a with current but dead value ~a" c (c-value c)) + (let ((new-v (calculate-and-set c))) + (trc "ensure-value-is-current> GOT new value ~a" new-v))) + (t (trc nil "ensuring current decided current, updating pulse" (c-slot-name c) debug-id) (c-pulse-update c :valid-uninfluenced))) @@ -118,7 +128,7 @@ (bwhen (v (c-value c)) (if (mdead v) (progn - (trc "ensure-value not returning dead model object value" v) + (brk "ensure-value still got and still not returning ~a dead value ~a" c v) nil) v))) @@ -127,7 +137,8 @@ (when (c-stopped) (princ #\.) (return-from calculate-and-set)) - + + #-its-alive! (bwhen (x (find c *call-stack*)) ;; circularity (unless nil ;; *stop* (let ((stack (copy-list *call-stack*))) @@ -142,7 +153,7 @@ (setf caller-reiterated (eq caller c))) (c-break ;; break is problem when testing cells on some CLs "cell ~a midst askers (see above)" c) - (break)) + (break "see listener for cell rule cycle diagnotics")) (multiple-value-bind (raw-value propagation-code) (calculate-and-link c) @@ -160,7 +171,7 @@ (let ((*call-stack* (cons c *call-stack*)) (*defer-changes* t)) (assert (typep c 'c-ruled)) - (trc nil "calculate-and-link" c) + #+slow (trc *c-debug* "calculate-and-link" c) (cd-usage-clear-all c) (multiple-value-prog1 (funcall (cr-rule c) c) @@ -248,7 +259,7 @@ ; --- head off unchanged; this got moved earlier on 2006-06-10 --- (when (and (not (eq propagation-code :propagate)) - (eql prior-state :valid) + (find prior-state '(:valid :uncurrent)) (c-no-news c absorbed-value prior-value)) (trc nil "(setf md-slot-value) > early no news" propagation-code prior-state prior-value absorbed-value) (count-it :nonews) @@ -303,16 +314,23 @@ (setf (c-state c) :optimized-away) - (let ((entry (rassoc c (cells (c-model c))))) ; move from cells to cells-flushed + (let ((entry (rassoc c (cells (c-model c))))) (unless entry (describe c)) (c-assert entry) (trc nil "c-optimize-away?! moving cell to flushed list" c) (setf (cells (c-model c)) (delete entry (cells (c-model c)))) - (push entry (cells-flushed (c-model c)))) + #-its-alive! (push entry (cells-flushed (c-model c))) + ) (dolist (caller (c-callers c)) - (break "got opti of called") + ; + ; example: on window shutdown with a tool-tip displayed, the tool-tip generator got + ; kicked off and asked about the value of a dead instance. That returns nil, and + ; there was no other dependency, so the Cell then decided to optimize itself away. + ; of course, before that time it had a normal value on which other things depended, + ; so we ended up here. where there used to be a break. + ; (setf (cd-useds caller) (delete c (cd-useds caller))) (c-optimize-away?! caller) ;; rare but it happens when rule says (or .cache ...) ))) --- /project/cells/cvsroot/cells/md-utilities.lisp 2007/01/29 06:44:01 1.12 +++ /project/cells/cvsroot/cells/md-utilities.lisp 2007/11/30 16:51:18 1.13 @@ -33,7 +33,7 @@ (defgeneric mdead (self) (:method ((self model-object)) - (eq :eternal-rest (md-state SELF))) + (eq :eternal-rest (md-state self))) (:method (self) (declare (ignore self)) @@ -47,19 +47,19 @@ (:method :around ((self model-object)) (declare (ignorable self)) (trc nil #+not (typep self '(or mathx::problem mathx::prb-solvers mathx::prb-solver)) - "not-to-be nailing" self) - (c-assert (not (eq (md-state self) :eternal-rest))) + "not.to-be nailing" self) + ;;showpanic (c-assert (not (eq (md-state self) :eternal-rest))) + (unless (eq (md-state self) :eternal-rest) + (call-next-method) + + (setf (fm-parent self) nil + (md-state self) :eternal-rest) + + (md-map-cells self nil + (lambda (c) + (c-assert (eq :quiesced (c-state c))))) ;; fails if user obstructs not.to-be with primary method (use :before etc) - (call-next-method) - - (setf (fm-parent self) nil - (md-state self) :eternal-rest) - - (md-map-cells self nil - (lambda (c) - (c-assert (eq :quiesced (c-state c))))) ;; fails if user obstructs not-to-be with primary method (use :before etc) - - (trc nil "not-to-be cleared 2 fm-parent, eternal-rest" self))) + (trc nil "not.to-be cleared 2 fm-parent, eternal-rest" self)))) (defun md-quiesce (self) (trc nil "md-quiesce nailing cells" self (type-of self)) @@ -75,13 +75,11 @@ (c-unlink-from-used c) (dolist (caller (c-callers c)) (setf (c-value-state caller) :uncurrent) - (trc nil "c-quiesce unlinking caller" c) + (trc nil "c-quiesce unlinking caller and making uncurrent" :q c :caller caller) (c-unlink-caller c caller)) (setf (c-state c) :quiesced) ;; 20061024 for debugging for now, might break some code tho ))) - - (defparameter *to-be-dbg* nil) (defmacro make-kid (class &rest initargs) --- /project/cells/cvsroot/cells/model-object.lisp 2007/01/29 06:44:01 1.15 +++ /project/cells/cvsroot/cells/model-object.lisp 2007/11/30 16:51:18 1.16 @@ -143,8 +143,11 @@ ;; next is an indirect and brittle way to determine that a slot has already been output, ;; but I think anything better creates a run-time hit. ;; - (unless (md-slot-cell-flushed self slot-name) ;; slot will have been propagated just after cell was flushed - (slot-value-observe slot-name self (bd-slot-value self slot-name) nil nil))) + ;; until 2007-10 (unless (cdr (assoc slot-name (cells-flushed self))) ;; make sure not flushed + ;; but first I worried about it being slow keeping the flushed list /and/ searching, then + ;; I wondered why a flushed cell should not be observed, constant cells are. So Just Observe It + (slot-value-observe slot-name self (bd-slot-value self slot-name) nil nil)) + ((find (c-lazy c) '(:until-asked :always t)) (trc nil "md-awaken deferring c-awaken since lazy" @@ -224,9 +227,6 @@ (setf (slot-value self slot-name) new-value) (setf (symbol-value slot-name) new-value))) -(defun md-slot-cell-flushed (self slot-name) - (cdr (assoc slot-name (cells-flushed self)))) - ;----------------- navigation: slot <> initarg <> esd <> cell ----------------- #+cmu --- /project/cells/cvsroot/cells/propagate.lisp 2007/01/29 06:44:01 1.27 +++ /project/cells/cvsroot/cells/propagate.lisp 2007/11/30 16:51:18 1.28 @@ -46,7 +46,8 @@ (defun c-pulse-update (c key) (declare (ignorable key)) - (trc nil "!!!!!!! c-pulse-update updating !!!!!!!!!!" *data-pulse-id* c key :prior-pulse (c-pulse c)) + (unless (find key '(:valid-uninfluenced)) + (trc nil "!!!!!!! c-pulse-update updating !!!!!!!!!!" *data-pulse-id* c key :prior-pulse (c-pulse c))) (assert (>= *data-pulse-id* (c-pulse c)) () "Current DP ~a not GE pulse ~a of cell ~a" *data-pulse-id* (c-pulse c) c) (setf (c-pulse c) *data-pulse-id*)) @@ -74,7 +75,7 @@ (princ #\.)(princ #\!) (return-from c-propagate)) (trc nil "c-propagate> !!!!!!! propping" c (c-value c) :caller-ct (length (c-callers c))) - (trc nil "c-propagate> !!!! new value" (c-value c) :prior-value prior-value :caller-ct (length (c-callers c)) c) + #+slow (trc c "c-propagate> !!!! new value" (c-value c) :prior-value prior-value :caller-ct (length (c-callers c)) c) (when *c-debug* (when (> *c-prop-depth* 250) (trc nil "c-propagate deep" *c-prop-depth* (c-model c) (c-slot-name c) #+nah c)) @@ -83,7 +84,7 @@ ; --- manifest new value as needed --- ; - ; 20061030 Trying not-to-be first because doomed instances may be interested in callers + ; 20061030 Trying not.to.be first because doomed instances may be interested in callers ; who will decide to propagate. If a family instance kids slot is changing, a doomed kid ; will be out of the kids but not yet quiesced. If the propagation to this rule asks the kid ; to look at its siblings (say a view instance being deleted from a stack who looks to the psib @@ -95,7 +96,7 @@ (md-slot-owning (type-of (c-model c)) (c-slot-name c))) (trc nil "c-propagate> contemplating lost") (flet ((listify (x) (if (listp x) x (list x)))) - (bIf (lost (set-difference (listify prior-value) (listify (c-value c)))) + (bif (lost (set-difference (listify prior-value) (listify (c-value c)))) (progn (trc nil "prop nailing owned!!!!!!!!!!!" c :lost lost :leaving (c-value c)) (mapcar 'not-to-be lost)) @@ -169,6 +170,8 @@ ; --- recalculate dependents ---------------------------------------------------- + + (defun c-propagate-to-callers (c) ; ; We must defer propagation to callers because of an edge case in which: @@ -186,26 +189,27 @@ (member (c-lazy caller) '(t :always :once-asked)))) (c-callers c)) (let ((causation (cons c *causation*))) ;; in case deferred - (TRC nil "c-propagate-to-callers > queueing notifying callers" (c-callers c)) + #+slow (TRC c "c-propagate-to-callers > queueing notifying callers" (c-callers c)) (with-integrity (:tell-dependents c) (assert (null *call-stack*)) (let ((*causation* causation)) (trc nil "c-propagate-to-callers > actually notifying callers of" c (c-callers c)) #+c-debug (dolist (caller (c-callers c)) (assert (find c (cd-useds caller)) () "test 1 failed ~a ~a" c caller)) - (dolist (caller (copy-list (c-callers c))) ;; following code may modify c-callers list... - (trc nil "PRE-prop-CHECK " c :caller caller (c-state caller) (c-lazy caller)) - (unless (or (eq (c-state caller) :quiesced) ;; ..so watch for quiesced - (member (c-lazy caller) '(t :always :once-asked))) - (assert (find c (cd-useds caller))() "Precheck Caller ~a of ~a does not have it as used" caller c) - )) + #+c-debug (dolist (caller (copy-list (c-callers c))) ;; following code may modify c-callers list... + (trc nil "PRE-prop-CHECK " c :caller caller (c-state caller) (c-lazy caller)) + (unless (or (eq (c-state caller) :quiesced) ;; ..so watch for quiesced + (member (c-lazy caller) '(t :always :once-asked))) + (assert (find c (cd-useds caller))() "Precheck Caller ~a of ~a does not have it as used" caller c) + )) (dolist (caller (progn #+not copy-list (c-callers c))) ;; following code may modify c-callers list... (trc nil "propagating to caller iterates" c :caller caller (c-state caller) (c-lazy caller)) (unless (or (eq (c-state caller) :quiesced) ;; ..so watch for quiesced (member (c-lazy caller) '(t :always :once-asked))) (assert (find c (cd-useds caller))() "Caller ~a of ~a does not have it as used" caller c) - (trc nil "propagating to caller is used" c :caller caller) - (ensure-value-is-current caller :prop-from c)))))))) + #+slow (trc c "propagating to caller is used" c :caller caller (c-currentp c)) + (let ((*trc-ensure* (trcp c))) + (ensure-value-is-current caller :prop-from c))))))))) --- /project/cells/cvsroot/cells/synapse-types.lisp 2006/05/20 06:32:19 1.5 +++ /project/cells/cvsroot/cells/synapse-types.lisp 2007/11/30 16:51:18 1.6 @@ -18,6 +18,18 @@ (in-package :cells) +(export! f-find) + +(defmacro f-find (synapse-id sought where) + `(call-f-find ,synapse-id ,sought ,where)) + +(defun call-f-find (synapse-id sought where) + (with-synapse synapse-id () + (bif (k (progn + (find sought where))) + (values k :propagate) + (values nil :no-propagate)))) + (defmacro f-sensitivity (synapse-id (sensitivity &optional subtypename) &body body) `(call-f-sensitivity ,synapse-id ,sensitivity ,subtypename (lambda () ,@body))) --- /project/cells/cvsroot/cells/synapse.lisp 2006/07/24 05:03:08 1.14 +++ /project/cells/cvsroot/cells/synapse.lisp 2007/11/30 16:51:18 1.15 @@ -19,7 +19,7 @@ (in-package :cells) (eval-when (:compile-toplevel :load-toplevel :execute) - (export '(mk-synapse f-delta f-sensitivity f-plusp f-zerop fdifferent))) + (export '(mk-synapse f-delta f-sensitivity f-plusp f-zerop fdifferent with-synapse))) (defmacro with-synapse (synapse-id (&rest closure-vars) &body body) (let ((syn-id (gensym))(syn-caller (gensym))) @@ -40,7 +40,6 @@ (multiple-value-bind (v p) (with-integrity () (ensure-value-is-current synapse :synapse (car *call-stack*))) - (trc nil "with-synapse: synapse, v, prop" synapse v p) (values v p)) (record-caller synapse))))) --- /project/cells/cvsroot/cells/test-synapse.lisp 2005/12/09 18:59:33 1.1 +++ /project/cells/cvsroot/cells/test-synapse.lisp 2007/11/30 16:51:18 1.2 @@ -35,6 +35,7 @@ (print `(output m-syn-b ,self ,new-value ,old-value))) + (def-cell-test m-syn (progn (cell-reset) (let* ((delta-ct 0) --- /project/cells/cvsroot/cells/trc-eko.lisp 2007/01/29 06:44:01 1.6 +++ /project/cells/cvsroot/cells/trc-eko.lisp 2007/11/30 16:51:18 1.7 @@ -22,8 +22,6 @@ (defparameter *trcdepth* 0) -(export! trc wtrc eko) - (defun trcdepth-reset () (setf *trcdepth* 0)) @@ -35,18 +33,31 @@ `(without-c-dependency (call-trc t ,tgt-form ,@os)) (let ((tgt (gensym))) + ;(break "slowww? ~a" tgt-form) `(without-c-dependency (bif (,tgt ,tgt-form) (if (trcp ,tgt) (progn - (assert (stringp ,(car os))) + (assert (stringp ,(car os)) () "trc with test expected string second, got ~a" ,(car os)) (call-trc t ,@os)) ;;,(car os) ,tgt ,@(cdr os))) (progn - ;; (break "trcfailed") + ;(trc "trcfailed") (count-it :trcfailed))) (count-it :tgtnileval))))))) -(export! trcx) +(export! brk brkx .bgo) + + +(define-symbol-macro .bgo (break "go")) + +(defun brk (&rest args) + #+its-alive! (print args) + #-its-alive! (progn + ;;(setf *ctk-dbg* t) + (apply 'break args))) + +(defmacro brkx (msg) + `(break "At ~a: OK?" ',msg)) (defmacro trcx (tgt-form &rest os) (if (eql tgt-form 'nil) @@ -60,6 +71,7 @@ (defparameter *last-trc* (get-internal-real-time)) (defun call-trc (stream s &rest os) + ;(break) (if #+cormanlisp nil #-cormanlisp (and (boundp '*trcdepth*) *trcdepth*) (format stream "~&~v,,,'.<~d~>> " (mod *trcdepth* 100) *trcdepth*) @@ -85,8 +97,6 @@ (defmethod trcp :around (other) (unless (call-next-method other)(break))) -(export! trcp) - (defmethod trcp (other) (eq other t)) @@ -99,8 +109,6 @@ (defun trcdepth-decf () (format t "decrementing trc depth ~d" *trcdepth*) (decf *trcdepth*)) - -(export! wtrc eko-if) (defmacro wtrc ((&optional (min 1) (max 50) &rest banner) &body body ) `(let ((*trcdepth* (if *trcdepth* @@ -121,11 +129,12 @@ ;------ eko -------------------------------------- - (defmacro eko ((&rest trcargs) &rest body) (let ((result (gensym))) `(let ((,result ,@body)) - (trc ,(car trcargs) :=> ,result ,@(cdr trcargs)) + ,(if (stringp (car trcargs)) + `(trc ,(car trcargs) :=> ,result ,@(cdr trcargs)) + `(trc ,(car trcargs) ,(cadr trcargs) :=> ,result ,@(cddr trcargs))) ,result))) (defmacro ekx (ekx-id &rest body) @@ -134,8 +143,6 @@ (trc ,(string-downcase (symbol-name ekx-id)) :=> ,result) ,result))) -(export! ekx) - (defmacro eko-if ((&rest trcargs) &rest body) (let ((result (gensym))) `(let ((,result ,@body)) @@ -148,4 +155,5 @@ `(let ((,result (,@body))) (when ,label (trc ,label ,result)) - ,result))) \ No newline at end of file + ,result))) +

1 0

[cells-cvs] CVS cells/cells-test
by ktilton 30 Nov '07

30 Nov '07

Update of /project/cells/cvsroot/cells/cells-test In directory clnet:/tmp/cvs-serv2729/cells-test Modified Files: cells-test.lpr deep-cells.lisp test-synapse.lisp test.lisp Log Message: --- /project/cells/cvsroot/cells/cells-test/cells-test.lpr 2006/06/10 22:16:35 1.6 +++ /project/cells/cvsroot/cells/cells-test/cells-test.lpr 2007/11/30 16:51:19 1.7 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.0 [Windows] (May 22, 2006 0:51)"; cg: "1.81"; -*- +;; -*- lisp-version: "8.1 [Windows] (Sep 29, 2007 20:23)"; cg: "1.103.2.10"; -*- (in-package :cg-user) @@ -25,64 +25,72 @@ :main-form nil :compilation-unit t :verbose nil - :runtime-modules '(:cg-dde-utils :cg.base :cg.bitmap-pane - :cg.bitmap-pane.clipboard :cg.bitmap-stream - :cg.button :cg.caret :cg.check-box :cg.choice-list - :cg.choose-printer :cg.clipboard - :cg.clipboard-stack :cg.clipboard.pixmap - :cg.color-dialog :cg.combo-box :cg.common-control - :cg.comtab :cg.cursor-pixmap :cg.curve - :cg.dialog-item :cg.directory-dialog - :cg.directory-dialog-os :cg.drag-and-drop - :cg.drag-and-drop-image :cg.drawable - :cg.drawable.clipboard :cg.dropping-outline - :cg.edit-in-place :cg.editable-text - :cg.file-dialog :cg.fill-texture - :cg.find-string-dialog :cg.font-dialog - :cg.gesture-emulation :cg.get-pixmap - :cg.get-position :cg.graphics-context - :cg.grid-widget :cg.grid-widget.drag-and-drop - :cg.group-box :cg.header-control :cg.hotspot - :cg.html-dialog :cg.html-widget :cg.icon - :cg.icon-pixmap :cg.ie :cg.item-list - :cg.keyboard-shortcuts :cg.lamp :cg.lettered-menu - :cg.lisp-edit-pane :cg.lisp-text :cg.lisp-widget - :cg.list-view :cg.mci :cg.menu :cg.menu.tooltip - :cg.message-dialog :cg.multi-line-editable-text - :cg.multi-line-lisp-text :cg.multi-picture-button - :cg.multi-picture-button.drag-and-drop - :cg.multi-picture-button.tooltip :cg.ocx - :cg.os-widget :cg.os-window :cg.outline - :cg.outline.drag-and-drop - :cg.outline.edit-in-place :cg.palette - :cg.paren-matching :cg.picture-widget - :cg.picture-widget.palette :cg.pixmap - :cg.pixmap-widget :cg.pixmap.file-io - :cg.pixmap.printing :cg.pixmap.rotate :cg.printing - :cg.progress-indicator :cg.project-window - :cg.property :cg.radio-button :cg.rich-edit - :cg.rich-edit-pane :cg.rich-edit-pane.clipboard - :cg.rich-edit-pane.printing :cg.sample-file-menu - :cg.scaling-stream :cg.scroll-bar - :cg.scroll-bar-mixin :cg.selected-object - :cg.shortcut-menu :cg.static-text :cg.status-bar - :cg.string-dialog :cg.tab-control - :cg.template-string :cg.text-edit-pane - :cg.text-edit-pane.file-io :cg.text-edit-pane.mark - :cg.text-or-combo :cg.text-widget :cg.timer - :cg.toggling-widget :cg.toolbar :cg.tooltip - :cg.trackbar :cg.tray :cg.up-down-control - :cg.utility-dialog :cg.web-browser - :cg.web-browser.dde :cg.wrap-string - :cg.yes-no-list :cg.yes-no-string :dde) + :runtime-modules (list :cg-dde-utils :cg.base :cg.bitmap-pane + :cg.bitmap-pane.clipboard :cg.bitmap-stream + :cg.button :cg.caret :cg.check-box + :cg.choice-list :cg.choose-printer + :cg.clipboard :cg.clipboard-stack + :cg.clipboard.pixmap :cg.color-dialog + :cg.combo-box :cg.common-control :cg.comtab + :cg.cursor-pixmap :cg.curve :cg.dialog-item + :cg.directory-dialog :cg.directory-dialog-os + :cg.drag-and-drop :cg.drag-and-drop-image + :cg.drawable :cg.drawable.clipboard + :cg.dropping-outline :cg.edit-in-place + :cg.editable-text :cg.file-dialog + :cg.fill-texture :cg.find-string-dialog + :cg.font-dialog :cg.gesture-emulation + :cg.get-pixmap :cg.get-position + :cg.graphics-context :cg.grid-widget + :cg.grid-widget.drag-and-drop :cg.group-box + :cg.header-control :cg.hotspot :cg.html-dialog + :cg.html-widget :cg.icon :cg.icon-pixmap + :cg.ie :cg.item-list :cg.keyboard-shortcuts + :cg.lamp :cg.lettered-menu :cg.lisp-edit-pane + :cg.lisp-text :cg.lisp-widget :cg.list-view + :cg.mci :cg.menu :cg.menu.tooltip + :cg.message-dialog + :cg.multi-line-editable-text + :cg.multi-line-lisp-text + :cg.multi-picture-button + :cg.multi-picture-button.drag-and-drop + :cg.multi-picture-button.tooltip :cg.ocx + :cg.os-widget :cg.os-window :cg.outline + :cg.outline.drag-and-drop + :cg.outline.edit-in-place :cg.palette + :cg.paren-matching :cg.picture-widget + :cg.picture-widget.palette :cg.pixmap + :cg.pixmap-widget :cg.pixmap.file-io + :cg.pixmap.printing :cg.pixmap.rotate + :cg.printing :cg.progress-indicator + :cg.project-window :cg.property + :cg.radio-button :cg.rich-edit + :cg.rich-edit-pane + :cg.rich-edit-pane.clipboard + :cg.rich-edit-pane.printing + :cg.sample-file-menu :cg.scaling-stream + :cg.scroll-bar :cg.scroll-bar-mixin + :cg.selected-object :cg.shortcut-menu + :cg.static-text :cg.status-bar + :cg.string-dialog :cg.tab-control + :cg.template-string :cg.text-edit-pane + :cg.text-edit-pane.file-io + :cg.text-edit-pane.mark :cg.text-or-combo + :cg.text-widget :cg.timer :cg.toggling-widget + :cg.toolbar :cg.tooltip :cg.trackbar :cg.tray + :cg.up-down-control :cg.utility-dialog + :cg.web-browser :cg.web-browser.dde + :cg.wrap-string :cg.yes-no-list + :cg.yes-no-string :dde) :splash-file-module (make-instance 'build-module :name "") :icon-file-module (make-instance 'build-module :name "") - :include-flags '(:top-level :debugger) - :build-flags '(:allow-runtime-debug :purify) + :include-flags (list :top-level :debugger) + :build-flags (list :allow-runtime-debug :purify) :autoload-warning t :full-recompile-for-runtime-conditionalizations nil + :include-manifest-file-for-visual-styles t :default-command-line-arguments "+M +t \"Console for Debugging\"" - :additional-build-lisp-image-arguments '(:read-init-files nil) + :additional-build-lisp-image-arguments (list :read-init-files nil) :old-space-size 256000 :new-space-size 6144 :runtime-build-option :standard --- /project/cells/cvsroot/cells/cells-test/deep-cells.lisp 2006/03/22 04:08:35 1.2 +++ /project/cells/cvsroot/cells/cells-test/deep-cells.lisp 2007/11/30 16:51:19 1.3 @@ -34,12 +34,12 @@ (setf *client-log* (append *client-log* (list new-value)))))) (defun deep-queue-handler (client-q) - (loop for (nil . task) in (prog1 - (sort (fifo-data client-q) '< :key 'car) - (fifo-clear client-q)) - do + (loop for (defer-info . task) in (prog1 + (sort (fifo-data client-q) '< :key 'car) + (fifo-clear client-q)) + do (trc nil "!!! --- deep-queue-handler dispatching" defer-info) - (funcall task))) + (funcall task :user-q defer-info))) (def-cell-test go-deep () (cells-reset 'deep-queue-handler) --- /project/cells/cvsroot/cells/cells-test/test-synapse.lisp 2006/06/23 01:04:56 1.2 +++ /project/cells/cvsroot/cells/cells-test/test-synapse.lisp 2007/11/30 16:51:19 1.3 @@ -33,6 +33,29 @@ (defobserver m-syn-b () (print `(output m-syn-b ,self ,new-value ,old-value))) +(def-cell-test m-syn-bool + (let* ((delta-ct 0) + (m (make-instance 'm-syn + :m-syn-a (c-in nil) + :m-syn-b (c? (incf delta-ct) + (trc "syn-b containing rule firing!!!!!!!!!!!!!!" delta-ct) + (bwhen (msg (with-synapse :xyz42 () + (trc "synapse fires!!! ~a" (^m-syn-a)) + (bIF (k (find (^m-syn-a) '(:one :two :three))) + (values k :propagate) + (values NIL :no-propagate)))) + msg))))) + (ct-assert (= 1 delta-ct)) + (ct-assert (null (m-syn-b m))) + (setf (m-syn-a m) :nine) + (ct-assert (= 1 delta-ct)) + (ct-assert (null (m-syn-b m))) + (setf (m-syn-a m) :one) + (ct-assert (= 2 delta-ct)) + (ct-assert (eq :one (m-syn-b m))) + (setf (m-syn-a m) :nine) + (ct-assert (= 2 delta-ct)) + (ct-assert (eq :one (m-syn-b m))))) (def-cell-test m-syn (let* ((delta-ct 0) --- /project/cells/cvsroot/cells/cells-test/test.lisp 2006/11/04 20:52:01 1.9 +++ /project/cells/cvsroot/cells/cells-test/test.lisp 2007/11/30 16:51:19 1.10 @@ -68,8 +68,10 @@ #+go (test-cells) + (defun test-cells () (loop for test in (reverse *cell-tests*) + when (eq 'm-syn-bool test) do (cell-test-init test) (funcall test)) (print (make-string 40 :initial-element #\*))

1 0

[cells-cvs] CVS Celtk
by fgoenninger 16 Nov '07

16 Nov '07

Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv7610 Modified Files: togl.lisp Log Message: Added: Some comments in the code - just to remember the why and how here and there ... Helped me to understand the code after having debugged it for a few hours ... Frank --- /project/cells/cvsroot/Celtk/togl.lisp 2007/01/29 06:48:42 1.25 +++ /project/cells/cvsroot/Celtk/togl.lisp 2007/11/16 10:09:31 1.26 @@ -50,6 +50,8 @@ (defcfun ("Togl_Interp" Togl-Interp) :pointer (togl-struct-ptr :pointer)) +;; The following functions are not CFFI-translated yet ... + ;; Togl_AllocColor ;; Togl_FreeColor @@ -80,8 +82,8 @@ ;; (defun tk-togl-init (interp) - ;(assert (not (zerop (tcl-init-stubs interp "8.1" 0)))) - ;(assert (not (zerop (tk-init-stubs interp "8.1" 0)))) + ;(assert (not (zerop (tcl-init-stubs interp "8.1" 0)))) ;; Only meaningful on Windows + ;(assert (not (zerop (tk-init-stubs interp "8.1" 0)))) ;; dito (togl-init interp) (togl-create-func (callback togl-create)) (togl-destroy-func (callback togl-destroy)) @@ -194,13 +196,17 @@ (def-togl-callback create () (trc "___________________ TOGL SET UP _________________________________________" togl-ptr ) -;;; ; -;;; ; just comment out these next two lines if not using Cello -;;; ; -;;; (setf cl-ftgl:*ftgl-ogl* togl-ptr) ;; help debug failure to use lazy cells/classes to defer FTGL till Ogl ready -;;; (kt-opengl:kt-opengl-reset) -;;; ; ^^^^^ above two needed only for cello ^^^^^^ -;;; ; + ;; + ;; Cello dependency here: relies on :CELLO being pushed to *features*! + ;; + ;;(eval-when (:compile-toplevel :execute) + ;; (if (member :cello cl-user::*features*) + ;; (progn + ;; (setf cl-ftgl:*ftgl-ogl* togl-ptr) ;; help debug failure to use lazy cells/classes + ;; ;; to defer FTGL till Ogl ready + ;; (kt-opengl:kt-opengl-reset)))) +;;; ^^^^^ above two needed only for cello ^^^^^^ +;;; (setf (togl-ptr self) togl-ptr) ;; this cannot be deferred (setf (togl-ptr-set self) togl-ptr) ;; this gets deferred, which is OK (setf (gethash (pointer-address togl-ptr) (tkwins *tkw*)) self))

1 0