From fgoenninger at common-lisp.net Fri Aug 14 15:53:59 2009 From: fgoenninger at common-lisp.net (fgoenninger) Date: Fri, 14 Aug 2009 11:53:59 -0400 Subject: [cells-cvs] CVS Celtk Message-ID: Update of /project/cells/cvsroot/Celtk In directory cl-net:/tmp/cvs-serv31315 Modified Files: tk-object.lisp Log Message: Changed: slot definition of hover-timer from :reader to :accessor. --- /project/cells/cvsroot/Celtk/tk-object.lisp 2009/07/12 11:36:15 1.18 +++ /project/cells/cvsroot/Celtk/tk-object.lisp 2009/08/14 15:53:59 1.19 @@ -24,7 +24,7 @@ (defmodel tk-object (model) ((.md-name :cell nil :initform (gentemp "TK") :initarg :id) (tk-class :cell nil :initform nil :initarg :tk-class :reader tk-class) - (hover-timer :cell nil :initform nil :initarg :hover-timer :reader hover-timer) + (hover-timer :cell nil :initform nil :initarg :hover-timer :accessor hover-timer) (timers :owning t :initarg :timers :accessor timers :initform nil) (on-command :initarg :on-command :accessor on-command :initform nil) (on-hover :initarg :on-hover :accessor on-hover :initform nil) From fgoenninger at common-lisp.net Fri Aug 14 16:00:38 2009 From: fgoenninger at common-lisp.net (fgoenninger) Date: Fri, 14 Aug 2009 12:00:38 -0400 Subject: [cells-cvs] CVS Celtk Message-ID: Update of /project/cells/cvsroot/Celtk In directory cl-net:/tmp/cvs-serv31837 Modified Files: togl.lisp Log Message: Changed: Mac OS X: Togl assumed to be installed in standard directory "/Library/Tcl/". --- /project/cells/cvsroot/Celtk/togl.lisp 2008/03/23 23:47:42 1.30 +++ /project/cells/cvsroot/Celtk/togl.lisp 2009/08/14 16:00:38 1.31 @@ -22,7 +22,7 @@ (define-foreign-library Togl (:darwin (:or "libTogl1.7.dylib" - "/opt/tcltk/togl/lib/Togl1.7/libtogl1.7.dylib")) + "/Library/Tcl/lib/Togl1.7/libTogl1.7.dylib")) (:windows (:or "togl17.dll")) (:unix "/usr/lib/Togl1.7/libTogl1.7.so")) @@ -206,7 +206,7 @@ (set (find-symbol "*FTGL-OGL*" "CL-FTGL") togl-ptr)) ;; help debug failure to use lazy cells/classes ;; to defer FTGL till Ogl ready (when (find-package "KT-OPENGL") - (funcall (symbol-function (find-symbol "KT-OPENGL-RESET" "CL-FTGL")))) + (funcall (symbol-function (find-symbol "KT-OPENGL-RESET" "KT-OPENGL")))) ;;; ^^^^^ above two needed only for cello ^^^^^^ ;;; From fgoenninger at common-lisp.net Fri Aug 14 16:05:20 2009 From: fgoenninger at common-lisp.net (fgoenninger) Date: Fri, 14 Aug 2009 12:05:20 -0400 Subject: [cells-cvs] CVS Celtk Message-ID: Update of /project/cells/cvsroot/Celtk In directory cl-net:/tmp/cvs-serv4382 Modified Files: Celtk.lisp Log Message: Changed: Added :grouped to the list of valid tk queue codes. Changed: More debug output for tk-format. --- /project/cells/cvsroot/Celtk/Celtk.lisp 2008/06/16 12:35:55 1.43 +++ /project/cells/cvsroot/Celtk/Celtk.lisp 2009/08/14 16:05:20 1.44 @@ -16,7 +16,7 @@ |# -;;; $Header: /project/cells/cvsroot/Celtk/Celtk.lisp,v 1.43 2008/06/16 12:35:55 ktilton Exp $ +;;; $Header: /project/cells/cvsroot/Celtk/Celtk.lisp,v 1.44 2009/08/14 16:05:20 fgoenninger Exp $ ;(pushnew :tile *features*) ;; frgo, 2007-09-21: Need to do this only when tile actually loaded @@ -75,7 +75,7 @@ (defparameter +tk-client-task-priority+ '(:delete :forget :destroy :pre-make-tk :make-tk :make-tk-menubutton :post-make-tk - :variable :bind :selection :trace :configure :grid :pack :fini)) + :variable :bind :selection :trace :configure :grid :pack :fini :grouped)) (defun tk-user-queue-sort (task1 task2) "Intended for use as user queue sorter, to make Tk happy by giving it stuff in the order it needs to work properly." @@ -136,11 +136,11 @@ (unless (find *tkw* *windows-destroyed*) (let* ((*print-circle* nil) (tk$ (apply 'format nil fmt$ fmt-args))) - (let ((yes ) ; '("menubar" "cd")) + (let ((yes '("key" "wm")) ; '("menubar" "cd")) (no '())) (declare (ignorable yes no)) (when (find-if (lambda (s) (search s tk$)) yes) - (format t "~&tk> ~a~%" tk$))) + (format t "~&tk-format-now> ~a~%" tk$))) (assert *tki*) (setf *tk-last* tk$) (tcl-eval-ex *tki* tk$)))) @@ -148,7 +148,7 @@ (defun tk-format (defer-info fmt$ &rest fmt-args) "Format then send to wish (via user queue)" (assert (or (eq defer-info :grouped) - (consp defer-info)) () "need defer-info to sort command ~a. Specify :grouped if caller is managing user-queue" + (consp defer-info)) () "Need defer-info to sort command ~a. Specify :grouped if caller is managing user-queue" (apply 'format nil fmt$ fmt-args)) (when (eq defer-info :grouped) From fgoenninger at common-lisp.net Fri Aug 14 16:07:56 2009 From: fgoenninger at common-lisp.net (fgoenninger) Date: Fri, 14 Aug 2009 12:07:56 -0400 Subject: [cells-cvs] CVS Celtk Message-ID: 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 , at 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 <> -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 . {destroy .}") - ; - ; see above for why we are converting key x-events to application key virtual events: - ; - (tk-format-now "bind . {do-key-down %W %K}") - (tk-format-now "bind . {do-key-up %W %K}") - (tk-format-now "bind . {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 <> -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 . {destroy .}") + ;; + ;; See above for why we are converting key x-events to application + ;; key virtual events: + + (tk-format-now "bind . {do-key-down %W %K}") + (tk-format-now "bind . {do-key-up %W %K}") + + (tk-format-now "bind . {do-double-click-1 %W %K; break}") + (tk-format-now "bind . {do-double-click-2 %W %K; break}") + (tk-format-now "bind . {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) -