[cells-cvs] CVS Celtk
ktilton
ktilton at common-lisp.net
Mon Nov 13 05:28:53 UTC 2006
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*)))
More information about the Cells-cvs
mailing list