- cells-cvs@common-lisp.net - mailman3.common-lisp.net

04 Jul '04

Update of /project/cells/cvsroot/cell-cultures/clyde/cloucell In directory common-lisp.net:/tmp/cvs-serv5472/clyde/cloucell Added Files: 01-cell-basics.lisp cloucell.asd cloucell.lpr ct-item-stack.lisp ct-slot-stack.lisp edt-window.lisp inspection.lisp inspector-toolbar.lisp inspector-window.lisp object-inspector-01.lisp object-inspector-02.lisp outline.lisp slot-inspector.lisp structure-view.lisp Log Message: Date: Sun Jul 4 11:59:46 2004 Author: ktilton

1 0

[cells-cvs] CVS update: cell-cultures/utils-kt/debug.lisp cell-cultures/utils-kt/defpackage.lisp
by Kenny Tilton 04 Jul '04

04 Jul '04

Update of /project/cells/cvsroot/cell-cultures/utils-kt In directory common-lisp.net:/tmp/cvs-serv5472/utils-kt Modified Files: debug.lisp defpackage.lisp Log Message: Date: Sun Jul 4 11:59:46 2004 Author: ktilton Index: cell-cultures/utils-kt/debug.lisp diff -u cell-cultures/utils-kt/debug.lisp:1.2 cell-cultures/utils-kt/debug.lisp:1.3 --- cell-cultures/utils-kt/debug.lisp:1.2 Tue Jun 29 01:58:49 2004 +++ cell-cultures/utils-kt/debug.lisp Sun Jul 4 11:59:45 2004 @@ -55,7 +55,7 @@ (assert (stringp ,(car os))) (call-trc t ,@os)) ;;,(car os) ,tgt ,@(cdr os))) (progn - (break :trcfailed) + ;;(break "trcfailed") (count-it :trcfailed))) (count-it :tgtnileval))))))) Index: cell-cultures/utils-kt/defpackage.lisp diff -u cell-cultures/utils-kt/defpackage.lisp:1.3 cell-cultures/utils-kt/defpackage.lisp:1.4 --- cell-cultures/utils-kt/defpackage.lisp:1.3 Wed Jun 30 14:02:12 2004 +++ cell-cultures/utils-kt/defpackage.lisp Sun Jul 4 11:59:46 2004 @@ -23,9 +23,13 @@ (in-package :cl-user) (defpackage :utils-kt - (:use #:common-lisp) + (:nicknames #:ukt) + (:use #:common-lisp + #-(or cormanlisp cmu sbcl) #:clos + #+sbcl #:sb-mop + #+mcl #:ccl) (:export - #:eko #:eko-if #:count-it #:trc #:maptimes #:bwhen #:bif #:xor + #:eko #:count-it #:count-of #:trc #:maptimes #:bwhen #:bif #:xor "WITH-DYNAMIC-FN" #:last1 #:packed-flat! #:with-metrics "TRUE" "SHORTC" #:intern$ #:defconstant-once "*COUNT*" "*STOP*" "*DBG*" "*TRCDEPTH*"

1 0

[cells-cvs] CVS update: cell-cultures/cl-opengl/cl-opengl.lisp cell-cultures/cl-opengl/gl-functions.lisp
by Kenny Tilton 04 Jul '04

04 Jul '04

Update of /project/cells/cvsroot/cell-cultures/cl-opengl In directory common-lisp.net:/tmp/cvs-serv5472/cl-opengl Modified Files: cl-opengl.lisp gl-functions.lisp Log Message: Date: Sun Jul 4 11:59:45 2004 Author: ktilton Index: cell-cultures/cl-opengl/cl-opengl.lisp diff -u cell-cultures/cl-opengl/cl-opengl.lisp:1.1 cell-cultures/cl-opengl/cl-opengl.lisp:1.2 --- cell-cultures/cl-opengl/cl-opengl.lisp:1.1 Sat Jun 26 11:38:40 2004 +++ cell-cultures/cl-opengl/cl-opengl.lisp Sun Jul 4 11:59:45 2004 @@ -27,7 +27,8 @@ (defpackage #:cl-opengl (:nicknames #:ogl) (:use #:common-lisp #:uffi #:ffx) - (:export #:glut-get-window + (:export #:*ogl-listing-p* + #:glut-get-window #:glut-set-window #:glut-post-redisplay #:with-matrix Index: cell-cultures/cl-opengl/gl-functions.lisp diff -u cell-cultures/cl-opengl/gl-functions.lisp:1.1 cell-cultures/cl-opengl/gl-functions.lisp:1.2 --- cell-cultures/cl-opengl/gl-functions.lisp:1.1 Sat Jun 26 11:38:41 2004 +++ cell-cultures/cl-opengl/gl-functions.lisp Sun Jul 4 11:59:45 2004 @@ -22,7 +22,7 @@ (in-package #:cl-opengl) - +(defparameter *ogl-listing-p* nil) (defun-ogl :void "open-gl" "glFlush" ())

1 0

[cells-cvs] CVS update: cell-cultures/cl-magick/wand-texture.lisp
by Kenny Tilton 04 Jul '04

04 Jul '04

Update of /project/cells/cvsroot/cell-cultures/cl-magick In directory common-lisp.net:/tmp/cvs-serv5472/cl-magick Modified Files: wand-texture.lisp Log Message: Date: Sun Jul 4 11:59:44 2004 Author: ktilton Index: cell-cultures/cl-magick/wand-texture.lisp diff -u cell-cultures/cl-magick/wand-texture.lisp:1.1 cell-cultures/cl-magick/wand-texture.lisp:1.2 --- cell-cultures/cl-magick/wand-texture.lisp:1.1 Sat Jun 26 11:38:39 2004 +++ cell-cultures/cl-magick/wand-texture.lisp Sun Jul 4 11:59:44 2004 @@ -66,7 +66,7 @@ (pixels (wand-get-image-pixels (mgk-wand self) 0 0 (car (image-size self)) (cdr (image-size self))))) - (assert (not clo::*listingp*)) + ;; (assert (not *ogl-listing-p*)) (gl-bind-texture gl_texture_2d tx) (progn ;; useless?? @@ -92,7 +92,7 @@ &aux (sz (image-size self))) #+not (format t "~&wand-render tex ~a ~a ~a" (texture-name self) self :size sz :bbox (list left top right bottom)) - (assert clo::*listingp*) + ;;(assert *ogl-listing-p*) (with-attrib (gl_texture_bit);; gl_enable_bit gl_hint_bit gl_line_bit gl_color_buffer_bit) (wand-texture-activate self) #+tilingworksbutslower

1 0

[cells-cvs] CVS update: cell-cultures/clyde/visual-apropos/visual-apropos.lisp
by Kenny Tilton 04 Jul '04

04 Jul '04

Update of /project/cells/cvsroot/cell-cultures/clyde/visual-apropos In directory common-lisp.net:/tmp/cvs-serv5472/clyde/visual-apropos Modified Files: visual-apropos.lisp Log Message: Date: Sun Jul 4 11:59:45 2004 Author: ktilton Index: cell-cultures/clyde/visual-apropos/visual-apropos.lisp diff -u cell-cultures/clyde/visual-apropos/visual-apropos.lisp:1.1 cell-cultures/clyde/visual-apropos/visual-apropos.lisp:1.2 --- cell-cultures/clyde/visual-apropos/visual-apropos.lisp:1.1 Sun Jun 27 16:52:25 2004 +++ cell-cultures/clyde/visual-apropos/visual-apropos.lisp Sun Jul 4 11:59:45 2004 @@ -21,12 +21,7 @@ #| do list -why some symbols show without classification? -close up list of symbols for gaps -add "String" with underscore for symbol entry -make symbol entry also a pop-up -get packages pop-up working and honored -make symbol list into proper listbox +at least show search in entry |# @@ -40,97 +35,224 @@ (defun vis-apropos () (make-be 'visual-apropos - :sub-symbol 'thread)) + :sub-symbol 'padding)) -(defmodel visual-apropos (frame) +(defmodel visual-apropos (frame-stack) ((symbols :initarg :symbols :initform nil :accessor symbols) (sub-symbol :initarg :sub-symbol :initform nil :accessor sub-symbol)) (:default-initargs - :layout (layout-stack) :symbols (c? (apropos-list (^sub-symbol))) + :pady 2 + :padx 4 + :layout (pack-layout? "-side left -fill both -expand 1 -anchor nw") :kids (c? (list (search-for-symbol) - (frame-row () - (frame-stack () - (exported-only) - (package-searching)) - (show-which-symbols)) + (frame-row + :padx 8 + :layout (pack-layout? "-side left -fill x") + :kids (c? (list + (frame-stack + :kids (c? (list + (checkbutton :md-name :exported-only + :text "Exported Only" + :underline 1 + :md-value (c-in nil) + :command (lambda (self) + (setf (^md-value) (not (^md-value))))) + (show-which-symbols)))) + (package-filtering)))) + (label :text (c? (format nil "Symbols containing ~a" + (sub-symbol .parent))) + :underline 4) (symbol-list))))) (defun search-for-symbol () - (frame-row () - (label :text "String:" - :underline 4) - (entry :md-name :search-string - :text (c? (symbol-name (md-value (upper self visual-apropos))))) - (button :text "Search" - :underline 0 - :command (lambda (self) - (setf (md-value (upper self visual-apropos)) - (md-value (fm^ :search-string))))))) - -(defun exported-only () - (checkbutton :md-name :exported-only - :text "Show Exported Symbols Only" - :md-value (c-in nil) - :command (lambda (self) - (setf (^md-value) (not (^md-value)))))) - -(defun package-searching () - (labelframe :text "Package(s) to Search" - :layout (layout-row) - :kids (c? (list - (checkbutton :md-name :all-pkgs - :text "All" - :md-value (c-in t) + (frame-row + :relief 'ridge + :padx 8 + :layout (pack-layout? "-side left -fill x -anchor nw") + :kids-layout (c? (format nil + "pack ~a -side left; pack ~a -side left -expand 1 -fill x; pack ~a -side right" + (path (kid1 self)) + (path (second (^kids))) + (path (third (^kids))))) + :kids (c? (list (label :text "String:" + :underline 4) + (entry :md-name :search-string + :text (c? (symbol-name (sub-symbol (upper self visual-apropos)))) + :width 64) + (button :text "Search" + :underline 0 :command (lambda (self) - (setf (^md-value) (not (^md-value))))) - (label :text "FNYI: Package pop-up menu"))))) + (setf (md-value (upper self visual-apropos)) + (md-value (fm^ :search-string))))))))) + +; --- symbol package filtering ------------------------------- + +(defun package-filtering () + (labelframe-row + :text " Package(s) to Search " + :layout (pack-layout? "-side left -fill x -expand 1") + :kids (c? (list + (checkbutton :md-name :all-pkgs + :text "All" + :underline 1 + :md-value (c-in t) + :command (lambda (self) + (setf (^md-value) (not (^md-value))))) + (scrolled-list + :md-name :in-package + :list-height 4 + :layout (pack-layout? "-side left -fill x -expand 1") + :enabled (c? (not (md-value (psib)))) + :list-items (c? (loop for p in (list-all-packages) + collecting (make-instance 'listbox-item + :md-value p + :item-text (down$ (package-name p)))))))))) + +; --- symbol binding filtering --------------------------------------- (defun show-which-symbols () (labelframe-selector :md-name :which-symbols - :text "Show" + :text " With bindings " :tk-variable 'which-symbols :layout (c? (format nil "pack ~a -side {left}~:{; grid ~a -column ~d -row ~d -sticky w~}" (path self) (mapcar (lambda (k) (list (path k)(floor (kid-no k) 2) (mod (kid-no k) 2))) (^kids)))) - :initial-selection (c? (fm-other :all)) - :selection (c-in nil) + :selection (c-in :any) :kids (c? (flet ((rb (n) (radiobutton :md-name n :text (string-capitalize (string n)) :tk-variable (tk-variable self) :value n - :layout nil :underline 0))) - (list (rb :all)(rb :functions)(rb :variables)(rb :classes)))))) + :layout nil + :underline 0))) + (list (rb :any)(rb :functions)(rb :variables)(rb :classes)))))) (defun symbol-list () - (canvas :md-name :symbol-list - :kids (c? (let ((root (upper self visual-apropos))) - (loop for symbol in (symbols root) - for n upfrom 0 - when (va-show-symbol-p self symbol) - collect - (make-instance 'symbol-indicator$ - :anchor "nw" - :md-value symbol - :coords (list 10 (* n 20)))))))) + (frame-stack :md-name :symbol-list + :layout (pack-layout? "-side top -expand 1 -fill both") + :width 64 + :background 'red + :kids (c? (list + (frame-row + :md-name :sym-sort + :md-value (c-in nil) + :relief 'groove + :layout (pack-layout? "-side top -fill x -anchor w") + :kids (c? (flet ((va-button (&rest args) + (apply 'make-instance 'va-sorter args))) + (list + (va-button :layout nil + :md-name :sym-sym :text "Symbol Name" :width 28) + (va-button :layout nil :padx 10 + :text "Package" + :sort-string-fn 'package-name) + (va-button :layout nil :text "Function") + (va-button :layout nil :text "Setf" + :sort-string-fn (lambda (fn) + (if fn "x" ""))) + (va-button :layout nil :text "Var" :padx 5) + (va-button :layout nil :text "Class") + (va-button :layout nil :text "Exp"))))) + (scrolled-list + :layout (pack-layout? "-side top -expand 1 -fill both") + :width 64 + :list-height nil + :background 'white + :md-value (c? (let ((root (upper self visual-apropos))) + (loop for s in (symbols root) + for n upfrom 0 + when (va-show-symbol-p self s) + collect + (list + (symbol-name s) + (symbol-package s) + (cond + ((special-operator-p s) "special") + ((macro-function s) "macro") + ((fboundp s) + (if (typep (fdefinition s) 'generic-function) + "gf" "func")) + (t "")) + (fboundp `(setf ,s)) + (when (boundp s) + (if (constantp s) "con" "var")) + (find-class s nil) + (exported-p s))))) + :list-items (c? (let ((sorter (let ((ss (fm^ :sym-sort))) + (or (md-value (fm^ :sym-sort)) + (kid1 ss))))) + (sort (loop for si in (^md-value) + collect (make-instance 'va-symbol-info + :md-value si)) + (sort-button-predicate sorter) + :key (sort-button-key sorter))))))))) + +(defmodel sort-button (button) + ((sort-button-predicate :initarg :sort-button-predicate :accessor sort-button-predicate + :initform #'string<) + (sort-button-key :initarg :sort-button-key :accessor sort-button-key + :initform #'identity))) + +(defmodel va-sorter (sort-button) + ((sort-string-fn :initform 'string :initarg :sort-string-fn :accessor sort-string-fn)) + (:default-initargs + :command (lambda (self) + (let* ((ss (fm^ :sym-sort))) + (if (eq self (or (md-value ss) (kid1 ss))) + (setf (sort-button-predicate self) + (if (eq (sort-button-predicate self) 'string<) + 'string> 'string<)) + (setf (md-value ss) self)))) + :sort-button-predicate (c-in 'string<) + :sort-button-key (c? (lambda (si) + (funcall (^sort-string-fn) + (elt (md-value si) (kid-no self))))))) + +(defmodel va-symbol-info (listbox-item) + () + (:default-initargs + :item-text (c? (destructuring-bind (sname pkg fn setf var class exp) + (^md-value) + (format nil "~(~a~) ~27,T~(~a~) ~36,T~a ~43,T~a ~46,T~a ~52,T~a ~57,T~a" + (if (< (length sname) 26) + sname + (conc$ (left$ sname 22) "...")) + (down$ (let ((nn (car (package-nicknames pkg)))) + (if (plusp (length nn)) + nn + (package-name pkg)))) + (or fn "") + (if setf "x" "") + (or var "") + (if class "x" "") + (if exp "x" "")))))) + +(defun exported-p (symbol) + (eq :external (symbol-status symbol))) (defun va-show-symbol-p (self symbol) (when (md-value (fm^ :exported-only)) - (unless (eq :external (symbol-status symbol)) + (unless (exported-p symbol) (return-from va-show-symbol-p nil))) - (let ((rb (selection (fm^ :which-symbols)))) - (when rb ;; not during initialization since echo of init-sel deferred (FIX) - (unless (ecase (md-name rb) - (:all t) + (let ((which (selection (fm^ :which-symbols)))) + (unless (ecase which + (:any t) (:functions (fboundp symbol)) (:classes (find-class symbol nil)) (:variables (boundp symbol))) - (return-from va-show-symbol-p nil)))) + (return-from va-show-symbol-p nil))) + (unless (or (md-value (fm^ :all-pkgs)) + (bIf (sel (selection (fm^ :in-package))) + (eq (symbol-package symbol) + (md-value (elt (list-items (fm^ :in-package)) sel))) + t)) + (return-from va-show-symbol-p nil)) + t) (defun symbol-status (sym)

1 0

[cells-cvs] CVS update: cell-cultures/cl-ftgl/cl-ftgl.lisp
by Kenny Tilton 04 Jul '04

04 Jul '04

Update of /project/cells/cvsroot/cell-cultures/cl-ftgl In directory common-lisp.net:/tmp/cvs-serv5472/cl-ftgl Modified Files: cl-ftgl.lisp Log Message: Date: Sun Jul 4 11:59:44 2004 Author: ktilton Index: cell-cultures/cl-ftgl/cl-ftgl.lisp diff -u cell-cultures/cl-ftgl/cl-ftgl.lisp:1.1 cell-cultures/cl-ftgl/cl-ftgl.lisp:1.2 --- cell-cultures/cl-ftgl/cl-ftgl.lisp:1.1 Sat Jun 26 11:38:39 2004 +++ cell-cultures/cl-ftgl/cl-ftgl.lisp Sun Jul 4 11:59:44 2004 @@ -20,7 +20,7 @@ ;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS ;;; IN THE SOFTWARE. -;;; $Header: /project/cells/cvsroot/cell-cultures/cl-ftgl/cl-ftgl.lisp,v 1.1 2004/06/26 18:38:39 ktilton Exp $ +;;; $Header: /project/cells/cvsroot/cell-cultures/cl-ftgl/cl-ftgl.lisp,v 1.2 2004/07/04 18:59:44 ktilton Exp $ (defpackage #:cl-ftgl (:nicknames #:ftgl) @@ -433,7 +433,7 @@ (let ((cf (ftgl-get-metrics-font font))) (assert cf) (unless (ftgl-ready font) - (when clo::*listingp* (cells::c-break "bad time #1 for sizing? ~a ~a" clo::*listingp* font)) + ;;(when *ogl-listing-p* (cells::c-break "bad time #1 for sizing? ~a ~a" *ogl-listing-p* font)) (setf (ftgl-ready font) t) (fgc-set-face-size cf (ftgl-size font) (ftgl-target-res font))) cf))

1 0

[cells-cvs] CVS update: cell-cultures/celtic/menu.lisp cell-cultures/celtic/scrolling.lisp cell-cultures/celtic/button.lisp cell-cultures/celtic/canvas.lisp cell-cultures/celtic/celtic.lisp cell-cultures/celtic/celtic.lpr cell-cultures/celtic/frame.lisp cell-cultures/celtic/textual.lisp cell-cultures/celtic/widget-item.lisp
by Kenny Tilton 04 Jul '04

04 Jul '04

Update of /project/cells/cvsroot/cell-cultures/celtic In directory common-lisp.net:/tmp/cvs-serv5472/celtic Modified Files: button.lisp canvas.lisp celtic.lisp celtic.lpr frame.lisp textual.lisp widget-item.lisp Added Files: menu.lisp scrolling.lisp Log Message: Date: Sun Jul 4 11:59:43 2004 Author: ktilton Index: cell-cultures/celtic/button.lisp diff -u cell-cultures/celtic/button.lisp:1.3 cell-cultures/celtic/button.lisp:1.4 --- cell-cultures/celtic/button.lisp:1.3 Sun Jun 27 21:25:14 2004 +++ cell-cultures/celtic/button.lisp Sun Jul 4 11:59:43 2004 @@ -26,13 +26,14 @@ ;-------------------------------------------------------------------------- (def-widget button () - (-activebackground -activeforeground -anchor -background - -bitmap -borderwidth -cursor -disabledforeground - -font -foreground -highlightbackground -highlightcolor - -highlightthickness -image -justify -padx -pady -relief -repeatdelay - -repeatinterval -takefocus -text -textvariable -underline -wraplength - (-command nil) - -compound -default -height -overrelief -state -width)) + () + (-activebackground -activeforeground -anchor -background + -bitmap -borderwidth -cursor -disabledforeground + -font -foreground -highlightbackground -highlightcolor + -highlightthickness -image -justify -padx -pady -relief -repeatdelay + -repeatinterval -takefocus -text -textvariable -underline -wraplength + (-command nil) + -compound -default -height -overrelief -state -width)) (defun test-button () (make-be 'button :text (format nil "Time is ~a" (get-internal-real-time)) @@ -45,6 +46,7 @@ ; http://tmml.sourceforge.net/doc/tk/checkbutton.html ; (def-widget checkbutton () + () (-activebackground -activeforeground -anchor -background -bitmap -borderwidth -cursor -disabledforeground -font -foreground -highlightbackground -highlightcolor @@ -62,6 +64,7 @@ (if new-value 1 0)))) (def-widget radiobutton () + () (-activebackground -activeforeground -anchor -background -bitmap -borderwidth -cursor -disabledforeground -font -foreground -highlightbackground -highlightcolor @@ -74,5 +77,6 @@ -tristatevalue (-tk-variable -variable) -width) (:default-initargs :command (lambda (self) - (setf (selection (upper self selector)) self)))) + (setf (selection (upper self selector)) + (value self))))) Index: cell-cultures/celtic/canvas.lisp diff -u cell-cultures/celtic/canvas.lisp:1.1 cell-cultures/celtic/canvas.lisp:1.2 --- cell-cultures/celtic/canvas.lisp:1.1 Sat Jun 26 11:38:38 2004 +++ cell-cultures/celtic/canvas.lisp Sun Jul 4 11:59:43 2004 @@ -22,6 +22,7 @@ (in-package :celtic) (def-widget canvas () + () (-background -borderwidth -cursor -highlightbackground -highlightcolor -highlightthickness -insertbackground -insertborderwidth -insertofftime -insertontime -insertwidth -relief Index: cell-cultures/celtic/celtic.lisp diff -u cell-cultures/celtic/celtic.lisp:1.2 cell-cultures/celtic/celtic.lisp:1.3 --- cell-cultures/celtic/celtic.lisp:1.2 Sun Jun 27 16:54:28 2004 +++ cell-cultures/celtic/celtic.lisp Sun Jul 4 11:59:43 2004 @@ -84,11 +84,11 @@ ;;; start wish and set *w* (defun tk-start () #+:sbcl (setf *w* (do-execute "/usr/bin/wish" '("-name" "Cells-LTk"))) - #-:sbcl (setf *w* (do-execute "wish" '("-name" "Cells-LTk")))) + #-:sbcl (setf *w* (do-execute "wish84" '("-name" "Visual Apropos")))) (defun tk-send (text) "send a string to wish" - (when *debug-tk* + (when nil ;; (search "pack " text) ;; *debug-tk* (format t "~&tk-send> ~A~%" text) (force-output)) (format *w* "~A~%" text) @@ -114,11 +114,14 @@ (defvar *callbacks* (make-hash-table :test #'equal)) -(defun register-callback(self callback-id fun - &aux (id (conc$ (path self) "." (down$ callback-id)))) - (format t "~&object ~a registering callback ~a: ~A" self id fun) +(defun register-callback (self callback-id fun + &aux (id (widget-callback-id self callback-id))) + ;;(format t "~&object ~a registering callback ~a: ~A" self :id id) (setf (gethash id *callbacks*) (cons fun self))) +(defun widget-callback-id (self callback-id) + (conc$ (path self) "." (down$ callback-id))) + (defun dispatch-callback(sym args) (let ((func-self (gethash sym *callbacks*))) ;(format t "sym:~S fun:~A~%" sym func-self) @@ -126,18 +129,19 @@ (when (not func-self) (format t "~&callback ~a, type ~a, pkg ~a, not found. known callbacks:" sym (type-of sym) (when (typep sym 'symbol) (symbol-package sym))) - #+shhh (maphash (lambda (key func-self) + (maphash (lambda (key func-self) (declare (ignore func-self)) (format t "~&known callback key ~a, type ~a, pkg ~a" key (type-of key)(when (typep key 'symbol) (symbol-package key)))) *callbacks*)) - (when func-self + (when (car func-self) (apply (car func-self) (cdr func-self) args)))) (defun after (self time func) "Usage: (after self <time> <func>)) ...after <time> msec call function <func>" (register-callback self "after" func) - (tk-send (format nil "after ~a {puts -nonewline {(\"~A\") };flush stdout}" time "after"))) + (tk-send (format nil "after ~a {puts -nonewline {(\"~A\") };flush stdout}" + time (widget-callback-id self "after")))) ;; tool functions used by the objects @@ -158,7 +162,7 @@ (defvar *tk-root*) (defun mainloop() - (trc "mainloop !!! *w* is" *w*) + (trc nil "mainloop !!! *w* is" *w*) (let ((*exit-mainloop* nil) (*read-eval* nil)) ;;safety against malicious clients (loop @@ -167,22 +171,17 @@ (trc "sitting on mainloop read") (tk-read)))) (when (null msg) (return)) - (when t ;; *debug-tk* + (when *debug-tk* (format t "~&msg:~A<=~%" msg) (force-output)) (if (consp msg) (progn - (trc "dispatching callback" msg) + (trc nil "dispatching callback" msg) (dispatch-callback (first msg) (rest msg))) (let ((emsg (read-line *w* nil nil))) (trc "error msg:" msg emsg))) - #+not - (if (eql #\( (elt msg 0)) - (let ((l (read-from-string msg))) - (trc "dispatching callback" l) - (dispatch-callback (first l) (rest l))) - (trc "mainloop gets tk error" msg)) + (when *exit-mainloop* (tk-send "exit") (return)))))) @@ -207,10 +206,8 @@ (tk-send (format nil "grid configure ~a -~a {~a}" (path widget) option value))) (defun tk-test (fn) - (trc "input is" *standard-input* *standard-output*) - (trc "debug-io is" *debug-io*) - - (let ((*debug-tk* nil)) + (let ((*debug-tk* nil) + (*callbacks* (make-hash-table :test #'equal))) (cell-reset) (tk-start) (let ((*tk-root* (funcall fn))) Index: cell-cultures/celtic/celtic.lpr diff -u cell-cultures/celtic/celtic.lpr:1.2 cell-cultures/celtic/celtic.lpr:1.3 --- cell-cultures/celtic/celtic.lpr:1.2 Sun Jun 27 16:54:28 2004 +++ cell-cultures/celtic/celtic.lpr Sun Jul 4 11:59:43 2004 @@ -11,9 +11,11 @@ (make-instance 'module :name "frame.lisp") (make-instance 'module :name "canvas.lisp") (make-instance 'module :name "textual.lisp") - (make-instance 'module :name "button.lisp")) + (make-instance 'module :name "button.lisp") + (make-instance 'module :name "menu.lisp") + (make-instance 'module :name "scrolling.lisp")) :projects (list (make-instance 'project-module :name - "c:\\dvl\\cells\\cells")) + "..\\cells\\cells")) :libraries nil :distributed-files nil :project-package-name :celtic Index: cell-cultures/celtic/frame.lisp diff -u cell-cultures/celtic/frame.lisp:1.3 cell-cultures/celtic/frame.lisp:1.4 --- cell-cultures/celtic/frame.lisp:1.3 Sun Jun 27 21:25:14 2004 +++ cell-cultures/celtic/frame.lisp Sun Jul 4 11:59:43 2004 @@ -21,95 +21,49 @@ (in-package :celtic) -(def-widget frame () - (-borderwidth -cursor -highlightbackground -highlightcolor - -highlightthickness -padx -pady -relief - -takefocus -background (tk-class -class) - -colormap -container -height -visual -width)) +;--- group geometry ----------------------------------------- -(defun test-frame () - (make-be 'frame - :kids (loop repeat 2 - collecting (make-instance 'button - :text (format nil "Time is ~a" (floor (get-internal-real-time) 1000)) - :borderwidth 4 - :underline 2 - :cursor "hand2" - :font "Courier")))) - -;------------------------------------------------------- +(defmodel inline-mixin () + ((kids-layout :initarg :kids-layout :accessor kids-layout :initform nil) + (padx :initarg :padx :accessor padx :initform 0) + (pady :initarg :pady :accessor pady :initform 0) + (layout-side :initarg :layout-side :accessor layout-side :initform 'left) + (layout-anchor :initarg :layout-anchor :accessor layout-anchor :initform 'nw)) + (:default-initargs + :kid-slots (lambda (self) + (declare (ignore self)) + (list + (mk-kid-slot (layout :if-missing t) + nil))) ;; suppress default + :kids-layout (c? (format nil "pack~{ ~a~} -side ~a -anchor ~a -padx ~a -pady ~a" + (mapcar 'path (^kids)) + (down$ (^layout-side)) + (down$ (^layout-anchor)) + (^padx)(^pady))))) -(def-widget labelframe () - (-borderwidth -cursor -highlightbackground -highlightcolor - -highlightthickness -padx -pady -relief - -takefocus -background (tk-class -class) -colormap -container -height -visual -width - -text -labelanchor -labelwidget)) +(def-c-output kids-layout () + (when new-value + (tk-send new-value))) -(defmodel stack (frame) +(defmodel row-mixin (inline-mixin) () (:default-initargs - :kid-slots (lambda (self) - (declare (ignore self)) - (list - (mk-kid-slot (layout :if-missing t) - (c? (format nil "pack~{ ~a~} -side {top} -anchor nw" - (path self)))))))) -(defun stack (&rest init-args) - (apply 'make-instance 'stack init-args)) - - -(defun test-labelframe () - (make-be 'labelframe - :text "Considering" - :padx 16 - :pady 16 - :kids (loop repeat 2 - collecting (make-instance 'button - :text (format nil "Time is ~a" (floor (get-internal-real-time) 1000)) - :borderwidth 4 - :padx 8 - :underline 2 - :cursor "hand2" - :font "Courier")))) - -; ------------------------------------------------------------------ + :layout-side 'left)) -(defmodel labelframe-selector (selector labelframe)()) -(defun labelframe-selector (&rest init-args) - (apply 'make-instance 'labelframe-selector init-args)) - -;------------------------------------------------------- +(defmodel stack-mixin (inline-mixin) + () + (:default-initargs + :layout-side 'top)) -(defun layout-row () - (c? (format nil "pack ~a -side {left}; pack~{ ~a~} -side {left}" - (path self) (mapcar 'path (^kids))))) - -(defun layout-stack () - (c? (format nil "pack ~a -side {left}; pack~{ ~a~} -side {top} -anchor nw" - (path self) (mapcar 'path (^kids))))) - -(defmacro frame-row ((&rest options) &rest kids) - `(frame ,@(append options - `(:layout (layout-row) - :kids (c? (list ,@kids)))))) - -(defmacro frame-stack ((&rest options) &rest kids) - `(frame ,@(append options - `(:layout (layout-stack) - :kids (c? (list ,@kids)))))) ;------------------------------------------------------ (defmodel selector () - ((selection :accessor selection :initarg :selection) - (initial-selection :initform nil :reader initial-selection - :initarg :initial-selection) - (tk-variable :cell nil :accessor tk-variable :initarg :tk-variable)) - (:default-initargs - :selection (c-in nil))) - -(def-c-output initial-selection () - (setf (selection self) new-value)) + ((selection :initform nil :accessor selection :initarg :selection) + (tk-variable :accessor tk-variable :initarg :tk-variable)) + (:default-initargs + :selection (c-in nil) + :tk-variable (c? (md-name self)))) (def-c-output selection () (when new-value @@ -117,14 +71,45 @@ (down$ (tk-variable self)) (down$ (md-name new-value)))))) -;--------------------------------------------------------- +;--- f r a m e -------------------------------------------------- -(defmodel radiogroup (selector) - ((tk-variable :accessor tk-variable :initarg :tk-variable)) - (:default-initargs - :tk-variable (c? (md-name self)))) +(def-widget frame () + () + (-borderwidth -cursor -highlightbackground -highlightcolor + -highlightthickness -padx -pady -relief + -takefocus -background (tk-class -class) + -colormap -container -height -visual -width)) + +(defmodel frame-selector (selector frame)()) +(defun frame-selector (&rest init-args) + (apply 'make-instance 'frame-selector init-args)) + +(defmodel frame-stack (stack-mixin frame-selector)()) +(defun frame-stack (&rest init-args) + (apply 'make-instance 'frame-stack init-args)) + +(defmodel frame-row (row-mixin frame-selector)()) +(defun frame-row (&rest init-args) + (apply 'make-instance 'frame-row init-args)) -(defmodel labelframe-radiogroup (radiogroup labelframe)()) -(defun labelframe-radiogroup (&rest init-args) - (apply 'make-instance 'labelframe-radiogroup init-args)) +;--- l a b e l f r a m e ---------------------------------------------- + +(def-widget labelframe () + () + (-borderwidth -cursor -highlightbackground -highlightcolor + -highlightthickness -padx -pady -relief + -takefocus -background (tk-class -class) -colormap -container -height -visual -width + -text -labelanchor -labelwidget)) + +(defmodel labelframe-selector (selector labelframe)()) +(defun labelframe-selector (&rest init-args) + (apply 'make-instance 'labelframe-selector init-args)) + +(defmodel labelframe-stack (stack-mixin labelframe-selector)()) +(defun labelframe-stack (&rest init-args) + (apply 'make-instance 'labelframe-stack init-args)) + +(defmodel labelframe-row (row-mixin labelframe-selector)()) +(defun labelframe-row (&rest init-args) + (apply 'make-instance 'labelframe-row init-args)) Index: cell-cultures/celtic/textual.lisp diff -u cell-cultures/celtic/textual.lisp:1.1 cell-cultures/celtic/textual.lisp:1.2 --- cell-cultures/celtic/textual.lisp:1.1 Sat Jun 26 11:38:38 2004 +++ cell-cultures/celtic/textual.lisp Sun Jul 4 11:59:43 2004 @@ -22,13 +22,14 @@ (in-package :celtic) (def-widget label () - (-activebackground -activeforeground -anchor -background - -bitmap -borderwidth -cursor -disabledforeground - -font -foreground -highlightbackground -highlightcolor - -highlightthickness -image -justify -padx - -pady -relief -takefocus -text - -textvariable -underline -wraplength - -compound -height -state -width)) + () + (-activebackground -activeforeground -anchor -background + -bitmap -borderwidth -cursor -disabledforeground + -font -foreground -highlightbackground -highlightcolor + -highlightthickness -image -justify -padx + -pady -relief -takefocus -text + -textvariable -underline -wraplength + -compound -height -state -width)) (defun test-label () (make-be 'label :text (format nil "Time is ~a" (get-internal-real-time)) @@ -39,6 +40,7 @@ ;-------------------------------------------------------------------------- (def-widget message () + () (-anchor -background -borderwidth -cursor -font -foreground -highlightbackground -highlightcolor -highlightthickness -padx -pady -relief @@ -58,6 +60,7 @@ ;---------------------------------------------------------------------------- (def-widget entry () + ((text :initarg :text :accessor text :initform nil)) (-background -borderwidth -cursor -exportselection -font -foreground -highlightbackground -highlightcolor -highlightthickness -insertbackground -insertborderwidth -insertofftime @@ -66,4 +69,13 @@ -textvariable -xscrollcommand -disabledbackground -disabledforeground -invalidcommand -readonlybackground -show -state - -validate -validatecommand -width)) + -validate -validatecommand -width) + (:default-initargs + :textvariable (c? (md-name self)))) + +(def-c-output text ((self entry)) + (when new-value + (tk-send (eko ("entry sets text var" self new-value) + (format nil "set ~a ~s" + (down$ (textvariable self)) + new-value))))) Index: cell-cultures/celtic/widget-item.lisp diff -u cell-cultures/celtic/widget-item.lisp:1.2 cell-cultures/celtic/widget-item.lisp:1.3 --- cell-cultures/celtic/widget-item.lisp:1.2 Sun Jun 27 21:25:14 2004 +++ cell-cultures/celtic/widget-item.lisp Sun Jul 4 11:59:43 2004 @@ -26,7 +26,7 @@ (defmethod md-awaken :before ((self tk-object)) (make-tk-instance self)) -;;; --- +;;; --- widget ----------------------------------------- (defmodel widget (family tk-object) ((name :initarg :name :accessor name @@ -35,29 +35,50 @@ :initform (c? (format nil "~a.~a" (if (fm-parent self) (path .parent) "") (name self)))) - (layout :reader layout :initarg :layout :initform nil) - (configurations :reader configurations :initarg :configurations :initform nil)) + (layout :reader layout :initarg :layout + :initform (c? (format nil "pack ~a" (path self)))) + (enabled :reader enabled :initarg :enabled :initform t) + (command-is-callback :reader command-is-callback :initarg :command-is-callback + :initform t) + (bindings :reader bindings :initarg :bindings :initform nil) + (selector :reader selector :initarg :selector + :initform (c? (upper self selector)))) (:default-initargs :md-name (create-name))) +(defmethod not-to-be :after ((self widget)) + (trc "whacking true widget" self) + (tk-send (format nil "pack forget ~a" (^path)))) + (def-c-output command ((self widget)) - (let ((id (conc$ (path self) ".command"))) + (when (^command-is-callback) (register-callback self "command" new-value) (configure self "command" - (format nil "puts -nonewline {(~s)};flush stdout" id)))) + (format nil "puts -nonewline {(~s)};flush stdout" + (widget-callback-id self "command"))))) + +(def-c-output bindings () ;;; (w widget) event fun) + (loop for binding in new-value + for name = (create-name) + do (destructuring-bind (event . fn) binding + (declare (ignorable event)) + (register-callback self name fn) + (tk-send (format nil "bind ~a ~a {puts -nonewline {(\"~A\")};flush stdout}" + (^path) event (widget-callback-id self name)))))) (defmethod configure ((self widget) option value) (tk-send (format nil "~A configure -~A {~A}" (path self) option value))) -;;; --- layout -------------------- - (def-c-output layout ((self widget)) (when new-value (tk-send new-value))) -(defmacro def-widget (class (&rest super-classes)(&rest tk-options) &rest defclass-options) - (let ((std-factory t)) - (flet ((de- (sym) (intern (remove #\- (symbol-name sym) :end 1)))) +;;; --- widget -------------------- + +(defmacro def-widget (class (&key (std-factory t)) + (&rest std-slots) + (&rest tk-options) &rest defclass-options) + (flet ((de- (sym) (intern (remove #\- (symbol-name sym) :end 1)))) (multiple-value-bind (slots outputs) (loop for tk-option-def in tk-options for slot-name = (de- (if (atom tk-option-def) @@ -71,12 +92,13 @@ (when new-value (configure self ,(down$ (de- (if (atom tk-option-def) tk-option-def (cadr tk-option-def)))) - (down$ new-value)))) + (if (stringp new-value) + new-value (down$ new-value))))) into outputs finally (return (values slot-defs outputs))) `(progn - (defmodel ,class (,@(append super-classes '(widget))) - (,@slots) + (defmodel ,class (widget) + (,@(append std-slots slots)) ,@defclass-options) (defun ,class (&rest inits) (apply 'make-instance ',class inits)) @@ -84,7 +106,10 @@ `(defmethod make-tk-instance ((self ,class)) (tk-send (format nil ,(concatenate 'string (down$ class) " ~A") (path self))))) - ,@outputs))))) + ,@outputs)))) + +(defmacro pack-layout? (fmt$ &rest args) + `(c? (format nil "pack ~a ~?" (^path) ,fmt$ (list ,@args)))) ;;; --- items ----------------------------------------------------------------------- @@ -102,7 +127,7 @@ (defmethod make-tk-instance :after ((self item)) (setf (id-no self) (let ((msg (tk-read))) - ;;(trc "item msg" msg) + (trc "created item" self :id msg) (read-from-string msg)))) (defmethod configure ((self item) option value)

1 0

[cells-cvs] CVS update: cell-cultures/cells/cells-test/cells-test.asd cell-cultures/cells/cells-test/cells-test.lpr cell-cultures/cells/cells-test/person.lisp
by Kenny Tilton 04 Jul '04

04 Jul '04

Update of /project/cells/cvsroot/cell-cultures/cells/cells-test In directory common-lisp.net:/tmp/cvs-serv5472/cells/cells-test Modified Files: person.lisp Added Files: cells-test.asd cells-test.lpr Log Message: Date: Sun Jul 4 11:59:42 2004 Author: ktilton Index: cell-cultures/cells/cells-test/cells-test.asd diff -u /dev/null cell-cultures/cells/cells-test/cells-test.asd:1.3 --- /dev/null Sun Jul 4 11:59:43 2004 +++ cell-cultures/cells/cells-test/cells-test.asd Sun Jul 4 11:59:42 2004 @@ -0,0 +1,20 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- + +(operate 'load-op :asdf-aclproj) +(use-package :asdf-aclproj) + +#+(or allegro lispworks cmu mcl clisp cormanlispx sbcl scl) + +(asdf:defsystem :cells-test + :name "cells-test" + :author "Kenny Tilton <ktilton(a)nyc.rr.com>" + :version "05-Nov-2003" + :maintainer "Kenny Tilton <ktilton(a)nyc.rr.com>" + :licence "MIT Style" + :description "Cells Regression Test/Documentation" + :long-description "Informatively-commented regression tests for Cells" + :serial t + :components ((lpr-project-file "cells-test"))) + +(defmethod perform :after ((op load-op) (system (eql (find-system :cells-test)))) + (cells::cv-test)) \ No newline at end of file Index: cell-cultures/cells/cells-test/person.lisp diff -u cell-cultures/cells/cells-test/person.lisp:1.2 cell-cultures/cells/cells-test/person.lisp:1.3 --- cell-cultures/cells/cells-test/person.lisp:1.2 Wed Jun 30 20:48:54 2004 +++ cell-cultures/cells/cells-test/person.lisp Sun Jul 4 11:59:42 2004 @@ -287,20 +287,20 @@ (trc "start guarded cyclic") #+not (cv-assert-error - (let ((tk (make-be 'talker))) - (setf (idea tk) "yes") - (cv-assert (string-equal "yes" (words tk))) - (setf (words tk) "no") - (cv-assert (string-equal "no" (idea tk))))) + (let ((tk (make-be 'talker))) + (setf (idea tk) "yes") + (cv-assert (string-equal "yes" (words tk))) + (setf (words tk) "no") + (cv-assert (string-equal "no" (idea tk))))) ;; ;; make sure cells declared to be cyclic are allowed ;; and halt (because after the first cyclic setf the cell in question ;; is being given the same value it already has, and propagation stops. ;; (make-be 'talker8) - #+not (let ((tk (make-be 'talker8))) - (setf (idea8 tk) "yes") - (string-equal "yes" (words8 tk)) - (setf (words8 tk) "no") - (string-equal "no" (idea8 tk))) + #+not (let ((tk (make-be 'talker8))) + (setf (idea8 tk) "yes") + (string-equal "yes" (words8 tk)) + (setf (words8 tk) "no") + (string-equal "no" (idea8 tk))) )

1 0

[cells-cvs] CVS update: cell-cultures/cells/cell-types.lisp cell-cultures/cells/cells.lisp cell-cultures/cells/constructors.lisp cell-cultures/cells/defpackage.lisp cell-cultures/cells/integrity.lisp cell-cultures/cells/md-slot-value.lisp cell-cultures/cells/model-object.lisp cell-cultures/cells/propagate.lisp cell-cultures/cells/synapse.lisp cell-cultures/cells/cells-test.asd cell-cultures/cells/cells-test.lpr cell-cultures/cells/rif.lisp
by Kenny Tilton 04 Jul '04

04 Jul '04

Update of /project/cells/cvsroot/cell-cultures/cells In directory common-lisp.net:/tmp/cvs-serv5472/cells Modified Files: cell-types.lisp cells.lisp constructors.lisp defpackage.lisp integrity.lisp md-slot-value.lisp model-object.lisp propagate.lisp synapse.lisp Removed Files: cells-test.asd cells-test.lpr rif.lisp Log Message: Date: Sun Jul 4 11:59:41 2004 Author: ktilton Index: cell-cultures/cells/cell-types.lisp diff -u cell-cultures/cells/cell-types.lisp:1.1 cell-cultures/cells/cell-types.lisp:1.2 --- cell-cultures/cells/cell-types.lisp:1.1 Sat Jun 26 11:38:36 2004 +++ cell-cultures/cells/cell-types.lisp Sun Jul 4 11:59:41 2004 @@ -53,8 +53,8 @@ (defstruct (c-ruled (:include cell) (:conc-name cr-)) - (synapses nil :type list) lazy + (code nil :type list) ;; /// feature this out on production build rule) (defun c-optimized-away-p (c) @@ -73,8 +73,8 @@ (defstruct (c-dependent (:include c-ruled) (:conc-name cd-)) + (synapses nil :type list) (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)) Index: cell-cultures/cells/cells.lisp diff -u cell-cultures/cells/cells.lisp:1.2 cell-cultures/cells/cells.lisp:1.3 --- cell-cultures/cells/cells.lisp:1.2 Tue Jun 29 01:58:49 2004 +++ cell-cultures/cells/cells.lisp Sun Jul 4 11:59:41 2004 @@ -112,6 +112,7 @@ (declare (ignorable slot-name self new old old-boundp))) + ; -------- cell conditions (not much used) --------------------------------------------- (define-condition xcell () ;; new 2k0227 Index: cell-cultures/cells/constructors.lisp diff -u cell-cultures/cells/constructors.lisp:1.1 cell-cultures/cells/constructors.lisp:1.2 --- cell-cultures/cells/constructors.lisp:1.1 Sat Jun 26 11:38:36 2004 +++ cell-cultures/cells/constructors.lisp Sun Jul 4 11:59:41 2004 @@ -87,7 +87,7 @@ :code ',forms :value-state :unevaluated :rule (c-lambda ,@forms) - ,@keys)) + ,@keys)) (defmacro c-input ((&rest keys) &optional (value nil valued-p)) `(make-cell Index: cell-cultures/cells/defpackage.lisp diff -u cell-cultures/cells/defpackage.lisp:1.3 cell-cultures/cells/defpackage.lisp:1.4 --- cell-cultures/cells/defpackage.lisp:1.3 Wed Jun 30 14:02:47 2004 +++ cell-cultures/cells/defpackage.lisp Sun Jul 4 11:59:41 2004 @@ -38,15 +38,19 @@ #:class-precedence-list #:class-slots #:slot-definition-name ) - - (:export #:cell #:c-input #:c-in #:c-in8 #:c? #:c?8 #:c?_ #:c?? + #+clisp (:import-from #:clos #:class-slots #:class-precedence-list) + #+cmu (:import-from #:pcl #:class-precedence-list #:class-slots + #:slot-definition-name #:true) + #+lispworks (:import-from #:lw #:true) + (:export #:cell #:c-input #:c-in #:c-in8 + #:c-formula #:c? #:c?8 #:c?_ #:c?? #:with-integrity #:with-deference #:without-c-dependency #:self #:.cache #:c-lambda #:.cause #:defmodel #:c-awaken #:def-c-output #:def-c-unchanged-test #:new-value #:old-value #:c... #:make-be #:mkpart #:the-kids #: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 + #: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 #:psib #:to-be #:not-to-be #:ssibno #:md-awaken Index: cell-cultures/cells/integrity.lisp diff -u cell-cultures/cells/integrity.lisp:1.1 cell-cultures/cells/integrity.lisp:1.2 --- cell-cultures/cells/integrity.lisp:1.1 Sat Jun 26 11:38:36 2004 +++ cell-cultures/cells/integrity.lisp Sun Jul 4 11:59:41 2004 @@ -24,6 +24,7 @@ (defun data-pulse-next (pulse-info) (declare (ignorable pulse-info)) + (trc nil "data-pulse-next > " (1+ *data-pulse-id*) pulse-info) (if (< *data-pulse-id* most-positive-fixnum) (incf *data-pulse-id*) (progn @@ -93,7 +94,7 @@ (trc nil "!!!!!!!!!! started new *unfinished-business*" key defer-info) (when (or (zerop *data-pulse-id*) (member opcode '(:setf :makunbound))) - (data-pulse-next defer-info) + (data-pulse-next (cons opcode defer-info)) (trc nil "!!! New pulse, event" *data-pulse-id* defer-info)) (prog1 (funcall action) Index: cell-cultures/cells/md-slot-value.lisp diff -u cell-cultures/cells/md-slot-value.lisp:1.1 cell-cultures/cells/md-slot-value.lisp:1.2 --- cell-cultures/cells/md-slot-value.lisp:1.1 Sat Jun 26 11:38:36 2004 +++ cell-cultures/cells/md-slot-value.lisp Sun Jul 4 11:59:41 2004 @@ -54,6 +54,7 @@ (defun c-influenced-by-pulse (c); &aux (ip *data-pulse-id*)) (unless (c-currentp c) (count-it :c-influenced-by-pulse) + (trc c "c-influenced-by-pulse> " c (c-useds c)) (some (lambda (used) (c-value-ensure-current used) (when (and (c-changed used) (> (c-pulse used)(c-pulse c))) Index: cell-cultures/cells/model-object.lisp diff -u cell-cultures/cells/model-object.lisp:1.1 cell-cultures/cells/model-object.lisp:1.2 --- cell-cultures/cells/model-object.lisp:1.1 Sat Jun 26 11:38:36 2004 +++ cell-cultures/cells/model-object.lisp Sun Jul 4 11:59:41 2004 @@ -96,15 +96,15 @@ (c-model c) self (c-slot-name c) sn (md-slot-cell self sn) c)) - (if (c-unboundp c) - (progn (trc "unbound cell" (type-of c) c) - (bd-slot-makunbound self sn)) - (setf (slot-value self sn) - (if c-isa-cell + + (if c-isa-cell + (if (c-unboundp c) + (bd-slot-makunbound self sn) + (setf (slot-value self sn) (if (c-inputp c) - (c-value c) - nil) - c)))) + (c-value c) + nil))) + (setf (slot-value self sn) c))) ;------------------ md obj initialization ------------------ Index: cell-cultures/cells/propagate.lisp diff -u cell-cultures/cells/propagate.lisp:1.1 cell-cultures/cells/propagate.lisp:1.2 --- cell-cultures/cells/propagate.lisp:1.1 Sat Jun 26 11:38:36 2004 +++ cell-cultures/cells/propagate.lisp Sun Jul 4 11:59:41 2004 @@ -56,15 +56,14 @@ (c-output-slot c (c-slot-name c) (c-model c) (c-value c) prior-value prior-value-supplied))) - (defun c-propagate-to-users (c) (trc nil "c-propagate-to-users > queueing" c :cause *causation*) - (let ((causation (list* c *causation*))) ;; in case deferred + (let ((causation (cons c *causation*))) ;; in case deferred (with-integrity (:user-notify :user-notify c) (let ((*causation* causation)) (trc nil "c-propagate-to-users > notifying users of" c) (dolist (user (c-users c)) - (trc nil "c-propagate-to-users> cause, user, c:" *causation* user c) + (trc user "c-propagate-to-users> *data-pulse-id*, user, c:" *data-pulse-id* user c) (when (c-user-cares user) (c-value-ensure-current user))))))) @@ -89,7 +88,7 @@ (c-output-slot nil slot-name self (bd-slot-value self slot-name) nil nil))) (defun c-output-slot (c slot-name self new-value prior-value prior-value-supplied) - (let ((causation (list* c *causation*))) ;; in case deferred + (let ((causation *causation*)) ;; in case deferred (with-integrity (:c-output-slot :output c) (let ((*causation* causation)) (trc nil "c-output-slot > causation" c *causation* causation) Index: cell-cultures/cells/synapse.lisp diff -u cell-cultures/cells/synapse.lisp:1.1 cell-cultures/cells/synapse.lisp:1.2 --- cell-cultures/cells/synapse.lisp:1.1 Sat Jun 26 11:38:36 2004 +++ cell-cultures/cells/synapse.lisp Sun Jul 4 11:59:41 2004 @@ -28,13 +28,13 @@ (defmacro with-synapse (((&rest closure-vars) &key trcp fire-p fire-value) &body body) (declare (ignorable trcp)) (let ((lex-loc-key (gensym "synapse-id"))) - `(let ((synapse (or (cdr (assoc ',lex-loc-key (cr-synapses + `(let ((synapse (or (cdr (assoc ',lex-loc-key (cd-synapses (car *c-calculators*)))) (cdar (push (cons ',lex-loc-key (let (,@closure-vars) (make-synaptic-ruled slot-c (,fire-p ,fire-value) ,@body))) - (cr-synapses + (cd-synapses (car *c-calculators*))))))) (progn ;;let ((*c-calculators* (cons synapse *c-calculators*))) (c-value-ensure-current synapse)))))

1 0

[cells-cvs] CVS update: cell-cultures/cellodemo/cellodemo.lpr
by Kenny Tilton 04 Jul '04

04 Jul '04

Update of /project/cells/cvsroot/cell-cultures/cellodemo In directory common-lisp.net:/tmp/cvs-serv5472/cellodemo Modified Files: cellodemo.lpr Log Message: Date: Sun Jul 4 11:59:41 2004 Author: ktilton Index: cell-cultures/cellodemo/cellodemo.lpr diff -u cell-cultures/cellodemo/cellodemo.lpr:1.1 cell-cultures/cellodemo/cellodemo.lpr:1.2 --- cell-cultures/cellodemo/cellodemo.lpr:1.1 Sat Jun 26 11:38:35 2004 +++ cell-cultures/cellodemo/cellodemo.lpr Sun Jul 4 11:59:40 2004 @@ -11,8 +11,8 @@ (make-instance 'module :name "tutor-geometry.lisp") (make-instance 'module :name "light-panel.lisp") (make-instance 'module :name "hedron-render.lisp") - (make-instance 'module :name "hedron-decoration.lisp") - (make-instance 'module :name "do-list.lisp")) + (make-instance 'module :name + "hedron-decoration.lisp")) :projects (list (make-instance 'project-module :name "..\\cello\\cello")) :libraries nil

1 0