Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv8641
Modified Files: Celtk.lisp canvas.lisp composites.lisp demos.lisp entry.lisp fileevent.lisp run.lisp tk-events.lisp tk-interp.lisp tk-object.lisp tk-structs.lisp togl.lisp widget.lisp Log Message:
--- /project/cells/cvsroot/Celtk/Celtk.lisp 2006/05/28 23:47:24 1.28 +++ /project/cells/cvsroot/Celtk/Celtk.lisp 2006/06/03 12:04:37 1.29 @@ -16,7 +16,7 @@
|#
-;;; $Header: /project/cells/cvsroot/Celtk/Celtk.lisp,v 1.28 2006/05/28 23:47:24 fgoenninger Exp $ +;;; $Header: /project/cells/cvsroot/Celtk/Celtk.lisp,v 1.29 2006/06/03 12:04:37 ktilton Exp $
(defpackage :celtk (:nicknames "CTK") @@ -125,8 +125,6 @@ "]" "\]") """ "\""))
-(tkescape "[exit]") - (defun tk-format-now (fmt$ &rest fmt-args) (unless (find *tkw* *windows-destroyed*) (let* ((*print-circle* nil) @@ -134,14 +132,15 @@ ; ; --- debug stuff --------------------------------- ; -;; (let ((yes '( "insert" "end")) -;; (no '())) -;; (declare (ignorable yes no)) -;; (when (and (find-if (lambda (s) (search s tk$)) yes) -;; (not (find-if (lambda (s) (search s tk$)) no))) -;; (format t "~&tk> ~a~%" tk$)) -;; (break)) -;; (assert *tki*) + + (let ((yes '( "photo")) + (no '())) + (declare (ignorable yes no)) + (when (and (find-if (lambda (s) (search s tk$)) yes) + (not (find-if (lambda (s) (search s tk$)) no))) + (format t "~&tk> ~a~%" tk$))) + (assert *tki*) + ; --- end debug stuff ------------------------------ ; ; --- serious stuff --- --- /project/cells/cvsroot/Celtk/canvas.lisp 2006/05/24 20:38:54 1.7 +++ /project/cells/cvsroot/Celtk/canvas.lisp 2006/06/03 12:04:37 1.8 @@ -32,11 +32,7 @@ (:default-initargs :xscrollcommand (c-in nil) :yscrollcommand (c-in nil) - :id (gentemp "CV") -;;; :virtual-event-handlers (c? (list -;;; (focusIn->active) -;;; (focusOut->active))) - )) + :id (gentemp "CV")))
(defun focusIn->active () (list '|<FocusIn>| (lambda (self event &rest args) --- /project/cells/cvsroot/Celtk/composites.lisp 2006/05/24 20:38:54 1.9 +++ /project/cells/cvsroot/Celtk/composites.lisp 2006/06/03 12:04:37 1.10 @@ -72,17 +72,25 @@ (eval-when (compile load eval) (export '(title$ active)))
+(defvar *app*) + +(defmodel application (family) + ((app-time :initform (c-in (get-internal-real-time)) + :initarg :app-time + :accessor app-time))) + +(defmethod path ((self application)) nil) + +(defun app-idle (self) + (setf (^app-time) (now))) + (defmodel window (composite-widget) - (#+wishful (wish :initarg :wish :accessor wish - :initform (wish-stream *wish*) - #+(or) (c? (do-execute "wish85 -name testwindow" - nil #+not (list (format nil "-name ~s" (title$ self)))))) - #+wishful (ewish :initarg :ewish :accessor ewish :initform nil :cell nil) ;; vestigial? - (title$ :initarg :title$ :accessor title$ + ((title$ :initarg :title$ :accessor title$ :initform (c? (string-capitalize (class-name (class-of self))))) (dictionary :initarg :dictionary :initform (make-hash-table :test 'equalp) :accessor dictionary) (tkwins :initform (make-hash-table) :reader tkwins) (xwins :initform (make-hash-table) :reader xwins) + (keyboard-modifiers :initarg :keyboard-modifiers :initform (c-in nil) :accessor keyboard-modifiers) (callbacks :initarg :callbacks :accessor callbacks :initform (make-hash-table :test #'eq)) (edit-style :initarg :edit-style :accessor edit-style :initform (c-in nil)) @@ -92,8 +100,7 @@ (tkfont-sizes-to-load :initarg :tkfont-sizes-to-load :accessor tkfont-sizes-to-load :initform nil) (tkfont-info :initarg :tkfont-info :accessor tkfont-info :initform (tkfont-info-loader)) - (initial-focus :initarg :initial-focus :accessor initial-focus :initform nil)) - ) + (initial-focus :initarg :initial-focus :accessor initial-focus :initform nil)))
(defobserver initial-focus () (when new-value --- /project/cells/cvsroot/Celtk/demos.lisp 2006/05/28 15:34:27 1.20 +++ /project/cells/cvsroot/Celtk/demos.lisp 2006/06/03 12:04:37 1.21 @@ -20,14 +20,23 @@
(defun ctk::tk-test () ;; ACL project manager needs a zero-argument function, in project package (test-window - 'one-button-window + ;;'place-test + ;;'one-button-window ;;'ltktest-cells-inside ;;'menu-button-test ;;'spinbox-test - ;;'lotsa-widgets + 'lotsa-widgets ;; Now in Gears project 'gears-demo ))
+(defmodel place-test (window) + () + (:default-initargs + :kids (c? (the-kids + (mk-label :text "hi, Mom" + :x 100 + :y 20))))) + (defmodel one-button-window (window) () (:default-initargs --- /project/cells/cvsroot/Celtk/entry.lisp 2006/05/31 05:08:25 1.13 +++ /project/cells/cvsroot/Celtk/entry.lisp 2006/06/03 12:04:37 1.14 @@ -16,7 +16,7 @@
|#
-;;; $Header: /project/cells/cvsroot/Celtk/entry.lisp,v 1.13 2006/05/31 05:08:25 fgoenninger Exp $ +;;; $Header: /project/cells/cvsroot/Celtk/entry.lisp,v 1.14 2006/06/03 12:04:37 ktilton Exp $
(in-package :Celtk)
@@ -108,28 +108,8 @@ (with-integrity (:client `(:variable ,self)) (tk-format-now "~a delete 1.0 end" (^path)) (when (plusp (length new-value)) - (trc "*** md-value text widget: new-value" new-value) (tk-format-now "~a insert end {~a}" (^path) new-value)) ;; kt060528: simple {} seems to block evaluation ;; Yes, it does. But we had to change ~s to ~a also in order to prevent ;; side effects - frgo 2006-05-29 1:30 am ;-) (tk-format-now "update idletasks"))) ;; Causes a display update after each text widget operation.
-;; The beginnings of a new text widget api: -;; (defmethod insert ((self text-widget) &rest args) -;; (tk-format-now )) - -;;;(defvar +tk-keysym-table+ -;;; (let ((ht (make-hash-table :test 'string=))) -;;; (with-open-file (ksyms "/0dev/math-paper/tk-keysym.dat" :direction :input) -;;; (loop for ksym-def = (read-line ksyms nil nil) -;;; for end = (position #\space ksym-def) -;;; while end -;;; do (let ((ksym (subseq ksym-def 0 end))) -;;; (setf (gethash ksym ht) (read-from-string ksym-def nil nil :start (1+ end)))) -;;; finally (return ht))))) - - (defun tk-translate-keysym (keysym$) - (if (= 1 (length keysym$)) - (schar keysym$ 0) - (intern (string-upcase keysym$)) - #+nah (gethash keysym$ +tk-keysym-table+))) \ No newline at end of file --- /project/cells/cvsroot/Celtk/fileevent.lisp 2006/05/31 05:09:14 1.6 +++ /project/cells/cvsroot/Celtk/fileevent.lisp 2006/06/03 12:04:37 1.7 @@ -21,7 +21,7 @@ ;;; DEALINGS IN THE SOFTWARE. ;;; ;;; --------------------------------------------------------------------------- -;;; $Header: /project/cells/cvsroot/Celtk/fileevent.lisp,v 1.6 2006/05/31 05:09:14 fgoenninger Exp $ +;;; $Header: /project/cells/cvsroot/Celtk/fileevent.lisp,v 1.7 2006/06/03 12:04:37 ktilton Exp $ ;;; ---------------------------------------------------------------------------
;;; =========================================================================== @@ -157,32 +157,24 @@ ;;; update operation.
(defun file-event-opcode-cell-rule () - (c? ;; Set the opcode depending on values of input-fd, output-fd, iostream, - ;; readable-cb, writeable-cb - - (if (and (not (^input-fd)) - (not (^output-fd)) - (not .cache)) - :nop + "Set the opcode depending on values of input-fd, output-fd, iostream, readable-cb, writeable-cb" + (c? (cond + ((not (or (^input-fd) (^output-fd) .cache)) + :nop)
- (if (and (^input-fd) - (^iostream) - (^readable-cb)) - :update-input-tk-fileevent + ((and (^input-fd) (^iostream) (^readable-cb)) + :update-input-tk-fileevent) - (if (and (^output-fd) - (^iostream) - (^writeable-cb)) - :update-output-tk-fileevent - - (if (and (not (^iostream)) - (not (^input-fd))) - :reset-input-tk-fileevent + ((and (^output-fd) (^iostream) (^writeable-cb)) + :update-output-tk-fileevent) + + ((not (or (^iostream) (^input-fd))) + :reset-input-tk-fileevent) - (if (and (not (^iostream)) - (not (^output-fd))) - :reset-output-tk-fileevent - :nop))))))) + ((not (or (^iostream) (^output-fd))) + :reset-output-tk-fileevent) + + (t :nop))))
;;; =========================================================================== ;;; INIT-TK-FILEEVENT - CALLED UPON INITIALIZATION @@ -347,7 +339,7 @@
(defobserver readable-cb ((self tk-fileevent)) (if new-value - (Tcl_CreateCommand *tki* + (tcl-create-command *tki* "readable-cb" new-value (null-pointer) @@ -355,7 +347,7 @@
(defobserver writeable-cb ((self tk-fileevent)) (if new-value - (Tcl_CreateCommand *tki* + (tcl-create-command *tki* "writeable-cb" new-value (null-pointer) @@ -363,7 +355,7 @@
(defobserver eof-cb ((self tk-fileevent)) (if new-value - (Tcl_CreateCommand *tki* + (tcl-create-command *tki* "eof-cb" new-value (null-pointer) --- /project/cells/cvsroot/Celtk/run.lisp 2006/05/26 17:50:36 1.14 +++ /project/cells/cvsroot/Celtk/run.lisp 2006/06/03 12:04:37 1.15 @@ -18,7 +18,7 @@
(in-package :Celtk)
-;;; --- running a Celtk application (window class, actually) -------------------------------------- +;;; --- running a Celtk (window class, actually) --------------------------------------
(eval-when (compile load eval) (export '(tk-scaling run-window test-window))) @@ -35,15 +35,24 @@ (tk-togl-init *tki*) (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)) - - (with-integrity () - (setf *tkw* (make-instance root-class)) + (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)) + + (with-integrity () ;; w/i somehow ensures tkwin slot gets populated + (setf *app* + (make-instance 'application + :kids (c? (the-kids + (setf *tkw* (make-instance root-class + :fm-parent *parent*))))))) + + (assert (tkwin *tkw*))
- (tk-create-event-handler-ex *tkw* 'main-window-proc -1 :structureNotifyMask :virtualEventMask)) + (tk-create-event-handler-ex *tkw* 'main-window-proc -1)
(tk-format `(:fini) "wm deiconify .") (tk-format-now "bind . <Escape> {destroy .}") - + (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))
(defun ensure-destruction (w) @@ -53,32 +62,58 @@ (let ((*windows-being-destroyed* (cons w *windows-being-destroyed*))) (not-to-be w))))
-(defcallback main-window-proc :void ((client-data :pointer)(xe :pointer)) - (declare (ignore client-data)) - (TRC nil "main window event" (xevent-type xe)) - (case (xevent-type 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$)) - - (close-window - (ensure-destruction *tkw*)) - - (window-destroyed - (ensure-destruction *tkw*)) - - (time-is-up - (let ((self (gethash (tcl-get-string (xsv user-data xe)) (dictionary *tkw*)))) - (bwhen (c (^on-command)) - (funcall c self)))) +(defparameter *keyboard-modifiers* + (loop with km = (make-hash-table :test 'equalp) + for (keysym mod) in '(("Shift_L" :shift) + ("Shift_R" :shift) + ("Alt_L" :alt) + ("Alt_R" :alt) + ("Control_L" :control) + ("Control_R" :control)) + do (setf (gethash keysym km) mod) + finally (return km)))
- (otherwise (trc "main window sees unknown" n$)))))) - 0) +(defun keysym-to-modifier (keysym) + (gethash keysym *keyboard-modifiers*)) + +(defcallback main-window-proc :void ((client-data :pointer)(xe :pointer)) + (let ((*tkw* (tkwin-widget client-data))) + (assert (typep *tkw* 'window)) + (TRC nil "main window event" (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 (let ((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)))) + (bIf (mod (keysym-to-modifier keysym)) + (eko ("modifiers now") + (setf (keyboard-modifiers *tkw*) + (delete mod (keyboard-modifiers *tkw*)))) + (trc "unhandled released keysym" keysym)))) + (close-window + (ensure-destruction *tkw*)) + + (window-destroyed + (ensure-destruction *tkw*)) + + (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 @@ -86,16 +121,17 @@ (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 (progn (trc nil "checking num main windows") - (plusp (tk-get-num-main-windows))) - do (trc nil "calling Tcl_DoOneEvent" (tk-get-num-main-windows)) - (loop until (zerop (Tcl_DoOneEvent 2))) ;; 2== TCL_DONT_WAIT - (trc nil "sleeping") + (loop while (plusp (tk-get-num-main-windows)) + do (loop until (zerop (Tcl_DoOneEvent 2)) + do (app-idle *app*)) ;; 2== TCL_DONT_WAIT + (app-idle *app*) (sleep *event-loop-delay*) ;; give the IDE a few cycles finally (trc nil "Tcl-do-one-event-loop sees no more windows" *tki*) (tcl-delete-interp *tki*) ;; probably unnecessary - (setf *tki* nil))) + (setf *app* nil *tkw* nil *tki* nil))) + +(defmethod window-idle ((self window)))
(defun test-window (root-class) "nails existing window as a convenience in iterative development" @@ -109,3 +145,47 @@ (setf *tkw* nil))
(run-window root-class)) + +;;; --- 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) + (bIf (cmd (,^on-name)) + (apply cmd self args) + (format t "~&Warning: Target widget ~a has no ~a to run" self ',do-on-name)) + 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*))) + (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) +(defcommand key-up) +(defcommand key-down) + +;;;(defcallback do-on-command :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*))) +;;; (apply 'do-on-command self (rest args)) +;;; (progn +;;; (break "do-on-command> Target widget ~a does not exist" path) +;;; #+anyvalue? (tcl-set-result interp +;;; (format nil "do-on-command> Target widget ~a does not exist" path) +;;; (null-pointer)) +;;; 1))))) \ No newline at end of file --- /project/cells/cvsroot/Celtk/tk-events.lisp 2006/05/24 20:38:54 1.4 +++ /project/cells/cvsroot/Celtk/tk-events.lisp 2006/06/03 12:04:37 1.5 @@ -27,13 +27,6 @@ (tcl-idle-proc :pointer) (client-data :pointer))
-(defcfun ("Tcl_CreateCommand" tcl-create-command) :pointer - (interp :pointer) - (cmdName :string) - (proc :pointer) - (client-data :pointer) - (delete-proc :pointer)) - (defcfun ("Tcl_SetResult" tcl-set-result) :void (interp :pointer) (result :string) @@ -133,8 +126,6 @@ (ignore-errors (foreign-enum-keyword 'tk-event-type n)))
- - (defun tk-event-mask-symbol (n) ;; do not try to generate masks from these! (ignore-errors (foreign-enum-keyword 'tk-event-mask n))) @@ -160,6 +151,8 @@
(trc "tkep> " (tk-event-type (mem-aref xe :int)) :client-data client-data) (case (tk-event-type (mem-aref xe :int)) + (:motionnotify + (trc nil "motionnotify" (xsv x xe) :y (xsv y xe) :x-root (xsv x-root xe) :y-root (xsv y-root xe))) (:virtualevent (trc " > :type" (format nil "<<~a>>" (xsv name xe)) :time (xsv time xe) :state (xsv state xe)) (trc " > :x" (xsv x xe) :y (xsv y xe) :x-root (xsv x-root xe) :y-root (xsv y-root xe)) @@ -171,4 +164,21 @@ (trc " > data" (unless (null-pointer-p (xsv user-data xe)) (tcl-get-string (xsv user-data xe)))))))
+(defun xevent-dump (xe) + (case (tk-event-type (mem-aref xe :int)) + (:motionnotify + (trc nil "motionnotify" (xsv x xe) :y (xsv y xe) :x-root (xsv x-root xe) :y-root (xsv y-root xe))) + (:virtualevent + (trc " > :type" (format nil "<<~a>>" (xsv name xe)) :time (xsv time xe) :state (xsv state xe)) + (trc " > :x" (xsv x xe) :y (xsv y xe) :x-root (xsv x-root xe) :y-root (xsv y-root xe)) + (trc " > event/root/sub" (mapcar (lambda (w) (when w (path w))) + (list (xwin-widget (xsv event-window xe)) + (xwin-widget (xsv root-window xe)) + (xwin-widget (xsv sub-window xe))))) + + (trc " > data" (unless (null-pointer-p (xsv user-data xe)) + (tcl-get-string (xsv user-data xe))))) + (otherwise + (trc "tkep> " (tk-event-type (mem-aref xe :int)))))) +
--- /project/cells/cvsroot/Celtk/tk-interp.lisp 2006/05/31 05:10:30 1.13 +++ /project/cells/cvsroot/Celtk/tk-interp.lisp 2006/06/03 12:04:37 1.14 @@ -136,12 +136,12 @@ ;; Tcl_CreateCommand - used to implement direct callbacks ;; ----------------------------------------------------------------------------
-(defcfun ("Tcl_CreateCommand" Tcl_CreateCommand) :pointer +(defcfun ("Tcl_CreateCommand" tcl-create-command) :pointer (interp :pointer) (cmdName :string) - (cmdProc :pointer) - (clientData :int) - (deleteProc :pointer)) + (proc :pointer) + (client-data :pointer) + (delete-proc :pointer))
;; ---------------------------------------------------------------------------- ;; Tcl/Tk channel related stuff --- /project/cells/cvsroot/Celtk/tk-object.lisp 2006/05/24 20:38:54 1.4 +++ /project/cells/cvsroot/Celtk/tk-object.lisp 2006/06/03 12:04:37 1.5 @@ -27,6 +27,8 @@
(timers :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) + (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"))
--- /project/cells/cvsroot/Celtk/tk-structs.lisp 2006/05/31 05:11:28 1.4 +++ /project/cells/cvsroot/Celtk/tk-structs.lisp 2006/06/03 12:04:37 1.5 @@ -98,7 +98,7 @@ |#
(defcstruct x-virtual-event - "Virtual event, OK?" + "common event fields" (type :int) (serial :unsigned-long) (send-event :boolean) @@ -120,9 +120,48 @@ (defmacro xsv (slot-name xptr) `(foreign-slot-value ,xptr 'X-Virtual-Event ',slot-name))
+(defmacro xke (slot-name xptr) + `(foreign-slot-value ,xptr 'x-key-event ',slot-name)) + (defun xevent-type (xe) (tk-event-type (xsv type xe)))
+;; ------------------------------------------- + +(defcstruct x-key-event + "X key Event" + (xke-header x-virtual-event) + (trans-char-0 :char) + (trans-char-1 :char) + (trans-char-2 :char) + (trans-char-3 :char)) + +(defcstruct x-button-event + "common event fields" + (type :int) + (serial :unsigned-long) + (send-event :boolean) + (display :pointer) + (event-window Window) + (root-window Window) + (sub-window Window) + (time Time) + (x :int) + (y :int) + (x-root :int) + (y-root :int) + (state :unsigned-int) + (button :unsigned-int) + (same-screen :boolean)) + +(defmacro xbe (slot-name xptr) + `(foreign-slot-value ,xptr 'x-button-event ',slot-name)) + +(defun xbe-x (xbe) (xbe x xbe)) +(defun xbe-y (xbe) (xbe y xbe)) + +;; -------------------------------------------- + (defcenum tcl-event-flag-values (:tcl-dont-wait 2) (:tcl-window-events 4) --- /project/cells/cvsroot/Celtk/togl.lisp 2006/05/27 06:04:22 1.8 +++ /project/cells/cvsroot/Celtk/togl.lisp 2006/06/03 12:04:37 1.9 @@ -28,40 +28,25 @@
;;; --- Togl (Version 1.7 and above needed!) -----------------------------
-(defcfun ("Togl_Init" Togl_Init) tcl-retcode +(defcfun ("Togl_Init" Togl-Init) tcl-retcode (interp :pointer))
-(defcfun ("Togl_CreateFunc" Togl_CreateFunc) :void - (togl-callback-ptr :pointer)) - -(defcfun ("Togl_DisplayFunc" Togl_DisplayFunc) :void - (togl-callback-ptr :pointer)) - -(defcfun ("Togl_ReshapeFunc" Togl_ReshapeFunc) :void - (togl-callback-ptr :pointer)) - -(defcfun ("Togl_DestroyFunc" Togl_DestroyFunc) :void - (togl-callback-ptr :pointer)) - -(defcfun ("Togl_TimerFunc" Togl_TimerFunc) :void - (togl-callback-ptr :pointer)) - -(defcfun ("Togl_PostRedisplay" Togl_PostRedisplay) :void +(defcfun ("Togl_PostRedisplay" togl-post-redisplay) :void (togl-struct-ptr :pointer))
-(defcfun ("Togl_SwapBuffers" Togl_SwapBuffers) :void +(defcfun ("Togl_SwapBuffers" togl-swap-buffers) :void (togl-struct-ptr :pointer))
(defcfun ("Togl_Ident" Togl-Ident) :string (togl-struct-ptr :pointer))
-(defcfun ("Togl_Width" Togl_Width) :int +(defcfun ("Togl_Width" Togl-Width) :int (togl-struct-ptr :pointer))
-(defcfun ("Togl_Height" Togl_Height) :int +(defcfun ("Togl_Height" Togl-Height) :int (togl-struct-ptr :pointer))
-(defcfun ("Togl_Interp" Togl_Interp) :pointer +(defcfun ("Togl_Interp" Togl-Interp) :pointer (togl-struct-ptr :pointer))
;; Togl_AllocColor @@ -86,9 +71,9 @@ ;; Togl_DumpToEpsFile
(eval-when (compile load eval) - (export '(togl_swapbuffers togl_postredisplay togl-ptr togl-reshape-func - togl togl-timer-using-class Togl_PostRedisplay togl-reshape-using-class - togl-display-using-class togl_width togl_height togl-create-using-class))) + (export '(togl-swap-buffers togl-post-redisplay togl-ptr togl-reshape-func + togl togl-timer-using-class togl-post-redisplay togl-reshape-using-class + togl-display-using-class togl-width togl-height togl-create-using-class)))
;; --- gotta call this bad boy during initialization, I guess any time after we have an interpreter ;; @@ -96,7 +81,7 @@ (defun tk-togl-init (interp) ;(assert (not (zerop (tcl-init-stubs interp "8.1" 0)))) ;(assert (not (zerop (tk-init-stubs interp "8.1" 0)))) - (togl_init interp) + (togl-init interp) (togl-create-func (callback togl-create)) (togl-destroy-func (callback togl-destroy)) (togl-display-func (callback togl-display)) @@ -115,15 +100,15 @@ -width ;; 400 Width of widget in pixels. -height ;; 400 Height of widget in pixels. -ident ;; "" A user identification string ignored by togl. - ;; This can be useful in your C callback functions - ;; to determine which Togl widget is the caller. + ;; This can be useful in your C callback functions + ;; to determine which Togl widget is the caller. -rgba ;; true If true, use RGB(A) mode - ;; If false, use Color Index mode + ;; If false, use Color Index mode -redsize ;; 1 Min bits per red component -greensize ;; 1 Min bits per green component -bluesize ;; 1 Min bits per blue component -double ;; false If false, request a single buffered window - ;; If true, request double buffered window + ;; If true, request double buffered window -depth ;; false If true, request a depth buffer -depthsize ;; 1 Min bits of depth buffer -accum ;; false If true, request an accumulation buffer @@ -132,33 +117,35 @@ -accumbluesize ;; 1 Min bits per accum blue component -accumalphasize ;; 1 Min bits per accum alpha component -alpha ;; false If true and -rgba is true, request an alpha - ;; channel + ;; channel -alphasize ;; 1 Min bits per alpha component -stencil ;; false If true, request a stencil buffer -stencilsize ;; 1 Min number of stencil bits -auxbuffers ;; 0 Desired number of auxiliary buffers -privatecmap ;; false Only applicable in color index mode. - ;; If false, use a shared read-only colormap. - ;; If true, use a private read/write colormap. + ;; If false, use a shared read-only colormap. + ;; If true, use a private read/write colormap. -overlay ;; false If true, request overlay planes. -stereo ;; false If true, request a stereo-capable window. (-timer-interval -time) ;; 1 Specifies the interval, in milliseconds, for - ; calling the C timer callback function which - ; was registered with Togl_TimerFunc. + ; calling the C timer callback function which + ; was registered with Togl_TimerFunc. -sharelist ;; "" Name of an existing Togl widget with which to - ; share display lists. - ; NOT YET IMPLEMENTED FOR WINDOWS 95/NT. + ; share display lists. + ; NOT YET IMPLEMENTED FOR WINDOWS 95/NT. -sharecontext ;; "" Name of an existing Togl widget with which to - ; share the OpenGL context. NOTE: most other - ; attributes such as double buffering, RGBA vs CI, - ; ancillary buffer specs, etc are then ignored. - ; NOT YET IMPLEMENTED FOR WINDOWS 95/NT. + ; share the OpenGL context. NOTE: most other + ; attributes such as double buffering, RGBA vs CI, + ; ancillary buffer specs, etc are then ignored. + ; NOT YET IMPLEMENTED FOR WINDOWS 95/NT. -indirect ;; false If present, request an indirect rendering context. - ; A direct rendering context is normally requested. - ; NOT SIGNIFICANT FOR WINDOWS 95/NT. + ; A direct rendering context is normally requested. + ; NOT SIGNIFICANT FOR WINDOWS 95/NT. ) (:default-initargs - :id (gentemp "TOGL") + :double t + :rgba t + :id (gentemp "TOGL") :ident (c? (^path))))
(defmacro def-togl-callback (root (&optional (ptr-var 'togl-ptr)(self-var 'self)) &body preamble) --- /project/cells/cvsroot/Celtk/widget.lisp 2006/05/26 18:02:02 1.11 +++ /project/cells/cvsroot/Celtk/widget.lisp 2006/06/03 12:04:37 1.12 @@ -55,25 +55,21 @@ (xwin :cell nil :accessor xwin :initform nil) (packing :reader packing :initarg :packing :initform nil) (gridding :reader gridding :initarg :gridding :initform nil) + (x :reader x :initarg :x :initform nil) + (y :reader y :initarg :y :initform nil) + (relx :reader relx :initarg :relx :initform nil) + (rely :reader rely :initarg :rely :initform nil) (enabled :reader enabled :initarg :enabled :initform t) (event-handler :reader event-handler :initarg :event-handler :initform nil) (menus :reader menus :initarg :menus :initform nil :documentation "An assoc of an arbitrary key and the associated CLOS menu instances (not their tk ids)") (image-files :reader image-files :initarg :image-files :initform nil) (selector :reader selector :initarg :selector - :initform (c? (upper self selector))) - (on-event :initform nil :initarg :on-event :accessor on-event)) + :initform (c? (upper self selector)))) (:default-initargs :id (gentemp "W") :event-handler nil #+debug (lambda (self xe) - (TRC "widget-event-handler" self (tk-event-type (xsv type xe)) ) - ))) - -(defobserver event-handler () - (when new-value ;; \\ work out how to unregister any old value - (with-integrity (:client `(:post-make-tk ,self)) - (trc nil "creating event handler for" self) - (tk-create-event-handler-ex self 'widget-event-handler -1)))) ;; // make this -1 more efficient + (TRC "widget-event-handler" self (tk-event-type (xsv type xe))))))
(defun tk-create-event-handler-ex (widget callback-name &rest masks) (let ((self-tkwin (widget-to-tkwin widget))) @@ -84,41 +80,6 @@ (get-callback callback-name) self-tkwin)))
-(defcallback widget-event-handler :void ((client-data :pointer)(xe :pointer)) - (let ((self (tkwin-widget client-data))) - (assert self () "widget-event-handler > no widget for tkwin ~a" client-data) - (bif (h (^event-handler)) - (funcall h self xe) - (trc "widget-event-handler > warning: no handler in instance requesting event handling" self)))) - -(defclass commander () - () - (:default-initargs - :command (c? (format nil "do-on-command ~a" (^path))))) - -(defcallback do-on-command :int ((client-data :pointer)(interp :pointer)(argc :int)(argv :pointer)) - (declare (ignore client-data)) - (destructuring-bind (path &rest args) - (loop for argn upfrom 1 below argc - collecting (mem-aref argv :string argn)) - (bif (self (gethash path (dictionary *tkw*))) - (bIf (cmd (^on-command)) - (progn (apply cmd self args) - 0) - (progn (tcl-set-result interp - (format nil "do-on-command> Target widget ~a has no on-command to run" path) - (null-pointer)) - 1)) - (progn - (loop for hk being the hash-keys of (dictionary *tkw*) - when (string-equal hk path) - do (trc "found string-equal match" path)) - (break "do-on-command> Target widget ~a does not exist" path) - (tcl-set-result interp - (format nil "do-on-command> Target widget ~a does not exist" path) - (null-pointer)) - 1)))) - (defun widget-menu (self key) (or (find key (^menus) :key 'md-name) (break "The only menus I see are~{ ~a,~} not requested ~a" (mapcar 'md-name (^menus)) key))) @@ -143,7 +104,36 @@
(defmethod make-tk-instance :after ((self widget)) (with-integrity (:client `(:post-make-tk ,self)) - (tkwin-register self))) + (tkwin-register self) + (tk-create-event-handler-ex self 'widget-event-handler-callback -1))) + +;;;(defobserver relx () +;;; (when new-value +;;; (tk-format `(:grid ,self) +;;; "place ~a ~a -relx ~a -rely ~a" (if old-value "configure" "") +;;; (^path) new-value (^rely)))) + +(defobserver x ((self widget)) + (when new-value + (tk-format `(:grid ,self) + "place ~a ~a -x ~a -y ~a" (if old-value "configure" "") + (^path) new-value (^y)))) + +(defcallback widget-event-handler-callback :void ((client-data :pointer)(xe :pointer)) + (let ((self (tkwin-widget client-data))) + (assert self () "widget-event-handler > no widget for tkwin ~a" client-data) + (widget-event-handle self xe))) + +(defmethod widget-event-handle ((self widget) xe) + (bif (h (^event-handler)) + (funcall h self xe) + #+shhh (case (xevent-type xe) + (:buttonpress + (trc "button pressed:" (xbe button xe)(xbe x xe)(xbe y xe)(xbe x-root xe)(xbe y-root xe))) + + (:buttonrelease (trc "button released:" (xbe button xe)(xbe x xe)(xbe y xe)(xbe x-root xe)(xbe y-root xe)))(:MotionNotify + (xevent-dump xe)) + (:virtualevent))))
(defmethod tk-configure ((self widget) option value) (tk-format `(:configure ,self ,option) "~a configure ~(~a~) ~a" (path self) option (tk-send-value value))) @@ -154,6 +144,14 @@ (tk-format `(:forget ,self) "pack forget ~a" (^path)) (tk-format `(:destroy ,self) "destroy ~a" (^path))))
+;;; --- commander mix-in -------------------------------- + +(defclass commander () + () + (:default-initargs + :command (c? (format nil "do-on-command ~a" (^path))))) + + ;;; --- items -----------------------------------------------------------------------
(eval-when (compile load eval) @@ -254,15 +252,15 @@ (let ((v$ (if (stringp new-value) ;; just going slow on switching over to C API before changing tk-send-value new-value (tk-send-value new-value)))) - (tcl-set-var *tki* (tk-variable self) v$ (var-flags :TCL_NAMESPACE_ONLY)))))) + (tcl-set-var *tki* (tk-variable self) v$ (var-flags :tcl-namespace-only))))))
;;; --- images -------------------------------------------------------
(defobserver image-files () (loop for (name file-pathname) in (set-difference new-value old-value :key 'car) - do (tk-format `(:pre-make-tk ,self) "image create photo ~(~a.~a~) -file ~a" - (^path) name (tkescape (namestring file-pathname))))) + do (tk-format `(:pre-make-tk ,self) "image create photo ~(~a.~a~) -file {~a}" + (^path) name (progn #+not tkescape (namestring file-pathname)))))
;;; --- menus ---------------------------------
-
ktilton