Update of /project/cells/cvsroot/Celtk In directory cl-net:/tmp/cvs-serv5539
Modified Files: run.lisp Log Message: Changed: Multiple changes, largely adding Lispworks support by ensuring that event loop / Tcl/Tk and Lispworks are running in same thread. Changed: Added support for on-command for mouse buttons 2 and 3.
--- /project/cells/cvsroot/Celtk/run.lisp 2008/06/16 12:35:56 1.30 +++ /project/cells/cvsroot/Celtk/run.lisp 2009/08/14 16:07:56 1.31 @@ -16,76 +16,254 @@
|#
-(in-package :Celtk) +;;; $Header: /project/cells/cvsroot/Celtk/run.lisp,v 1.31 2009/08/14 16:07:56 fgoenninger Exp $
+(in-package :Celtk)
-;;; --- running a Celtk (window class, actually) -------------------------------------- +;;; --- running a Celtk (window class, actually) ------------------------------
(eval-now! - (export '(tk-scaling run-window test-window *ctk-dbg*))) + (export '(tk-scaling + + run-window-using-context + mk-run-window-context + + run-window + test-window + + *ctk-dbg* + + defcommand + )))
(defparameter *ctk-dbg* nil)
+;;; --- commands -------------------------------------------------------------- + +(defmacro defcommand (name) + (let ((do-on-name (read-from-string (format nil "DO-ON-~a" name))) + (^on-name (read-from-string (format nil "^ON-~a" name)))) + + `(progn + + (defmethod ,do-on-name (self &rest args) + (bwhen (cmd (,^on-name)) + (apply cmd self args)) + 0) + + (defcallback ,do-on-name :int + ((client-data :pointer)(interp :pointer)(argc :int)(argv :pointer)) + (declare (ignore client-data)) + (let ((*tki* interp) + (args (loop for argn upfrom 1 below argc + collecting (mem-aref argv :string argn)))) + (bif (self (gethash (car args) (dictionary *tkw*))) + (progn + (trc "defcommand > " ',^on-name self (cdr args)) + (apply ',do-on-name self (rest args))) + (progn + (break ",do-on-name> Target widget ~a does not exist" (car args)) + #+anyvalue? (tcl-set-result interp + (format nil ",do-on-name> Target widget ~a does not exist" (car args)) + (null-pointer)) + 1))))))) + +(defcommand command) +; +; see notes elsewhere for why Tcl API deficiencies require augmented key handling via app virtual events +; +(defcommand key-down) +(defcommand key-up) +(defcommand double-click-1) +(defcommand double-click-2) +(defcommand double-click-3) + +;;; --- running a Celtk (window class, actually) ----------------------------- + +(defmd run-window-context () + root-class + resetp + window-initargs + tk-packages-to-load + + ;; Default initargs + + :resetp t + + ;; Specify here the Tcl/Tk packages to load after Tcl/Tk init. + ;; Format is: list of (package-name init-function) pairs. + :tk-packages-to-load (list + '("snack" nil) + '("tile" (lambda () + (ctk:tk-format-now "namespace import -force ttk::*"))) + '("QuickTimeTcl" nil) + '("snack" (lambda () + (ctk:tk-format-now "snack::sound s"))))) + +(defmacro mk-run-window-context (root-class &rest args) + `(make-instance 'run-window-context :root-class ,root-class ,@args)) + +(defparameter *rwc* nil "This is the single instance of run-window-context. Holds call parameters for run-window. Needed because run-window needs to be a function with no arguments on Lispworks.") + +(defun %do-run-window () + "Lowest level call to %run-window - implementation and platform specific + stuff should go into this function." + + ;;(%run-window) ;; frgo, 2007-09-28: + ;; DEBUG - call %run-window directly even on LW + + #+lispworks + (let* ((bindings (cons '(*tkw* . *tkw*) mp:*process-initial-bindings*)) ;; UGLY ... + (bindings (cons '(*tki* . *tki*) bindings)) ;; there has to be a + (bindings (cons '(*app* . *app*) bindings)) ;; better way ... + (bindings (cons '(*rwc* . *rwc*) bindings)) ;; frgo, 2007-09-26 + (mp:*process-initial-bindings* bindings)) + (%run-window)) + + #-lispwoks (%run-window) + ) + (defun run-window (root-class &optional (resetp t) &rest window-initargs) - (assert (symbolp root-class)) - (setf *tkw* nil) + (declare (ignorable root-class))
- (when resetp - (cells-reset 'tk-user-queue-handler)) - (tk-interp-init-ensure) - - (setf *tki* (Tcl_CreateInterp)) - ;(break "ok?") - ;(deep) - - ;; not recommended by Tcl doc (tcl-do-when-idle (get-callback 'tcl-idle-proc) 42) - (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 "package require tile") - #-unix - ;;(tk-format-now "package require QuickTimeTcl") - (tk-format-now "snack::sound s") - - (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 - ;; include enough info to extract the keysym directly, and the function to extract the - ;; keysym is not exposed. The keysym, btw, is the portable representation of key events. - - (tcl-create-command *tki* "do-key-down" (get-callback 'do-on-key-down) (null-pointer) (null-pointer)) - (tcl-create-command *tki* "do-key-up" (get-callback 'do-on-key-up) (null-pointer) (null-pointer)) - (tcl-create-command *tki* "do-double-click-1" (get-callback 'do-on-double-click-1) (null-pointer) (null-pointer)) - (trc "integ" cells::*within-integrity*) - - (with-integrity () ;; w/i somehow ensures tkwin slot gets populated - (setf *app* - (make-instance 'application - :kids (c? (the-kids - (setf *tkw* (apply 'make-instance root-class - :fm-parent *parent* - window-initargs))))))) - - (assert (tkwin *tkw*)) - - (tk-format `(:fini) "wm deiconify .") - #-its-alive! (tk-format-now "bind . <Escape> {destroy .}") - ; - ; see above for why we are converting key x-events to application key virtual events: - ; - (tk-format-now "bind . <KeyPress> {do-key-down %W %K}") - (tk-format-now "bind . <KeyRelease> {do-key-up %W %K}") - (tk-format-now "bind . <Double-ButtonPress-1> {do-double-click-1 %W %K; break}") + ;; Save call parameters into *rwc* context + (setq *rwc* (make-instance 'run-window-context + :root-class root-class + :resetp resetp + :window-initargs window-initargs)) + + ;; Call internal run-window funtion + (%do-run-window)) + +(defmethod run-window-using-context ((rwc run-window-context)) + (declare (ignorable root-class)) + + ;; Save call into *rwc* context + (let ((*rwc* rwc)) + + ;; Call internal run-window funtion + (%do-run-window))) + +(defun tk-package-require (tk-package) + (assert (stringp tk-package) () "Error: Parameter tk-package is not a string.") + (tk-format-now "package require ~a" tk-package)) + +(defun %run-window () + "This function is intented to be called by 'run-window. It relies on the call parameters to be stored in *rwc*."
- (block nil + (assert *rwc* () "Error: Global call context *rwc* for '%run-window is not initialized.") + + ;; Get call parameters from *rwc* + (let ((root-class (root-class *rwc*)) + (resetp (resetp *rwc*)) + (window-initargs (window-initargs *rwc*)) + (tk-packages-to-load (tk-packages-to-load *rwc*))) + + ;; Ensure clean start situation + + (setf *tkw* nil) + + (when resetp + (cells-reset 'tk-user-queue-handler)) + + (tk-interp-init-ensure) + + ;; Initialize Tcl/Tk + (setf *tki* (Tcl_CreateInterp)) + + (tk-app-init *tki*) ;; Inits Tk + (tk-togl-init *tki*) ;; Inits the Tcl/Tk OpenGL Widget TOGL + + (trc "Tcl/Tk and Togl initialized." *tki*) + + ;; Load Tcl/Tk packages (as they are defined in *rwc*.tk-packages-to-load) + + (dolist (pkg-load-info tk-packages-to-load) + (let ((tk-package (first pkg-load-info)) + (init-fn (second pkg-load-info))) + (when tk-package + (tk-package-require tk-package)) + (when (and init-fn (functionp init-fn)) + (trc "*** Calling Tcl/Tk package init function" init-fn) + (funcall init-fn)))) + + ;; Setup Tcl/Tk to be able to interact with Celtk + (tk-format-now + "proc TraceOP {n1 n2 op} {event generate $n1 <<trace>> -data $op}") + + (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 include enough info to extract the keysym + ;; directly, and the function to extract the keysym is not exposed. + ;; The keysym, btw, is the portable representation of key events. + + (tcl-create-command *tki* "do-key-down" + (get-callback 'do-on-key-down) + (null-pointer) (null-pointer)) + + (tcl-create-command *tki* "do-key-up" + (get-callback 'do-on-key-up) + (null-pointer) (null-pointer)) + + (tcl-create-command *tki* "do-double-click-1" + (get-callback 'do-on-double-click-1) + (null-pointer) (null-pointer)) + (tcl-create-command *tki* "do-double-click-2" + (get-callback 'do-on-double-click-2) + (null-pointer) (null-pointer)) + (tcl-create-command *tki* "do-double-click-3" + (get-callback 'do-on-double-click-3) + (null-pointer) (null-pointer)) + + (trc ";;; Celtk: Tcl/Tk setup done. Now about to create window.") + + ;; Create the application window + + (with-integrity () ;; w/i somehow ensures tkwin slot gets populated + (setf *app* + (make-instance 'application + :kids (c? (the-kids + (setf *tkw* (apply 'make-instance root-class + :fm-parent *parent* + window-initargs)))) + ))) + + (assert (tkwin *tkw*)) ;; really there ? + + (trc ";;; Celtk: Tcl/Tk window created.") + + ;; And ... show it! + (tk-format `(:fini) "wm deiconify .") + + ;; Default key bindings + + #-its-alive! (tk-format-now "bind . <Escape> {destroy .}") + ;; + ;; See above for why we are converting key x-events to application + ;; key virtual events: + + (tk-format-now "bind . <KeyPress> {do-key-down %W %K}") + (tk-format-now "bind . <KeyRelease> {do-key-up %W %K}") + + (tk-format-now "bind . <Double-ButtonPress-1> {do-double-click-1 %W %K; break}") + (tk-format-now "bind . <Double-ButtonPress-2> {do-double-click-2 %W %K; break}") + (tk-format-now "bind . <Double-ButtonPress-3> {do-double-click-1 %W %K; break}") + + ;; Call the window class's init function prior to enter event loop (bwhen (ifn (start-up-fn *tkw*)) (funcall ifn *tkw*)) - (CG:kill-splash-screen) - (unless #-rms-s3 nil #+rms-s3 (b-when bail$ (clo::rms-get :login "announce" ) - (not (eval (read-from-string bail$)))) - (tcl-do-one-event-loop)))) + + ;; Kenny Tilton specials on next 4 lines + #+cg (cg:kill-spash-screen) + (unless #-rms-s3 nil + #+rms-s3 (b-when bail$ (clo::rms-get :login "announce" ) + (not (eval (read-from-string bail$))))) + + ;; Finally enter event loop to process events + (tcl-do-one-event-loop)))
(defun ensure-destruction (w key) (declare (ignorable key)) @@ -113,9 +291,10 @@ (defmethod widget-event-handle ((self window) xe) (let ((*tkw* self)) (unless (find (xevent-type xe) '(:MotionNotify)) - #+xxx (TRC "main window event" self *tkw* (xevent-type xe))) + (TRC "main window event" self *tkw* (xevent-type xe))) (flet ((give-to-window () (bwhen (eh (event-handler *tkw*)) + (trc "giving to window: eh" eh) (funcall eh *tkw* xe)))) (case (xevent-type xe) ((:focusin :focusout) (setf (^focus-state) (xevent-type xe))) @@ -123,9 +302,13 @@ #+shhh (call-dump-event client-data xe))
(:configurenotify - (setf (^width) (parse-integer (tk-eval "winfo width ."))) - (with-cc :height - (setf (^height) (parse-integer (tk-eval "winfo height ."))))) + (let ((width (parse-integer (tk-eval "winfo width ."))) + (height (parse-integer (tk-eval "winfo height .")))) + (trc ":configure-notify >>> widht | height" width height) + ;; frgo (break "widget-event-handle/:configurenotify") + #+not (with-cc :configurenotify + (setf (^width) width) + (setf (^height) height))))
(:destroyNotify (pushnew *tkw* *windows-destroyed*) @@ -133,7 +316,7 @@
(:virtualevent (bwhen (n$ (xsv name xe)) - (trc nil "main-window-proc :" n$ (unless (null-pointer-p (xsv user-data xe)) + (trc "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 ;(break "this works??: going after keysym") @@ -197,38 +380,3 @@
(apply 'run-window root-class resetp window-initargs))
-;;; --- commands ----------------------------------------------------------------- - -(defmacro defcommand (name) - (let ((do-on-name (read-from-string (format nil "DO-ON-~a" name))) - (^on-name (read-from-string (format nil "^ON-~a" name)))) - `(progn - (defmethod ,do-on-name (self &rest args) - (bwhen (cmd (,^on-name)) - (apply cmd self args)) - 0) - - (defcallback ,do-on-name :int ((client-data :pointer)(interp :pointer)(argc :int)(argv :pointer)) - (declare (ignore client-data)) - (let ((*tki* interp) - (args (loop for argn upfrom 1 below argc - collecting (mem-aref argv :string argn)))) - (bif (self (gethash (car args) (dictionary *tkw*))) - (progn - (trc nil "defcommand > " ',^on-name self (cdr args)) - (apply ',do-on-name self (rest args))) - (progn - (break ",do-on-name> Target widget ~a does not exist" (car args)) - #+anyvalue? (tcl-set-result interp - (format nil ",do-on-name> Target widget ~a does not exist" (car args)) - (null-pointer)) - 1))))))) - -(defcommand command) -; -; see notes elsewhere for why Tcl API deficiencies require augmented key handling via app virtual events -; -(defcommand key-down) -(defcommand key-up) -(defcommand double-click-1) -