September 2006 - cells-cvs@common-lisp.net

[cells-cvs] CVS Celtk
by fgoenninger 29 Sep '06

29 Sep '06

Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv31920 Modified Files: composites.lisp Log Message: Added: + Methods iconify and deiconify for class window + new class FULL-SCREEN-NO-DECO-WINDOW as a convenience function for creating a window with no decorations that occupies the whole screen + New functions screen-width and screen-height Changed: + now the symbols application, iconify, deiconify, full-screen-no-deco-window, screen-width, screen-height are exported from the Celtk package. --- /project/cells/cvsroot/Celtk/composites.lisp 2006/09/29 09:15:24 1.17 +++ /project/cells/cvsroot/Celtk/composites.lisp 2006/09/29 16:08:31 1.18 @@ -18,6 +18,19 @@ (in-package :Celtk) +(eval-now! + (export '(title$ active .time decoration))) + +(export! application + keyboard-modifiers + iconify + deiconify + full-screen-no-deco-window + screen-width + screen-height) + +;;; --- decoration ------------------------------------------- + (defmd decoration-mixin () (decoration (c-in :normal))) @@ -70,9 +83,6 @@ (defmodel composite-widget (widget) ((kids-packing :initarg :kids-packing :accessor kids-packing :initform nil))) -(eval-now! - (export '(title$ active .time decoration))) - (defvar *app*) (defmodel application (family) @@ -87,8 +97,6 @@ (defun app-idle (self) (setf (^app-time) (get-internal-real-time))) -(export! keyboard-modifiers) - (defmd window (composite-widget decoration-mixin) (title$ (c? (string-capitalize (class-name (class-of self))))) (dictionary (make-hash-table :test 'equalp)) @@ -105,6 +113,26 @@ on-key-down on-key-up) +(defun screen-width () + (let ((*tkw* *tkw*)) + (tk-format-now "winfo screenwidth ."))) + +(defun screen-height () + (let ((*tkw* *tkw*)) + (tk-format-now "winfo screenheight ."))) + +(defmodel full-screen-no-deco-window (window) + ()) + +(defmethod initialize-instance :before ((self full-screen-no-deco-window) + &key &allow-other-keys) + (tk-format '(:pre-make-tk self) + "wm geometry . [winfo screenwidth .]x[winfo screenheight .]+0+0") + (tk-format '(:pre-make-tk self) "update idletasks") + #-macosx (tk-format '(:pre-make-tk self) "wm attributes . -topmost yes") + (tk-format '(:pre-make-tk self) "wm overrideredirect . yes") + ) + (defmethod do-on-key-down :before (self &rest args &aux (keysym (car args))) (trc nil "ctk::do-on-key-down window" keysym (keyboard-modifiers .tkw)) (bwhen (mod (keysym-to-modifier keysym)) @@ -188,3 +216,14 @@ (defmethod path ((self window)) ".") (defmethod parent-path ((self window)) "") +(defmethod iconify ((self window)) + (%%do-decoration self :normal) + (tk-format `(:fini) "wm iconify ~a" (^path))) + +(defmethod deiconify ((self window)) + (%%do-decoration self (decoration self)) + (tk-format `(:fini) "wm deiconify ~a" (^path))) + + + +

1 0

[cells-cvs] CVS Celtk
by fgoenninger 29 Sep '06

29 Sep '06

Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv17218 Modified Files: composites.lisp Log Message: Changed: Decoration handling now done via mixin class. No available for Toplevel and Window classes. --- /project/cells/cvsroot/Celtk/composites.lisp 2006/09/28 20:54:55 1.16 +++ /project/cells/cvsroot/Celtk/composites.lisp 2006/09/29 09:15:24 1.17 @@ -18,11 +18,12 @@ (in-package :Celtk) - +(defmd decoration-mixin () + (decoration (c-in :normal))) ;;; --- toplevel --------------------------------------------- -(deftk toplevel (widget) +(deftk toplevel (widget decoration-mixin) () (:tk-spec toplevel -borderwidth -cursor -highlightbackground -highlightcolor @@ -35,7 +36,7 @@ ;; --- panedwindow ----------------------------------------- -(deftk panedwindow (widget) +(deftk panedwindow (widget decoration-mixin) () (:tk-spec panedwindow -background -borderwidth -cursor -height @@ -88,7 +89,7 @@ (export! keyboard-modifiers) -(defmd window (composite-widget) +(defmd window (composite-widget decoration-mixin) (title$ (c? (string-capitalize (class-name (class-of self))))) (dictionary (make-hash-table :test 'equalp)) (tkwins (make-hash-table)) @@ -102,8 +103,7 @@ (tkfont-info (tkfont-info-loader)) initial-focus on-key-down - on-key-up - (decoration (c-in :normal))) + on-key-up) (defmethod do-on-key-down :before (self &rest args &aux (keysym (car args))) (trc nil "ctk::do-on-key-down window" keysym (keyboard-modifiers .tkw)) @@ -118,16 +118,41 @@ (setf (keyboard-modifiers .tkw) (delete mod (keyboard-modifiers .tkw)))))) -(defobserver decoration ((self window)) ;; == wm overrideredirect 0|1 +;;; Helper function that actually executes decoration change +(defun %%do-decoration (widget decoration) + (let ((path (path widget))) + (ecase decoration + (:none (progn + (tk-format '(:pre-make-tk decoration) + "wm withdraw ~a" path) + (tk-format '(:pre-make-tk decoration) + "wm overrideredirect ~a 1" path) + (tk-format '(:pre-make-tk decoration) + "wm deiconify ~a" path) + (tk-format '(:pre-make-tk decoration) + "update idletasks" path) + )) + (:normal (progn + (tk-format '(:pre-make-tk decoration) + "wm withdraw ~a" path) + (tk-format '(:pre-make-tk decoration) + "wm overrideredirect ~a 0" path) + (tk-format '(:pre-make-tk decoration) + "wm deiconify ~a" path) + (tk-format '(:pre-make-tk decoration) + "update idletasks" path)))))) + +;;; Decoration observer for all widgets that inherit from decoration-mixin +;;; On Mac OS X this is a one-way operation. When created without decorations +;;; then it is not possible to restore the decorations and vice versa. So on +;;; OS X the window decoration will stay as you created the window with. + +(defobserver decoration ((self decoration-mixin)) ;; == wm overrideredirect 0|1 (assert (or (eq new-value nil) ;; Does not change decoration (eq new-value :normal) ;; "normal" (eq new-value :none))) ;; No title bar, no nothing ... (if (not (eq new-value old-value)) - (case new-value - (:none (tk-format '(:pre-make-tk new-value) - "wm overrideredirect ~a 1" (^path))) - (:normal (tk-format '(:pre-make-tk new-value) - "wm overrideredirect ~a 0" (^path)))))) + (%%do-decoration self new-value))) (defobserver initial-focus () (when new-value

1 0

[cells-cvs] CVS Celtk
by fgoenninger 28 Sep '06

28 Sep '06

Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv10623 Modified Files: composites.lisp Log Message: Added: export of symbol 'decoration. --- /project/cells/cvsroot/Celtk/composites.lisp 2006/09/28 20:02:40 1.15 +++ /project/cells/cvsroot/Celtk/composites.lisp 2006/09/28 20:54:55 1.16 @@ -70,7 +70,7 @@ ((kids-packing :initarg :kids-packing :accessor kids-packing :initform nil))) (eval-now! - (export '(title$ active .time))) + (export '(title$ active .time decoration))) (defvar *app*)

1 0

[cells-cvs] CVS Celtk
by fgoenninger 28 Sep '06

28 Sep '06

Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv4713 Modified Files: composites.lisp Log Message: Added: Cell slot "decoration" to window. This allows creating Splash screens without any window manager decoration: No title bar, no border, no nothing. Use :decoration :none for the defmodel of a window to achieve this. Setting decoration to :normal restores all window decorations. --- /project/cells/cvsroot/Celtk/composites.lisp 2006/09/05 18:43:22 1.14 +++ /project/cells/cvsroot/Celtk/composites.lisp 2006/09/28 20:02:40 1.15 @@ -102,9 +102,8 @@ (tkfont-info (tkfont-info-loader)) initial-focus on-key-down - on-key-up) - - + on-key-up + (decoration (c-in :normal))) (defmethod do-on-key-down :before (self &rest args &aux (keysym (car args))) (trc nil "ctk::do-on-key-down window" keysym (keyboard-modifiers .tkw)) @@ -119,6 +118,17 @@ (setf (keyboard-modifiers .tkw) (delete mod (keyboard-modifiers .tkw)))))) +(defobserver decoration ((self window)) ;; == wm overrideredirect 0|1 + (assert (or (eq new-value nil) ;; Does not change decoration + (eq new-value :normal) ;; "normal" + (eq new-value :none))) ;; No title bar, no nothing ... + (if (not (eq new-value old-value)) + (case new-value + (:none (tk-format '(:pre-make-tk new-value) + "wm overrideredirect ~a 1" (^path))) + (:normal (tk-format '(:pre-make-tk new-value) + "wm overrideredirect ~a 0" (^path)))))) + (defobserver initial-focus () (when new-value (tk-format '(:fini new-value) "focus ~a" (path new-value))))

1 0

[cells-cvs] CVS Celtk
by ktilton 05 Sep '06

05 Sep '06

Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv31540 Modified Files: Celtk.lisp composites.lisp demos.lisp run.lisp timer.lisp tk-object.lisp togl.lisp Log Message: --- /project/cells/cvsroot/Celtk/Celtk.lisp 2006/07/06 22:10:39 1.34 +++ /project/cells/cvsroot/Celtk/Celtk.lisp 2006/09/05 18:43:22 1.35 @@ -16,7 +16,7 @@ |# -;;; $Header: /project/cells/cvsroot/Celtk/Celtk.lisp,v 1.34 2006/07/06 22:10:39 ktilton Exp $ +;;; $Header: /project/cells/cvsroot/Celtk/Celtk.lisp,v 1.35 2006/09/05 18:43:22 ktilton Exp $ (defpackage :celtk (:nicknames "CTK") @@ -24,7 +24,7 @@ (:export #:right #:left #:<1> #:tk-event-type #:xsv #:name #:x #:y #:x-root #:y-root - #:title$ #:pop-up #:path #:parent-path #:^keyboard-modifiers #:keyboard-modifiers + #:title$ #:pop-up #:path #:parent-path #:^keyboard-modifiers #:window #:panedwindow #:mk-row #:c?pack-self #:mk-stack #:mk-text-widget #:text-widget #:mk-panedwindow #:mk-stack #:mk-radiobutton #:mk-radiobutton-ex #:mk-radiobutton #:mk-label --- /project/cells/cvsroot/Celtk/composites.lisp 2006/07/06 22:10:40 1.13 +++ /project/cells/cvsroot/Celtk/composites.lisp 2006/09/05 18:43:22 1.14 @@ -86,6 +86,8 @@ (defun app-idle (self) (setf (^app-time) (get-internal-real-time))) +(export! keyboard-modifiers) + (defmd window (composite-widget) (title$ (c? (string-capitalize (class-name (class-of self))))) (dictionary (make-hash-table :test 'equalp)) @@ -102,6 +104,21 @@ on-key-down on-key-up) + + +(defmethod do-on-key-down :before (self &rest args &aux (keysym (car args))) + (trc nil "ctk::do-on-key-down window" keysym (keyboard-modifiers .tkw)) + (bwhen (mod (keysym-to-modifier keysym)) + (eko (nil "modifiers after adding" mod) + (pushnew mod (keyboard-modifiers .tkw))))) + +(defmethod do-on-key-up :before (self &rest args &aux (keysym (car args))) + (trc nil "ctk::do-on-key-up before" keysym (keyboard-modifiers .tkw)) + (bwhen (mod (keysym-to-modifier keysym)) + (eko (nil "modifiers after removing" mod) + (setf (keyboard-modifiers .tkw) + (delete mod (keyboard-modifiers .tkw)))))) + (defobserver initial-focus () (when new-value (tk-format '(:fini new-value) "focus ~a" (path new-value)))) --- /project/cells/cvsroot/Celtk/demos.lisp 2006/06/29 09:54:52 1.23 +++ /project/cells/cvsroot/Celtk/demos.lisp 2006/09/05 18:43:22 1.24 @@ -19,6 +19,35 @@ (in-package :celtk-user) +(defmodel my-test (window) + ((my-mode :accessor my-mode :initform (c? (evenp (selection (fm! :my-selector)))))) + (:default-initargs + :id :my-test-id + :kids (c? (the-kids + (mk-stack ("stack" :packing (c?pack-self "-side bottom") :relief 'ridge) + (mk-entry :id :my-entry + :md-value (c-in "abc")) + (mk-row ( "row" #| :packing (c?pack-self "-side bottom") |# :relief 'ridge) + (mk-label :text (c? (format nil "selection: ~a" (selection (fm^ :my-selector))))) + (mk-label :text "Labeltext") + (mk-button-ex ("Reset" (setf (selection (fm^ :my-selector)) 1))) + (mk-stack ((c? (format nil "current selection: ~a" (^selection))) :id :my-selector :selection (c-in 1) :relief 'ridge) + (mk-radiobutton-ex ("selection 1" 1)) + (mk-radiobutton-ex ("selection 2" 2)) + (mk-radiobutton-ex ("selection 3" 3)) + (mk-radiobutton-ex ("selection 4" 4))) + (mk-label :text (c? (format nil "selection: ~a" (selection (fm^ :my-selector))))) + )))))) + +(defobserver my-mode ((self my-test) new-value old-value old-value-bound-p) + (format t "~% mode changed from ~a to ~a" old-value new-value)) + +(defun ctk::franks-test () + (run-window 'my-test)) + +#+test +(ctk::franks-test) + (defun ctk::tk-test () ;; ACL project manager needs a zero-argument function, in project package (test-window ;;'place-test --- /project/cells/cvsroot/Celtk/run.lisp 2006/07/06 22:10:40 1.19 +++ /project/cells/cvsroot/Celtk/run.lisp 2006/09/05 18:43:22 1.20 @@ -53,7 +53,7 @@ :fm-parent *parent* window-initargs)))) ))) - + (assert (tkwin *tkw*)) (tk-format `(:fini) "wm deiconify .") @@ -89,29 +89,32 @@ (defmethod widget-event-handle ((self window) xe) (let ((*tkw* self)) - (TRC nil "main window event" *tkw* (xevent-type xe)) + (TRC nil "main window event" self *tkw* (xevent-type xe)) (flet ((give-to-window () (bwhen (eh (event-handler *tkw*)) (funcall eh *tkw* xe)))) (case (xevent-type xe) ((:MotionNotify :buttonpress) #+shhh (call-dump-event client-data xe)) + (:destroyNotify (let ((*windows-destroyed* (cons *tkw* *windows-destroyed*))) (ensure-destruction *tkw*))) + (:virtualevent (bwhen (n$ (xsv name xe)) (trc nil "main-window-proc :" n$ (unless (null-pointer-p (xsv user-data xe)) (tcl-get-string (xsv user-data xe)))) (case (read-from-string (string-upcase n$)) - (keypress (trc "going after keysym") + (keypress (break "this works??: going after keysym") (let ((keysym (tcl-get-string (xsv user-data xe)))) (trc "keypress keysym!!!!" (tcl-get-string (xsv user-data xe))) (bIf (mod (keysym-to-modifier keysym)) (eko ("modifiers now") (pushnew mod (keyboard-modifiers *tkw*))) (trc "unhandled pressed keysym" keysym)))) - (keyrelease (let ((keysym (tcl-get-string (xsv user-data xe)))) + (keyrelease (break "this works??: going after keysym") + (let ((keysym (tcl-get-string (xsv user-data xe)))) (bIf (mod (keysym-to-modifier keysym)) (eko ("modifiers now") (setf (keyboard-modifiers *tkw*) @@ -123,14 +126,15 @@ (window-destroyed (ensure-destruction *tkw*)) - (otherwise (give-to-window))))) + (otherwise + (give-to-window))))) (otherwise (give-to-window))) 0))) ;; Our own event loop ! - Use this if it is desirable to do something ;; else between events -(defparameter *event-loop-delay* 0.08 "Minimum delay [s] in event loop not to lock out IDE (ACL anyway)") +(defparameter *event-loop-delay* 0.08 "Minimum delay [s] in event loop not to lock out IDE (ACL anyway)") (defun tcl-do-one-event-loop () (loop while (plusp (tk-get-num-main-windows)) --- /project/cells/cvsroot/Celtk/timer.lisp 2006/09/03 13:39:56 1.11 +++ /project/cells/cvsroot/Celtk/timer.lisp 2006/09/05 18:43:22 1.12 @@ -93,6 +93,9 @@ (with-integrity (:client `(:fini ,self)) ;; just guessing as to when, not sure it matters (set-timer self (^delay)))))))))) +(defmethod not-to-be :before ((self timer)) + (setf (state self) :off)) + (defobserver state ((self timer)) (unless (eq new-value :on) (cancel-timer self))) --- /project/cells/cvsroot/Celtk/tk-object.lisp 2006/09/03 13:39:56 1.9 +++ /project/cells/cvsroot/Celtk/tk-object.lisp 2006/09/05 18:43:22 1.10 @@ -25,20 +25,15 @@ ((.md-name :cell nil :initform (gentemp "TK") :initarg :id) (tk-class :cell nil :initform nil :initarg :tk-class :reader tk-class) - (timers :initarg :timers :accessor timers :initform nil) + (timers :owning t :initarg :timers :accessor timers :initform nil) (on-command :initarg :on-command :accessor on-command :initform nil) (on-key-down :initarg :on-key-down :accessor on-key-down :initform nil - :documentation "Long story. Tcl C API sucks for keypress events. This gets dispatched + :documentation "Long story. Tcl C API weak for keypress events. This gets dispatched eventually thanks to DEFCOMMAND") (on-key-up :initarg :on-key-up :accessor on-key-up :initform nil) (user-errors :initarg :user-errors :accessor user-errors :initform nil)) (:documentation "Root class for widgets and (canvas) items")) -(defmethod not-to-be :before ((self tk-object)) - (loop for timer in (^timers) do - (setf (state timer) :off) - (not-to-be timer))) - (defmethod md-awaken :before ((self tk-object)) (make-tk-instance self)) --- /project/cells/cvsroot/Celtk/togl.lisp 2006/09/03 13:39:56 1.19 +++ /project/cells/cvsroot/Celtk/togl.lisp 2006/09/05 18:43:22 1.20 @@ -185,8 +185,8 @@ (def-togl-callback create () (trc "!!!!!!!!!!!!!!!!!! about to install togl-ptr!!!!!!!!!!!!!!!!!!" togl-ptr ) - ;;#+cl-ftgl (setf cl-ftgl::*ftgl-ogl* togl-ptr) ;; help debug failure to use lazy cells/classes to defer FTGL till Ogl ready - ;;(ogl::kt-opengl-reset) + #+cl-ftgl (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:kt-opengl-reset) (setf (togl-ptr self) togl-ptr) (setf (gethash (pointer-address togl-ptr) (tkwins *tkw*)) self))

1 0

[cells-cvs] CVS cells/utils-kt
by ktilton 05 Sep '06

05 Sep '06

Update of /project/cells/cvsroot/cells/utils-kt In directory clnet:/tmp/cvs-serv30469/utils-kt Modified Files: debug.lisp defpackage.lisp detritus.lisp flow-control.lisp strings.lisp Log Message: New :owning slot parameter automates NOT-TO-BE of slot contents as value/values disappear. --- /project/cells/cvsroot/cells/utils-kt/debug.lisp 2006/09/03 13:41:10 1.11 +++ /project/cells/cvsroot/cells/utils-kt/debug.lisp 2006/09/05 18:40:48 1.12 @@ -95,20 +95,20 @@ `(if ,onp (prog1 (time (progn ,@body)) - (trc "timing was of" ,@trcargs)) + (format t "timing was of ~{ ~a~}" ,@trcargs)) (progn ,@body))) #+save (defun dbg-time-report (cpu-gc-user cpu-gc-sys cpu-tot-user cpu-tot-sys real-time conses other-bytes static-bytes) - (trc "cpu-gc-user" cpu-gc-user) - (trc "cpu-gc-sys" cpu-gc-sys) - (trc "cpu-tot-user" cpu-tot-user) - (trc "cpu-tot-sys" cpu-tot-sys) - (trc "<non-gc user cpu>" (- cpu-tot-user cpu-gc-user)) - (trc "<non-gc sys cpu>" (- cpu-tot-sys cpu-gc-sys)) - (trc "conses" conses) - (trc "other-bytes" other-bytes) - (trc "static-bytes" static-bytes) + (format t "~&cpu-gc-user ~a" cpu-gc-user) + (format t "~&cpu-gc-sys ~a" cpu-gc-sys) + (format t "~&cpu-tot-user ~a" cpu-tot-user) + (format t "~&cpu-tot-sys ~a" cpu-tot-sys) + (format t "~&<non-gc user cpu> ~a" (- cpu-tot-user cpu-gc-user)) + (format t "~&<non-gc sys cpu> ~a" (- cpu-tot-sys cpu-gc-sys)) + (format t "~&conses ~a" conses) + (format t "~&other-bytes ~a" other-bytes) + (format t "~&static-bytes ~a" static-bytes) (excl::time-report cpu-gc-user cpu-gc-sys cpu-tot-user cpu-tot-sys real-time conses other-bytes static-bytes)) ;---------------- Metrics ------------------- --- /project/cells/cvsroot/cells/utils-kt/defpackage.lisp 2006/08/21 04:29:31 1.5 +++ /project/cells/cvsroot/cells/utils-kt/defpackage.lisp 2006/09/05 18:40:48 1.6 @@ -26,13 +26,13 @@ #+openmcl-partial-mop #:openmcl-mop #+(and mcl (not openmcl-partial-mop)) #:ccl) (:export #:utils-kt-reset - #:eko #:count-it #:count-of #:trc #:trcp + #:count-it #:count-of #:wdbg #:maptimes #:bwhen #:bif #:xor #:with-dynamic-fn #:last1 #:packed-flat! #:with-metrics #:shortc #:intern$ #:define-constant #:*count* #:*stop* - #:*dbg* #:*trcdepth* + #:*dbg* #:make-fifo-queue #:fifo-queue #:fifo-add #:fifo-delete #:fifo-empty #:fifo-pop #:fifo-clear #:fifo-map #:fifo-peek #:fifo-data #:with-fifo-map #:fifo-length --- /project/cells/cvsroot/cells/utils-kt/detritus.lisp 2006/08/21 04:29:31 1.9 +++ /project/cells/cvsroot/cells/utils-kt/detritus.lisp 2006/09/05 18:40:48 1.10 @@ -154,8 +154,7 @@ (defun tree-includes (sought tree &key (test 'eql)) (typecase tree (null) - (atom (eko (nil "tree-inc? testing" sought tree) - (funcall test sought tree))) + (atom (funcall test sought tree)) (cons (loop for subtree in tree when (tree-includes sought subtree :test test) do (return-from tree-includes t))))) @@ -171,7 +170,6 @@ (defun tree-intersect (t1 t2 &key (test 'eql)) (tree-traverse t1 (lambda (t1-node) - (eko (nil "treeinter?" t1-node t2) - (when (tree-includes t1-node t2 :test test) - (return-from tree-intersect t1-node)))))) + (when (tree-includes t1-node t2 :test test) + (return-from tree-intersect t1-node))))) --- /project/cells/cvsroot/cells/utils-kt/flow-control.lisp 2006/08/21 04:29:31 1.5 +++ /project/cells/cvsroot/cells/utils-kt/flow-control.lisp 2006/09/05 18:40:50 1.6 @@ -31,7 +31,7 @@ (defun min-if (v1 v2) (if v1 (if v2 (min v1 v2) v1) v2)) -(export! list-flatten!) +(export! list-flatten! tree-flatten) (defun list-flatten! (&rest list) (if (consp list) @@ -56,6 +56,9 @@ head) list)) +(defun tree-flatten (tree) + (list-flatten! (copy-tree tree))) + (defun packed-flat! (&rest u-nameit) (delete nil (list-flatten! u-nameit))) --- /project/cells/cvsroot/cells/utils-kt/strings.lisp 2006/07/06 22:10:03 1.5 +++ /project/cells/cvsroot/cells/utils-kt/strings.lisp 2006/09/05 18:40:50 1.6 @@ -140,8 +140,7 @@ (or (null s) (if (stringp s) (string-equal "" (trim$ s)) - #+(or) (trc nil "empty$> sees non-string" (type-of s))) - )) + #+(or) (format t "empty$> sees non-string ~a" (type-of s))))) (defmacro find$ (it where &rest args) `(find ,it ,where ,@args :test #'string-equal))

1 0

[cells-cvs] CVS cells
by ktilton 05 Sep '06

05 Sep '06

Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv30469 Modified Files: defmodel.lisp family.lisp model-object.lisp propagate.lisp Log Message: New :owning slot parameter automates NOT-TO-BE of slot contents as value/values disappear. --- /project/cells/cvsroot/cells/defmodel.lisp 2006/08/21 04:29:30 1.8 +++ /project/cells/cvsroot/cells/defmodel.lisp 2006/09/05 18:40:47 1.9 @@ -26,30 +26,32 @@ ; ; define slot macros before class so they can appear in initforms and default-initargs ; - ,@(loop for slotspec in slotspecs - collecting (destructuring-bind + ,@(delete nil + (loop for slotspec in slotspecs + nconcing (destructuring-bind (slotname &rest slotargs - &key (cell t) (accessor slotname) reader + &key (cell t) owning (accessor slotname) reader &allow-other-keys) slotspec (declare (ignorable slotargs)) - (when cell - (let* ((reader-fn (or reader accessor)) - (deriver-fn (intern$ "^" (symbol-name reader-fn))) - ) - ; - ; may as well do this here... - ; - ;;(trc nil "slot, deriverfn would be" slotname deriverfn) - `(eval-when (:compile-toplevel :execute :load-toplevel) - (setf (md-slot-cell-type ',class ',slotname) ,cell) - (unless (macro-function ',deriver-fn) - (defmacro ,deriver-fn () - `(,',reader-fn self))) - ) - )) - )) + (list + (when cell + (let* ((reader-fn (or reader accessor)) + (deriver-fn (intern$ "^" (symbol-name reader-fn))) + ) + ; + ; may as well do this here... + ; + ;;(trc nil "slot, deriverfn would be" slotname deriverfn) + `(eval-when (:compile-toplevel :execute :load-toplevel) + (setf (md-slot-cell-type ',class ',slotname) ,cell) + (unless (macro-function ',deriver-fn) + (defmacro ,deriver-fn () + `(,',reader-fn self)))))) + (when owning + `(eval-when (:compile-toplevel :execute :load-toplevel) + (setf (md-slot-owning ',class ',slotname) ,owning))))))) ; ; ------- defclass --------------- (^slot-value ,model ',',slotname) @@ -66,6 +68,7 @@ (remf ias :writer) (remf ias :accessor)) (remf ias :cell) + (remf ias :owning) (remf ias :unchanged-if) ias))) (mapcar #'copy-list slotspecs)) (:documentation @@ -123,6 +126,7 @@ (defun defmd-canonicalize-slot (slotname &key (cell nil cell-p) + (owning nil owning-p) (type nil type-p) (initform nil initform-p) (initarg (intern (symbol-name slotname) :keyword)) @@ -135,6 +139,7 @@ (list* slotname :initarg initarg (append (when cell-p (list :cell cell)) + (when owning-p (list :owning owning)) (when type-p (list :type type)) (when initform-p (list :initform initform)) (when unchanged-if-p (list :unchanged-if unchanged-if)) --- /project/cells/cvsroot/cells/family.lisp 2006/09/03 13:41:09 1.13 +++ /project/cells/cvsroot/cells/family.lisp 2006/09/05 18:40:47 1.14 @@ -64,12 +64,13 @@ (defmodel family (model) ((.kid-slots :cell nil - :initform nil - :accessor kid-slots - :initarg :kid-slots) + :initform nil + :accessor kid-slots + :initarg :kid-slots) (.kids :initform (c-in nil) ;; most useful - :accessor kids - :initarg :kids) + :owning t + :accessor kids + :initarg :kids) )) (defvar *parent*) @@ -152,11 +153,7 @@ (bwhen (sample (find-if-not 'fm-parent new-kids)) (c-break "New as of Cells3: parent must be supplied to make-instance of ~a kid ~a" (type-of sample) sample)) - (trc nil ".kids output > entry" new-kids (mapcar 'fm-parent new-kids)) - - (dolist (k (set-difference old-kids new-kids)) - (trc nil "kids change nailing lost kid" k) - (not-to-be k))) + (trc nil ".kids output > entry" new-kids (mapcar 'fm-parent new-kids))) (defmethod kids ((other model-object)) nil) --- /project/cells/cvsroot/cells/model-object.lisp 2006/09/03 13:41:09 1.10 +++ /project/cells/cvsroot/cells/model-object.lisp 2006/09/05 18:40:47 1.11 @@ -45,12 +45,13 @@ ; here we shuttle cells out of the slots and into a per-instance dictionary of cells, ; as well as tell the cells what slot and instance they are mediating. ; + (when (slot-boundp self '.md-state) (loop for esd in (class-slots (class-of self)) for sn = (slot-definition-name esd) for sv = (when (slot-boundp self sn) (slot-value self sn)) - ;;do (print (list self sn sv (typep sv 'cell))) + ;; do (print (list self sn sv (typep sv 'cell))) when (typep sv 'cell) do (if (md-slot-cell-type (type-of self) sn) (md-install-cell self sn sv) @@ -171,6 +172,21 @@ (setf (cdr entry) new-type) (push (cons slot-name new-type) (get class-name :cell-types))))) +(defun md-slot-owning (class-name slot-name) + (bif (entry (assoc slot-name (get class-name :ownings))) + (cdr entry) + (dolist (super (class-precedence-list (find-class class-name))) + (bwhen (entry (assoc slot-name (get (c-class-name super) :ownings))) + (return (setf (md-slot-owning class-name slot-name) (cdr entry))))))) + +(defun (setf md-slot-owning) (value class-name slot-name) + (let ((entry (assoc slot-name (get class-name :ownings)))) + (if entry + (setf (cdr entry) value) + (push (cons slot-name value) (get class-name :ownings))))) + + + (defmethod md-slot-value-store ((self model-object) slot-name new-value) (trc nil "md-slot-value-store" slot-name new-value) (setf (slot-value self slot-name) new-value)) --- /project/cells/cvsroot/cells/propagate.lisp 2006/09/03 13:41:09 1.20 +++ /project/cells/cvsroot/cells/propagate.lisp 2006/09/05 18:40:47 1.21 @@ -94,6 +94,15 @@ (slot-value-observe (c-slot-name c) (c-model c) (c-value c) prior-value prior-value-supplied) + (when (and prior-value-supplied + prior-value + (md-slot-owning (type-of (c-model c)) (c-slot-name c))) + (bwhen (lost (set-difference prior-value (c-value c))) + (trc "bingo!!!!! lost nailing" lost) + (break "go") + (typecase lost + (atom (not-to-be lost)) + (cons (mapcar 'not-to-be lost))))) ; ; with propagation done, ephemerals can be reset. we also do this in c-awaken, so ; let the fn decide if C really is ephemeral. Note that it might be possible to leave

1 0

[cells-cvs] CVS cells/utils-kt
by ktilton 03 Sep '06

03 Sep '06

Update of /project/cells/cvsroot/cells/utils-kt In directory clnet:/tmp/cvs-serv16378/utils-kt Modified Files: debug.lisp utils-kt.lpr Log Message: --- /project/cells/cvsroot/cells/utils-kt/debug.lisp 2006/08/21 04:29:31 1.10 +++ /project/cells/cvsroot/cells/utils-kt/debug.lisp 2006/09/03 13:41:10 1.11 @@ -36,6 +36,7 @@ ;------------- counting --------------------------- +(export! with-counts) (defmacro with-counts ((onp &rest msg) &body body) `(if ,onp --- /project/cells/cvsroot/cells/utils-kt/utils-kt.lpr 2006/08/22 14:59:38 1.17 +++ /project/cells/cvsroot/cells/utils-kt/utils-kt.lpr 2006/09/03 13:41:10 1.18 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.0 [Windows] (Aug 17, 2006 12:24)"; cg: "1.81"; -*- +;; -*- lisp-version: "8.0 [Windows] (Aug 24, 2006 21:48)"; cg: "1.81"; -*- (in-package :cg-user)

1 0

[cells-cvs] CVS cells
by ktilton 03 Sep '06

03 Sep '06

Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv16378 Modified Files: family.lisp md-utilities.lisp model-object.lisp propagate.lisp trc-eko.lisp Log Message: --- /project/cells/cvsroot/cells/family.lisp 2006/08/28 21:44:13 1.12 +++ /project/cells/cvsroot/cells/family.lisp 2006/09/03 13:41:09 1.13 @@ -31,6 +31,10 @@ (declare (ignore other)) nil) +(defmethod (setf fm-parent) (new-value other) + (declare (ignore other)) + new-value) + (defmethod print-object ((self model) s) (format s "~a" (type-of self)) #+shhh (format s "~a" (or (md-name self) (type-of self)))) --- /project/cells/cvsroot/cells/md-utilities.lisp 2006/08/21 04:29:30 1.7 +++ /project/cells/cvsroot/cells/md-utilities.lisp 2006/09/03 13:41:09 1.8 @@ -27,6 +27,9 @@ (defmethod md-release (other) (declare (ignorable other))) +(export! md-dead) +(defun md-dead (SELF) + (eq :eternal-rest (md-state SELF))) ;___________________ birth / death__________________________________ (defmethod not-to-be :around (self) --- /project/cells/cvsroot/cells/model-object.lisp 2006/06/29 09:54:06 1.9 +++ /project/cells/cvsroot/cells/model-object.lisp 2006/09/03 13:41:09 1.10 @@ -68,6 +68,7 @@ ; (when c-isa-cell (count-it :md-install-cell) + (setf (c-model c) self (c-slot-name c) sn @@ -103,7 +104,7 @@ (trc nil "md-awaken entry" self (md-state self)) (c-assert (eql :nascent (md-state self))) (count-it :md-awaken) - ;;(count-it 'mdawaken (type-of self)) + (count-it 'mdawaken) ; --- --- /project/cells/cvsroot/cells/propagate.lisp 2006/07/24 05:03:08 1.19 +++ /project/cells/cvsroot/cells/propagate.lisp 2006/09/03 13:41:09 1.20 @@ -46,7 +46,8 @@ (defun c-pulse-update (c key) (declare (ignorable key)) - (trc nil "c-pulse-update updating as unchanged!!!" *data-pulse-id* c key) + (trc nil "c-pulse-update updating" *data-pulse-id* c key) + (assert (>= *data-pulse-id* (c-pulse c))) (setf (c-changed c) nil (c-pulse c) *data-pulse-id*)) --- /project/cells/cvsroot/cells/trc-eko.lisp 2006/08/22 14:59:37 1.1 +++ /project/cells/cvsroot/cells/trc-eko.lisp 2006/09/03 13:41:09 1.2 @@ -46,12 +46,15 @@ (count-it :trcfailed))) (count-it :tgtnileval))))))) +(defparameter *last-trc* (get-internal-real-time)) + (defun call-trc (stream s &rest os) (if #+cormanlisp nil #-cormanlisp (and (boundp '*trcdepth*) *trcdepth*) (format stream "~&~v,,,'.<~d~>> " (mod *trcdepth* 100) *trcdepth*) (format stream "~&")) - + (format stream " ~a " (round (- (get-internal-real-time) *last-trc*) 10)) + (setf *last-trc* (get-internal-real-time)) (format stream "~a" s) (let (pkwp) (dolist (o os)

1 0

[cells-cvs] CVS Celtk
by ktilton 03 Sep '06

03 Sep '06

Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv15575 Modified Files: entry.lisp ltktest-ci.lisp timer.lisp tk-object.lisp togl.lisp Log Message: --- /project/cells/cvsroot/Celtk/entry.lisp 2006/06/03 12:04:37 1.14 +++ /project/cells/cvsroot/Celtk/entry.lisp 2006/09/03 13:39:56 1.15 @@ -16,7 +16,7 @@ |# -;;; $Header: /project/cells/cvsroot/Celtk/entry.lisp,v 1.14 2006/06/03 12:04:37 ktilton Exp $ +;;; $Header: /project/cells/cvsroot/Celtk/entry.lisp,v 1.15 2006/09/03 13:39:56 ktilton Exp $ (in-package :Celtk) @@ -40,10 +40,10 @@ :xscrollcommand (c-in nil) :textvariable (c? (intern (^path))) :event-handler (lambda (self xe) - (TRC nil "widget-event-handler" self (xsv type xe) ) + (TRC nil "ENTRY event-handler" self (xsv type xe) (tk-event-type (xsv type xe))) (case (tk-event-type (xsv type xe)) (:virtualevent - (trc nil "v/e" (xsv name xe)) + (trc nil "ENTRY virtual event" (xsv name xe)) (case (read-from-string (string-upcase (xsv name xe))) (trace (TRC nil "entry e/h trace" self (when (plusp (xsv user-data xe)) --- /project/cells/cvsroot/Celtk/ltktest-ci.lisp 2006/06/07 22:13:41 1.8 +++ /project/cells/cvsroot/Celtk/ltktest-ci.lisp 2006/09/03 13:39:56 1.9 @@ -99,7 +99,7 @@ ; to defer things until The Right Time. Which brings us back to Tk. Inspect the source of ; tk-user-queue-handler and search the Celtk source for "with-integrity (:client" to see how Celtk ; manages to talk to Tk in the order Tk likes. And hack the function tk-format-now to have - ; Celtk dump the TCL/Tk code being sent to wish during initialization, and notice how un-random it looks. You can + ; Celtk dump the code it has evaluated by TCL/Tk during initialization, and notice how un-random it looks. You can ; then comment out the above specification of a Tk-savvy handler to see (a) the order that would have happened ; before Cells3 and (b) the demo collapse in a broken heap. ; @@ -393,7 +393,6 @@ for y = (+ (* 50 (cos angle-2)) 200 (* 150 (cos w))) nconcing (list x y)))))) - (defun (setf moire-spin) (repeat self) (setf (repeat (car (timers self))) repeat)) ;; just hiding the implementation @@ -453,3 +452,6 @@ (defun mk-entry-numeric (&rest iargs) (apply 'make-instance 'entry-numeric :fm-parent *parent* iargs)) +(defun ctk::ltktest-ci () + (cells-reset 'tk-user-queue-handler) + (ctk:test-window 'ltktest-cells-inside)) \ No newline at end of file --- /project/cells/cvsroot/Celtk/timer.lisp 2006/07/24 05:04:01 1.10 +++ /project/cells/cvsroot/Celtk/timer.lisp 2006/09/03 13:39:56 1.11 @@ -74,10 +74,13 @@ (on-command :reader on-command :initform (lambda (self) - (when (eq (^state) :on) + (unless (md-dead self) + (trc nil "timer on-command dispatched!!!!!" self) + (when (eq (^state) :on) (assert (^action)) (funcall (^action) self) - (setf (^executed) t)))) + (setf (^executed) t))))) + (after-factory :reader after-factory :initform (c? (bwhen (rpt (when (eq (^state) :on) (^repeat))) @@ -92,7 +95,6 @@ (defobserver state ((self timer)) (unless (eq new-value :on) - (trc "bingo!!!!!!!!!!!!!!!!!!!!! state takes out timer" self) (cancel-timer self))) (defun set-timer (self time) --- /project/cells/cvsroot/Celtk/tk-object.lisp 2006/07/06 22:10:40 1.8 +++ /project/cells/cvsroot/Celtk/tk-object.lisp 2006/09/03 13:39:56 1.9 @@ -34,6 +34,11 @@ (user-errors :initarg :user-errors :accessor user-errors :initform nil)) (:documentation "Root class for widgets and (canvas) items")) +(defmethod not-to-be :before ((self tk-object)) + (loop for timer in (^timers) do + (setf (state timer) :off) + (not-to-be timer))) + (defmethod md-awaken :before ((self tk-object)) (make-tk-instance self)) --- /project/cells/cvsroot/Celtk/togl.lisp 2006/08/28 21:44:40 1.18 +++ /project/cells/cvsroot/Celtk/togl.lisp 2006/09/03 13:39:56 1.19 @@ -185,8 +185,8 @@ (def-togl-callback create () (trc "!!!!!!!!!!!!!!!!!! about to install togl-ptr!!!!!!!!!!!!!!!!!!" togl-ptr ) - #+cl-ftgl (setf cl-ftgl::*ftgl-ogl* togl-ptr) ;; help debug failure to use lazy cells/classes to defer FTGL till Ogl ready - (ogl::kt-opengl-reset) + ;;#+cl-ftgl (setf cl-ftgl::*ftgl-ogl* togl-ptr) ;; help debug failure to use lazy cells/classes to defer FTGL till Ogl ready + ;;(ogl::kt-opengl-reset) (setf (togl-ptr self) togl-ptr) (setf (gethash (pointer-address togl-ptr) (tkwins *tkw*)) self))

1 0