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

Contents of /mcclim/pointer-tracking.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.16 - (show annotations)
Tue Jan 11 13:35:18 2005 UTC (9 years, 3 months ago) by tmoore
Branch: MAIN
CVS Tags: McCLIM-0-9-1
Changes since 1.15: +114 -53 lines
Rewrote WITH-DOUBLE-BUFFERING. This version takes a rectangle as an
argument, allocates a pixmap for that region of the screen, and sets up
the sheet transformations so that drawing is done in the correct
pixmap coordinates.

Use WITH-DOUBLE-BUFFERING in DRAG-OUTPUT-RECORD. Add a little example
of using dragging-output.

Change the definition of ROUND-COORDINATE in the CLX backend to round
down from .5, not up. This should follow the CLIM pixel coverage
definition for shapes more closely. Replace most uses of ROUND in the
CLX backend with ROUND-COORDINATE.

Allow inconsistent :ID-TEST arguments in UPDATING-OUTPUT.
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 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 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 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

  ViewVC Help
Powered by ViewVC 1.1.5