/[cells]/Celtk/tk-events.lisp
ViewVC logotype

Contents of /Celtk/tk-events.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.6 - (show annotations)
Mon Aug 21 04:30:23 2006 UTC (7 years, 7 months ago) by ktilton
Branch: MAIN
CVS Tags: HEAD
Changes since 1.5: +2 -0 lines
*** empty log message ***
1 ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
2 #|
3
4 Celtk -- Cells, Tcl, and Tk
5
6 Copyright (C) 2006 by Kenneth Tilton
7
8 This library is free software; you can redistribute it and/or
9 modify it under the terms of the Lisp Lesser GNU Public License
10 (http://opensource.franz.com/preamble.html), known as the LLGPL.
11
12 This library is distributed WITHOUT ANY WARRANTY; without even
13 the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
14
15 See the Lisp Lesser GNU Public License for more details.
16
17 |#
18
19
20 (in-package :celtk)
21
22
23 (defcfun ("Tcl_DoOneEvent" Tcl_DoOneEvent) :int
24 (flags :int))
25
26 (defcfun ("Tcl_DoWhenIdle" tcl-do-when-idle) :void
27 (tcl-idle-proc :pointer)
28 (client-data :pointer))
29
30 (defcfun ("Tcl_SetResult" tcl-set-result) :void
31 (interp :pointer)
32 (result :string)
33 (free-proc :pointer))
34
35 (defcfun ("Tcl_GetString" tcl-get-string) :string
36 (tcl-obj :pointer))
37
38 (defcallback tcl-idle-proc :void ((client-data :pointer))
39 (unless (c-stopped)
40 (print (list :idle-proc :client-data client-data))))
41
42 ;; Tk_MainLoop
43
44 (defcfun ("Tk_MainLoop" Tk_MainLoop) :void)
45
46 (defcfun ("Tk_CreateEventHandler" tk-create-event-handler) :void
47 (tkwin :pointer)
48 (mask :int)
49 (proc :pointer)
50 (client-data :pointer))
51
52 (defcenum tk-event-type ;; do not try to generate masks from these!
53 "Ok for interpreting type field in event, but not for (expt 2 etype) to get mask"
54 (:KeyPress 2)
55 :KeyRelease
56 :ButtonPress
57 :ButtonRelease
58 :MotionNotify
59 :EnterNotify
60 :LeaveNotify
61 :FocusIn
62 :FocusOut
63 :KeymapNotify
64 :Expose
65 :GraphicsExpose
66 :NoExpose
67 :VisibilityNotify
68 :CreateNotify
69 :DestroyNotify
70 :UnmapNotify
71 :MapNotify
72 :MapRequest
73 :ReparentNotify
74 :ConfigureNotify
75 :ConfigureRequest
76 :GravityNotify
77 :ResizeRequest
78 :CirculateNotify
79 :CirculateRequest
80 :PropertyNotify
81 :SelectionClear
82 :SelectionRequest
83 :SelectionNotify
84 :ColormapNotify
85 :ClientMessage
86 :MappingNotify
87 :virtualEvent
88 :ActivateNotify
89 :DeactivateNotify
90 :MouseWheelEvent)
91
92
93
94 (defcenum tk-event-mask
95 "Use to filter events when calling tk-create-event-handler"
96 :NoEventMask
97 (:KeyPressMask #.(ash 1 0))
98 (:KeyReleaseMask #.(ash 1 1))
99 (:ButtonPressMask #.(ash 1 2))
100 (:ButtonReleaseMask #.(ash 1 3))
101 (:EnterWindowMask #.(ash 1 4))
102 (:LeaveWindowMask #.(ash 1 5))
103 (:PointerMotionMask #.(ash 1 6))
104 (:PointerMotionHintMask #.(ash 1 7))
105 (:Button1MotionMask #.(ash 1 8))
106 (:Button2MotionMask #.(ash 1 9))
107 (:Button3MotionMask #.(ash 1 10))
108 (:Button4MotionMask #.(ash 1 11))
109 (:Button5MotionMask #.(ash 1 12))
110 (:ButtonMotionMask #.(ash 1 13))
111 (:KeymapStateMask #.(ash 1 14))
112 (:ExposureMask #.(ash 1 15))
113 (:VisibilityChangeMask #.(ash 1 16))
114 (:StructureNotifyMask #.(ash 1 17))
115 (:ResizeRedirectMask #.(ash 1 18))
116 (:SubstructureNotifyMask #.(ash 1 19))
117 (:SubstructureRedirectMask #.(ash 1 20))
118 (:FocusChangeMask #.(ash 1 21))
119 (:PropertyChangeMask #.(ash 1 22))
120 (:ColormapChangeMask #.(ash 1 23))
121 (:OwnerGrabButtonMask #.(ash 1 24))
122 (:MouseWheelMask #.(ash 1 28))
123 (:ActivateMask #.(ash 1 29))
124 (:VirtualEventMask #.(ash 1 30)))
125
126
127 (defun tk-event-type (n) ;; do not try to generate masks from these!
128 (ignore-errors
129 (foreign-enum-keyword 'tk-event-type n)))
130
131 (defun tk-event-mask-symbol (n) ;; do not try to generate masks from these!
132 (ignore-errors
133 (foreign-enum-keyword 'tk-event-mask n)))
134
135 (defun foreign-masks-combine (enum-type &rest mask-specs)
136 (reduce 'logior (loop for mask-spec in mask-specs
137 collecting (etypecase mask-spec
138 (number mask-spec)
139 (keyword (foreign-enum-value enum-type mask-spec))))
140 :initial-value 0))
141
142
143 ;; sample event handler
144
145 (defcallback dump-event :void ((client-data :pointer)(xe :pointer))
146 (call-dump-event client-data xe))
147
148 (defun call-dump-event (client-data xe)
149 ;;(trc "tkep> serial" (xsv serial xe))
150 #+shh (loop for win being the hash-keys of (tkwins *tkw*)
151 do (print `(win ,win :xwin ,(tkwin-window win) ,(tkwin-widget win) ,(path (tkwin-widget win)))))
152 ;;(trc " > same-screen" (xsv same-screen xe))
153
154 (trc "tkep> " (tk-event-type (mem-aref xe :int)) :client-data client-data)
155 (case (tk-event-type (mem-aref xe :int))
156 (:motionnotify
157 (trc nil "motionnotify" (xsv x xe) :y (xsv y xe) :x-root (xsv x-root xe) :y-root (xsv y-root xe)))
158 (:virtualevent
159 (trc " > :type" (format nil "<<~a>>" (xsv name xe)) :time (xsv time xe) :state (xsv state xe))
160 (trc " > :x" (xsv x xe) :y (xsv y xe) :x-root (xsv x-root xe) :y-root (xsv y-root xe))
161 (trc " > event/root/sub" (mapcar (lambda (w) (when w (path w)))
162 (list (xwin-widget (xsv event-window xe))
163 (xwin-widget (xsv root-window xe))
164 (xwin-widget (xsv sub-window xe)))))
165
166 (trc " > data" (unless (null-pointer-p (xsv user-data xe))
167 (tcl-get-string (xsv user-data xe)))))))
168
169 (defun xevent-dump (xe)
170 (case (tk-event-type (mem-aref xe :int))
171 (:motionnotify
172 (trc nil "motionnotify" (xsv x xe) :y (xsv y xe) :x-root (xsv x-root xe) :y-root (xsv y-root xe)))
173 (:virtualevent
174 (trc " > :type" (format nil "<<~a>>" (xsv name xe)) :time (xsv time xe) :state (xsv state xe))
175 (trc " > :x" (xsv x xe) :y (xsv y xe) :x-root (xsv x-root xe) :y-root (xsv y-root xe))
176 (trc " > event/root/sub" (mapcar (lambda (w) (when w (path w)))
177 (list (xwin-widget (xsv event-window xe))
178 (xwin-widget (xsv root-window xe))
179 (xwin-widget (xsv sub-window xe)))))
180
181 (trc " > data" (unless (null-pointer-p (xsv user-data xe))
182 (tcl-get-string (xsv user-data xe)))))
183 (otherwise
184 (trc "tkep> " (tk-event-type (mem-aref xe :int))))))
185
186

  ViewVC Help
Powered by ViewVC 1.1.5