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

Contents of /mcclim/pointer-tracking.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.18 - (hide annotations)
Thu Dec 21 10:36:40 2006 UTC (7 years, 4 months ago) by thenriksen
Branch: MAIN
CVS Tags: mcclim-0-9-4, McCLIM-0-9-4
Changes since 1.17: +153 -1 lines
Implemented `pointer-place-rubber-band-line*',
`pointer-input-rectangle*' and `pointer-input-rectangle' (CLIM 2.2).
1 adejneka 1.1 ;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*-
2    
3     ;;; (c) copyright 2002 by Alexey Dejneka (adejneka@comail.ru)
4 moore 1.10 ;;; (c) copyright 2004 by Tim Moore (moore@bricoworks.com)
5 adejneka 1.1
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 mikemac 1.3 (in-package :clim-internals)
32 adejneka 1.1
33 moore 1.6 ;;; 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 hefner1 1.7 (if (eq (car args) '&key)
42     args
43     (cons '&key args))))
44 moore 1.6
45 moore 1.9 (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 moore 1.10 ;;; 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 pointer transformp context-type highlight))
85 moore 1.12 (setq sheet (stream-designator-symbol sheet '*standard-output*))
86 moore 1.10 (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 hefner1 1.14 (declare (dynamic-extent ,@fn-names))
95     (invoke-tracking-pointer-loop *application-frame*
96 moore 1.10 ,sheet
97     ,@tracking-pointer-args
98 hefner1 1.14 ,@args
99     #-cmu18e :allow-other-keys #-cmu18e t)))))
100 moore 1.10
101     (defun invoke-tracking-pointer-loop (frame sheet &rest args)
102     (apply #'tracking-pointer-loop
103     (make-tracking-pointer-state frame sheet args)
104 moore 1.11 frame sheet args))
105 moore 1.10
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 tmoore 1.17 :initarg :pointer-button-press)
114 moore 1.10 (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 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 moore 1.9 (do-tracking))
146 moore 1.10 (do-tracking)))))
147    
148     (defmethod tracking-pointer-loop-step
149     ((state tracking-pointer-state) (event pointer-motion-event) x y)
150 hefner1 1.15 (funcall (motion-handler state) :event event :window (event-sheet event) :x x :y y))
151 moore 1.10
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 tmoore 1.16 (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 moore 1.10 (defgeneric drag-output-record
182     (stream output
183     &key repaint erase feedback finish-on-release multiple-window))
184    
185 tmoore 1.16 ;;; 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 moore 1.10 (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 tmoore 1.16 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 moore 1.10
297     (defmacro dragging-output ((&optional (stream '*standard-output*) &rest args
298 thenriksen 1.18 &key (repaint t) finish-on-release multiple-window)
299 moore 1.10 &body body)
300     (declare (ignore repaint finish-on-release multiple-window))
301 moore 1.12 (setq stream (stream-designator-symbol stream '*standard-output*))
302 moore 1.10 (with-gensyms (record)
303     `(let ((,record (with-output-to-output-record (,stream)
304     ,@body)))
305 tmoore 1.16 (drag-output-record ,stream ,record :erase-final t ,@args))))
306    
307 thenriksen 1.18 (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 hefner1 1.8
353 thenriksen 1.18 (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