Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv11067
Modified Files: Celtk.lisp composites.lisp lotsa-widgets.lisp menu.lisp run.lisp Log Message:
--- /project/cells/cvsroot/Celtk/Celtk.lisp 2006/10/02 02:56:01 1.36 +++ /project/cells/cvsroot/Celtk/Celtk.lisp 2006/11/13 05:28:52 1.37 @@ -16,7 +16,7 @@
|#
-;;; $Header: /project/cells/cvsroot/Celtk/Celtk.lisp,v 1.36 2006/10/02 02:56:01 ktilton Exp $ +;;; $Header: /project/cells/cvsroot/Celtk/Celtk.lisp,v 1.37 2006/11/13 05:28:52 ktilton Exp $
(defpackage :celtk (:nicknames "CTK") @@ -96,12 +96,12 @@ unless (find (car defer-info) +tk-client-task-priority+) do (error "unknown tk client task type ~a in task: ~a " (car defer-info) defer-info))
- (loop for (nil #+not defer-info . task) in (prog1 - (stable-sort (fifo-data user-q) 'tk-user-queue-sort :key 'car) - (fifo-clear user-q)) + (loop for (defer-info . task) in (prog1 + (stable-sort (fifo-data user-q) 'tk-user-queue-sort :key 'car) + (fifo-clear user-q)) do (trc nil "!!! --- tk-user-queue-handler dispatching" defer-info) - (funcall task))) + (funcall task :user-q defer-info)))
(defun tk-format-now (fmt$ &rest fmt-args) (unless (find *tkw* *windows-destroyed*) @@ -111,12 +111,12 @@ ; --- debug stuff --------------------------------- ;
- (let ((yes '()) + (let ((yes '("pack")) (no '("font"))) (declare (ignorable yes no)) - (when #+not t (and (or ;; (null yes) - (find-if (lambda (s) (search s tk$)) yes)) - (not (find-if (lambda (s) (search s tk$)) no))) + (when (and (or ;; (null yes) + (find-if (lambda (s) (search s tk$)) yes)) + #+hunh? (not (find-if (lambda (s) (search s tk$)) no))) (format t "~&tk> ~a~%" tk$))) (assert *tki*)
--- /project/cells/cvsroot/Celtk/composites.lisp 2006/11/04 20:53:08 1.20 +++ /project/cells/cvsroot/Celtk/composites.lisp 2006/11/13 05:28:52 1.21 @@ -97,7 +97,7 @@ (defun app-idle (self) (setf (^app-time) (get-internal-real-time)))
-(defmd window (composite-widget decoration-mixin) +(defmd window (toplevel composite-widget decoration-mixin) (title$ (c? (string-capitalize (class-name (class-of self))))) (dictionary (make-hash-table :test 'equalp)) (tkwins (make-hash-table)) @@ -109,12 +109,19 @@ tkfonts-to-load tkfont-sizes-to-load (tkfont-info (tkfont-info-loader)) + start-up-fn + close-fn initial-focus + (focus-state (c-in nil) :documentation "This is about the window having the focus on the desktop, not the key focus. +Actually holds last event code, :focusin or :focusout") on-key-down - on-key-up) + on-key-up + :width (c?n 800) + :height (c?n 600))
-(export! .control-key-p) +(export! .control-key-p .alt-key-p focus-state ^focus-state) (define-symbol-macro .control-key-p (find :control (keyboard-modifiers .tkw))) +(define-symbol-macro .alt-key-p (find :alt (keyboard-modifiers .tkw)))
(defmethod make-tk-instance ((self window)) (setf (gethash (^path) (dictionary .tkw)) self)) --- /project/cells/cvsroot/Celtk/lotsa-widgets.lisp 2006/11/04 20:53:08 1.7 +++ /project/cells/cvsroot/Celtk/lotsa-widgets.lisp 2006/11/13 05:28:52 1.8 @@ -83,10 +83,10 @@
(defun style-by-edit-menu () - (mk-row ("Style by Edit Menu") - (mk-label :text "Four score and seven years ago today" - :wraplength 600 - :tkfont (c? (list + (mk-row ("Style by Edit Menu") + (mk-label :text "Four score and seven years ago today" + :wraplength 600 + :tkfont (c? (list (selection (fm^ :app-font-face)) (selection (fm^ :app-font-size)) (if (fm^v :app-font-italic) --- /project/cells/cvsroot/Celtk/menu.lisp 2006/11/04 20:53:08 1.18 +++ /project/cells/cvsroot/Celtk/menu.lisp 2006/11/13 05:28:52 1.19 @@ -213,7 +213,7 @@ :tk-variable (c? (down$ (path (upper self selector)))) :on-command (lambda (self) (declare (ignore key args)) - (trc nil "menu radio button command firing" self (^value) (upper self selector)) + (trc "menu radio button command firing" self (^value) (upper self selector)) (setf (selection (upper self selector)) (^value)))))
(defmodel menu-radio-group (selector family) --- /project/cells/cvsroot/Celtk/run.lisp 2006/10/28 18:21:52 1.22 +++ /project/cells/cvsroot/Celtk/run.lisp 2006/11/13 05:28:52 1.23 @@ -25,6 +25,8 @@ (eval-now! (export '(tk-scaling run-window test-window)))
+ + (defun run-window (root-class &optional (resetp t) &rest window-initargs) (declare (ignorable root-class)) (setf *tkw* nil) @@ -37,7 +39,16 @@ (tk-app-init *tki*) (tk-togl-init *tki*) (tk-format-now "proc TraceOP {n1 n2 op} {event generate $n1 <<trace>> -data $op}") - + (tk-format-now "package require snack") + (tk-format-now "snack::sound s") +;;; (tk-format-now (conc$ "snack::sound s -load " +;;; (snackify-pathname (make-pathname :directory '(:absolute "sounds") +;;; :name "ahem_x" :type "wav") +;;; #+vs (car (directory (make-pathname :directory '(:absolute "sounds"))))))) +;;; (tk-format-now "s play -blocking yes") +;;; (sleep 2) +;;; (tk-format-now "s play") + (tcl-create-command *tki* "do-on-command" (get-callback 'do-on-command) (null-pointer) (null-pointer))
;; these next exist because of limitations in the Tcl API. eg, the keypress event does not @@ -65,8 +76,10 @@ ; (tk-format-now "bind . <KeyPress> {do-key-down %W %K}") (tk-format-now "bind . <KeyRelease> {do-key-up %W %K}") - - (tcl-do-one-event-loop)) + (bwhen (ifn (start-up-fn *tkw*)) + (funcall ifn *tkw*)) + (tcl-do-one-event-loop) + )
@@ -93,15 +106,27 @@
(defmethod widget-event-handle ((self window) xe) (let ((*tkw* self)) - (TRC nil "main window event" self *tkw* (xevent-type xe)) + (unless (find (xevent-type xe) '(:MotionNotify)) + (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) + ((:focusin :focusout) (setf (^focus-state) (xevent-type xe))) ((:MotionNotify :buttonpress) #+shhh (call-dump-event client-data xe))
+ (:configurenotify + (setf (^width) (ekx new-width!!! parse-integer (tk-eval "winfo width ."))) + (with-cc :height + (setf (^height) (parse-integer (tk-eval "winfo height .")))) + ) + + (:visibilitynotify + (mathx::a1-snack-off :startup "" 0.8)) (:destroyNotify + (mathx::a1-snack-off :quit "-blocking yes" 0.5) + (let ((*windows-destroyed* (cons *tkw* *windows-destroyed*))) (ensure-destruction *tkw*)))
-
ktilton