/[mcclim]/mcclim/pointer-tracking.lisp
ViewVC logotype

Contents of /mcclim/pointer-tracking.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.19 - (show annotations)
Sat Jul 21 12:27:45 2007 UTC (6 years, 8 months ago) by rstrandh
Branch: MAIN
CVS Tags: McCLIM-0-9-5, McCLIM-0-9-6, HEAD
Changes since 1.18: +2 -2 lines
Declared some more arguments IGNORE or IGNORABLE to remove
some more compiler warnings.
1 ;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*-
2
3 ;;; (c) copyright 2002 by Alexey Dejneka (adejneka@comail.ru)
4 ;;; (c) copyright 2004 by Tim Moore (moore@bricoworks.com)
5
6 ;;; This library is free software; you can redistribute it and/or
7 ;;; modify it under the terms of the GNU Library General Public
8 ;;; License as published by the Free Software Foundation; either
9 ;;; version 2 of the License, or (at your option) any later version.
10 ;;;
11 ;;; This library is distributed in the hope that it will be useful,
12 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
14 ;;; Library General Public License for more details.
15 ;;;
16 ;;; You should have received a copy of the GNU Library General Public
17 ;;; License along with this library; if not, write to the
18 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
19 ;;; Boston, MA 02111-1307 USA.
20
21 ;;; TODO:
22 ;;;
23 ;;; - Keyboard gestures.
24 ;;;
25 ;;; - Optimization
26 ;;;
27 ;;; - - too many repeated checks within a loop;
28 ;;;
29 ;;; - - remove invoke-tracking-pointer; remove unnecessary checks.
30
31 (in-package :clim-internals)
32
33 ;;; The Spec specifies the tracking-pointer clause arguments as, e.g.,
34 ;;; (&key presentation event x y), implying that the user must write
35 ;;; the &key keyword, but real code doesn't do that. Check if &key is in
36 ;;; the arg list and add it if it is not.
37 (eval-when (:compile-toplevel :load-toplevel :execute)
38 (defun fix-tracking-pointer-args (args)
39 (unless (member '&allow-other-keys args)
40 (setq args (append args '(&allow-other-keys))))
41 (if (eq (car args) '&key)
42 args
43 (cons '&key args))))
44
45 (defmacro with-pointer-grabbed ((port sheet &key pointer) &body body)
46 (with-gensyms (the-port the-sheet the-pointer grabbed)
47 `(let* ((,the-port ,port)
48 (,the-sheet ,sheet)
49 (,the-pointer (or ,pointer (port-pointer ,the-port)))
50 (,grabbed nil))
51 ;; Don't end up in the debugger with the pointer grabbed!
52 (handler-bind ((error #'(lambda (c)
53 (declare (ignore c))
54 (when ,grabbed
55 (port-ungrab-pointer ,the-port
56 ,the-pointer
57 ,the-sheet)
58 (setq ,grabbed nil)))))
59 (unwind-protect
60 (when (port-grab-pointer ,the-port ,the-pointer ,the-sheet)
61 (setq ,grabbed t)
62 ,@body)
63 (when ,grabbed
64 (port-ungrab-pointer ,the-port ,the-pointer ,the-sheet)))))))
65
66 ;;; tracking-pointer. The functionality that deals with presentations has been
67 ;;; split off into frames.lisp.
68
69
70 (defgeneric tracking-pointer-loop (state frame sheet
71 &key pointer multiple-window
72 transformp context-type highlight
73 &allow-other-keys))
74
75 (defgeneric tracking-pointer-loop-step (tracking-state event x y))
76
77 (defgeneric make-tracking-pointer-state (frame sheet args))
78
79 (defmacro tracking-pointer
80 ((sheet &rest args
81 &key pointer multiple-window transformp context-type
82 (highlight nil highlight-p))
83 &body body)
84 (declare (ignorable multiple-window pointer transformp context-type highlight))
85 (setq sheet (stream-designator-symbol sheet '*standard-output*))
86 (loop
87 for (event-name handler-args . handler-body) in body
88 for handler-name = (gensym (symbol-name event-name))
89 collect `(,handler-name ,(fix-tracking-pointer-args handler-args)
90 ,@handler-body) into bindings
91 collect `#',handler-name into fn-names
92 append `(,event-name #',handler-name) into tracking-pointer-args
93 finally (return `(flet ,bindings
94 (declare (dynamic-extent ,@fn-names))
95 (invoke-tracking-pointer-loop *application-frame*
96 ,sheet
97 ,@tracking-pointer-args
98 ,@args
99 #-cmu18e :allow-other-keys #-cmu18e t)))))
100
101 (defun invoke-tracking-pointer-loop (frame sheet &rest args)
102 (apply #'tracking-pointer-loop
103 (make-tracking-pointer-state frame sheet args)
104 frame sheet args))
105
106 (defun default-tracking-handler (&rest args)
107 (declare (ignore args))
108 nil)
109
110 (defclass tracking-pointer-state ()
111 ((motion-handler :reader motion-handler :initarg :pointer-motion)
112 (button-press-handler :reader button-press-handler
113 :initarg :pointer-button-press)
114 (buttton-release-handler :reader button-release-handler
115 :initarg :pointer-button-release)
116 (keyboard-handler :reader keyboard-handler :initarg :keyboard))
117 (:default-initargs :pointer-motion #'default-tracking-handler
118 :pointer-button-press #'default-tracking-handler
119 :pointer-button-release #'default-tracking-handler
120 :keyboard #'default-tracking-handler))
121
122
123 (defmethod tracking-pointer-loop
124 ((state tracking-pointer-state) frame sheet &rest args
125 &key pointer multiple-window transformp context-type highlight)
126 (declare (ignore args pointer context-type highlight frame))
127 (with-sheet-medium (medium sheet)
128 (flet ((do-tracking ()
129 (loop
130 for event = (event-read sheet)
131 do (if (typep event 'pointer-event)
132 (multiple-value-bind (sheet-x sheet-y)
133 (pointer-event-position* event)
134 (multiple-value-bind (x y)
135 (if transformp
136 (transform-position
137 (medium-transformation medium)
138 sheet-x
139 sheet-y)
140 (values sheet-x sheet-y))
141 (tracking-pointer-loop-step state event x y)))
142 (tracking-pointer-loop-step state event 0 0)))))
143 (if multiple-window
144 (with-pointer-grabbed ((port medium) sheet)
145 (do-tracking))
146 (do-tracking)))))
147
148 (defmethod tracking-pointer-loop-step
149 ((state tracking-pointer-state) (event pointer-motion-event) x y)
150 (funcall (motion-handler state) :event event :window (event-sheet event) :x x :y y))
151
152 (defmethod tracking-pointer-loop-step
153 ((state tracking-pointer-state) (event pointer-button-press-event) x y)
154 (funcall (button-press-handler state)
155 :event event :window (event-sheet event) :x x :y y))
156
157 (defmethod tracking-pointer-loop-step
158 ((state tracking-pointer-state) (event pointer-button-release-event) x y)
159 (funcall (button-release-handler state)
160 :event event :window (event-sheet event) :x x :y y))
161
162 (defmethod tracking-pointer-loop-step
163 ((state tracking-pointer-state) (event t) x y)
164 (declare (ignore x y))
165 (if (typep event '(or keyboard-event character symbol))
166 (funcall (keyboard-handler state) :gesture event)
167 (handle-event (event-sheet event) event)))
168
169
170 ;;; DRAG-OUTPUT-RECORD and DRAGGING-OUTPUT.
171 ;;;
172 ;;; XXX Unresolved issues:
173 ;;; multiple-window is completely unsupported.
174 ;;; window-repaint events while dragging.
175
176 (defun bound-rectangles (r1-x1 r1-y1 r1-x2 r1-y2 r2-x1 r2-y1 r2-x2 r2-y2)
177 (values (min r1-x1 r2-x1) (min r1-y1 r2-y1)
178 (max r1-x2 r2-x2) (max r1-y2 r2-y2)))
179
180
181 (defgeneric drag-output-record
182 (stream output
183 &key repaint erase feedback finish-on-release multiple-window))
184
185 ;;; Fancy double-buffered feedback function
186 (defun make-buffered-feedback-function (record finish-on-release erase-final)
187 (multiple-value-bind (record-x record-y)
188 (output-record-position record)
189 (lambda (record stream initial-x initial-y x y event)
190 (flet ((simple-erase ()
191 (when erase-final
192 (when (output-record-parent record)
193 (delete-output-record record (output-record-parent record)))
194 (with-double-buffering
195 ((stream record) (buffer-rectangle))
196 (stream-replay stream buffer-rectangle)))))
197 (let ((dx (- record-x initial-x))
198 (dy (- record-y initial-y)))
199 (typecase event
200 (null
201 (setf (output-record-position record) (values (+ dx x) (+ dy y)))
202 (stream-add-output-record stream record)
203 (stream-replay stream record))
204 (pointer-motion-event
205 ;; Don't do an explicit erase. Instead, update the position of the
206 ;; output record and redraw the union of the old and new
207 ;; positions.
208 (with-bounding-rectangle* (old-x1 old-y1 old-x2 old-y2)
209 record
210 (when (output-record-parent record)
211 (delete-output-record record (output-record-parent record)))
212 (setf (output-record-position record)
213 (values (+ dx x) (+ dy y)))
214 (stream-add-output-record stream record)
215 (with-bounding-rectangle* (new-x1 new-y1 new-x2 new-y2)
216 record
217 (multiple-value-bind (area-x1 area-y1 area-x2 area-y2)
218 (bound-rectangles old-x1 old-y1 old-x2 old-y2
219 new-x1 new-y1 new-x2 new-y2)
220 (with-double-buffering
221 ((stream area-x1 area-y1 area-x2 area-y2)
222 (buffer-rectangle))
223 (stream-replay stream buffer-rectangle))))))
224 (pointer-button-press-event
225 (unless finish-on-release
226 (simple-erase)))
227 (pointer-button-release-event
228 (when finish-on-release
229 (simple-erase)))
230 (t nil)))))))
231
232 ;;; If the user supplies a feedback function, create a function to
233 ;;; call it with the simple :draw / :erase arguments.
234
235 (defun make-simple-feedback-function
236 (record feedback finish-on-release erase-final)
237 (declare (ignore record))
238 (lambda (record stream initial-x initial-y x y event)
239 (typecase event
240 (null
241 (funcall feedback record stream initial-x initial-y x y :draw))
242 (pointer-motion-event
243 (funcall feedback record stream initial-x initial-y x y :erase)
244 (funcall feedback record stream initial-x initial-y x y :draw))
245 (pointer-button-press-event
246 (unless finish-on-release
247 (when erase-final
248 (funcall feedback record stream initial-x initial-y x y :erase))))
249 (pointer-button-release-event
250 (when (and finish-on-release erase-final)
251 (funcall feedback record stream initial-x initial-y x y :erase)))
252 (t nil))))
253
254
255 (defmethod drag-output-record
256 ((stream output-recording-stream) (record output-record)
257 &key (repaint t) (erase #'erase-output-record)
258 feedback finish-on-release multiple-window
259 feedback-event erase-final)
260 (declare (ignore erase repaint multiple-window))
261 (let ((feedback-event-fn
262 (cond (feedback-event
263 feedback-event)
264 (feedback
265 (make-simple-feedback-function record
266 feedback
267 finish-on-release
268 erase-final))
269 (t (make-buffered-feedback-function record
270 finish-on-release
271 erase-final)))))
272 (setf (stream-current-output-record stream)
273 (stream-output-history stream))
274 (let* ((pointer (port-pointer (port stream)))
275 (pointer-state (pointer-button-state pointer)))
276 (multiple-value-bind (x0 y0)
277 (stream-pointer-position stream)
278 (funcall feedback-event-fn record stream x0 y0 x0 y0 nil)
279 (tracking-pointer (stream)
280 (:pointer-motion (&key event x y)
281 ;; XXX What about the sheet?
282 (funcall feedback-event-fn record stream x0 y0 x y event)
283 (funcall feedback-event-fn record stream x0 y0 x y event))
284 (:pointer-button-press (&key event x y)
285 (unless finish-on-release
286 (funcall feedback-event-fn record stream x0 y0 x y event)
287 (return-from drag-output-record (values x y))))
288 (:pointer-button-release (&key event x y)
289 ;; If the button released was one of those held down on entry to
290 ;; drag-output-record, we're done.
291 (when (and finish-on-release
292 (not (zerop (logand pointer-state
293 (pointer-event-button event)))))
294 (funcall feedback-event-fn record stream x0 y0 x y event)
295 (return-from drag-output-record (values x y)))))))))
296
297 (defmacro dragging-output ((&optional (stream '*standard-output*) &rest args
298 &key (repaint t) finish-on-release multiple-window)
299 &body body)
300 (declare (ignore repaint finish-on-release multiple-window))
301 (setq stream (stream-designator-symbol stream '*standard-output*))
302 (with-gensyms (record)
303 `(let ((,record (with-output-to-output-record (,stream)
304 ,@body)))
305 (drag-output-record ,stream ,record :erase-final t ,@args))))
306
307 (defun dragging-drawing (stream drawer &key (finish-on-release t)
308 (pointer (port-pointer (port stream)))
309 multiple-window)
310 "Draws something simple in response to pointer events for
311 `pointer' and returns the coordinates of the pointer when the
312 function finishes. The function finishes when mouse button one is
313 no longer held down if `finish-on-release' is true; if it is
314 false, it finishes when the mouse is clicked. `Drawer' should
315 draw something on `stream', and is called with tree arguments:
316 two integers, the X and the Y coordinates for the pointer motion
317 triggering the draw, and either the symbol `:draw' or `:erase'
318 signalling what the function should do. `Drawer' will be called
319 with the previously used coordinates whenever pointer motion
320 occurs, so it can erase the previous output (elegantly done by
321 using `+flipping-ink+' for drawing and ignoring the state
322 symbol)."
323 (with-output-recording-options (stream :draw t :record nil)
324 (let ((ox nil) (oy nil)) ; So we can erase the old line.
325 (labels ((draw (x y)
326 (funcall drawer x y :draw))
327 (erase (x y)
328 (funcall drawer x y :erase))
329 (motion (x y)
330 (when ox (erase ox oy))
331 (draw x y)
332 (setf ox x oy y))
333 (end (event x y)
334 (when (eql (event-sheet event) stream)
335 (when ox (draw ox oy))
336 (return-from dragging-drawing
337 (values x y)))))
338 ;; Make an initial draw. We need to convert the screen
339 ;; coordinates from the pointer into sheet-local coordinates.
340 (multiple-value-call #'transform-position
341 (sheet-native-transformation stream) (pointer-position pointer))
342 (tracking-pointer (stream :pointer pointer
343 :multiple-window multiple-window)
344 (:pointer-motion (window x y)
345 (when (eql window stream)
346 (motion x y)))
347 (:pointer-button-press (event x y)
348 (end event x y))
349 (:pointer-button-release (event x y)
350 (when finish-on-release
351 (end event x y))))))))
352
353 (defun pointer-place-rubber-band-line* (&key (stream *standard-output*)
354 (pointer (port-pointer (port stream)))
355 multiple-window start-x start-y
356 (finish-on-release t))
357 "Let the user drag a line on `stream', returning the
358 coordinates of the line ends as four values. `Pointer' is the
359 pointer that will be tracked (the default should be used unless
360 the port has multiple pointing devices), `multiple-window' is
361 currently unimplemented and `start-x'/`start-y', if provided (and
362 both or none must be provided) are the coordinates for one end of
363 the line. If these arguments are not provided, the user will have
364 to press a mouse button to specify the beginning of the line. If
365 `finish-on-release' is true, the function will end when the user
366 releases the mouse button. If false, the user will have to click
367 to finish inputting the line."
368 (assert (not (eq (not (not start-x)) (not start-y))) nil
369 "You must provide either both `:start-x' and `:start-y'
370 or none at all")
371 (or start-x
372 (block nil
373 (tracking-pointer (stream :pointer pointer
374 :multiple-window multiple-window)
375 (:pointer-button-press (event x y)
376 (declare (ignore event))
377 (setf start-x x)
378 (setf start-y y)
379 (return)))))
380 (assert (and (>= start-x 0) (>= start-y 0)))
381 (labels ((draw (x y state)
382 (declare (ignore state))
383 (with-drawing-options (stream :ink +flipping-ink+)
384 (draw-line* stream start-x start-y x y))))
385 (multiple-value-call #'values
386 (values start-x start-y)
387 (dragging-drawing stream #'draw :finish-on-release finish-on-release
388 :pointer pointer :multiple-window multiple-window))))
389
390 ;; The CLIM 2.2 spec is slightly unclear about how the next two
391 ;; functions are supposed to behave, especially wrt. the user
392 ;; experience. I think these functions are supposed to present a
393 ;; rectangle on screen and let the user drag around the edges - this
394 ;; would make supporting both left/top and right/bottom make sense,
395 ;; and provide a way for the :rectangle argument to
396 ;; `pointer-input-rectangle' to make sense. However, this would be a
397 ;; very weird user experience, so I (Troels) have instead chosen to
398 ;; consider left/top and right/bottom to be the same thing, preferring
399 ;; left/top if both are specified. The :rectangle argument to
400 ;; `pointer-input-rectangle' is ignored. The user is meant to drag out
401 ;; a rectangle with the mouse, possibly by first providing a starting
402 ;; point. This is intuitive behavior and I see no point in supporting
403 ;; something more complicated. These changes should be invisible to
404 ;; the calling program.
405
406 (defun pointer-input-rectangle* (&key (stream *standard-output*)
407 (pointer (port-pointer (port stream)))
408 multiple-window left top right bottom
409 (finish-on-release t))
410 "Let the user drag a rectangle on `stream' and return four
411 values, the coordinates of the rectangle. `Pointer' is the
412 pointer that will be tracked (the default should be used unless
413 the port has multiple pointing devices), `multiple-window' is
414 currently unimplemented and both `left'/`top' and
415 `right'/`bottom' specify an initial position for a rectangle
416 corner. You must provide either both parts of any of these two
417 coordinate pairs or none at all. If you provide both `left'/`top'
418 and `right'/`bottom', the `left'/`top' values will be used,
419 otherwise, the non-nil set will be used. If neither is specified,
420 the user will be able to specify the origin corner of the
421 rectangle by clicking the mouse. If `finish-on-release' is true,
422 the function will end when the user releases the mouse button. If
423 false, the user will have to click to finish inputting the
424 rectangle."
425 (assert (not (eq (not (not top)) (not left))) nil
426 "You must provide either none or both of `:top' and `:left'")
427 (assert (not (eq (not (not right)) (not bottom))) nil
428 "You must provide either none or both of `:right' and `:bottom'")
429 (setf top (or top bottom)
430 left (or left right))
431 (unless top
432 (block nil
433 (tracking-pointer (stream :pointer pointer
434 :multiple-window multiple-window)
435 (:pointer-button-press (event x y)
436 (declare (ignore event))
437 (setf left x)
438 (setf top y)
439 (return)))))
440 (multiple-value-bind (x y)
441 (labels ((draw (x y state)
442 (declare (ignore state))
443 (with-drawing-options (stream :ink +flipping-ink+)
444 (draw-rectangle* stream left top x y :filled nil))))
445 (dragging-drawing stream #'draw :finish-on-release finish-on-release
446 :pointer pointer :multiple-window multiple-window))
447 ;; Normalise so that x1 < x2 ^ y1 < y2.
448 (values (min left x) (min top y)
449 (max left x) (max top y))))
450
451 (defun pointer-input-rectangle (&rest args &key (stream *standard-output*)
452 (pointer (port-pointer (port stream)))
453 multiple-window rectangle
454 (finish-on-release t))
455 "Like `pointer-input-rectangle*', but returns a bounding
456 rectangle instead of coordinates."
457 (declare (ignore pointer multiple-window rectangle finish-on-release))
458 (with-keywords-removed (args (:rectangle))
459 (apply #'make-bounding-rectangle (apply #'pointer-input-rectangle args))))

  ViewVC Help
Powered by ViewVC 1.1.5