[cells-cvs] CVS Celtk
ktilton
ktilton at common-lisp.net
Sat Jun 3 12:04:37 UTC 2006
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 ---------------------------------
More information about the Cells-cvs
mailing list