/[mcclim]/mcclim/input.lisp
ViewVC logotype

Contents of /mcclim/input.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.30 - (show annotations)
Sun Mar 21 21:49:06 2004 UTC (10 years ago) by hefner1
Branch: MAIN
Changes since 1.29: +28 -0 lines
Scroll wheel support. Added new defconstants for +pointer-wheel-up/down+,
and changed CLX backend to produce them. Handle scrolling using a
DISPATCH-EVENT method specialized on mouse-wheel-scroll-mixin, and
tentatively mixed this into clim-stream-pane.
1 ;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*-
2
3 ;;; (c) copyright 1998,1999,2000 by Michael McDonald (mikemac@mikemac.com)
4 ;;; (c) copyright 2002 by Gilbert Baumann <unk6@rz.uni-karlsruhe.de>
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 (in-package :clim-internals)
22
23 ;;; Input Protocol Classes
24
25 ;; Event queues
26
27 (defclass standard-event-queue ()
28 ((lock :initform (make-lock "event queue")
29 :reader event-queue-lock)
30 (head :initform nil
31 :accessor event-queue-head
32 :documentation "Head pointer of event queue.")
33 (tail :initform nil
34 :accessor event-queue-tail
35 :documentation "Tail pointer of event queue.")
36 (processes
37 :initform (make-condition-variable)
38 :accessor event-queue-processes
39 :documentation "Condition variable for waiting processes")
40 ;; experimental extension for scheduled event insersion
41 (schedule-time
42 :initform nil
43 :accessor event-schedule-time
44 :documentation "The next time an event should be scheduled.")
45 (schedule
46 :initform nil
47 ;; :accessor event-queue-schedule
48 ;; this accessor conflicts with the method below.
49 ;; noted by mikemac. I recommend renaming the slot.
50 ;; --GB 2002-11-10
51 :documentation "Time ordered queue of events to schedule.")))
52
53 (defclass port-event-queue (standard-event-queue)
54 ((port :initform nil
55 :initarg :port
56 :accessor event-queue-port
57 :documentation "The port which will be generating events for the queue.")))
58
59 (defmethod event-queue-read-no-hang/locked ((eq standard-event-queue))
60 (check-schedule eq)
61 (let ((res (pop (event-queue-head eq))))
62 (when (null (event-queue-head eq))
63 (setf (event-queue-tail eq) nil))
64 res))
65
66 (defmethod event-queue-read-no-hang ((eq standard-event-queue))
67 "Reads one event from the queue, if there is no event just return NIL."
68 (with-lock-held ((event-queue-lock eq))
69 (event-queue-read-no-hang/locked eq)))
70
71 (defmethod event-queue-read ((eq standard-event-queue))
72 "Reads one event from the queue, if there is no event, hang until here is one."
73 (let ((lock (event-queue-lock eq)))
74 (with-lock-held (lock)
75 (loop
76 (check-schedule eq)
77 (let ((res (event-queue-read-no-hang/locked eq)))
78 (when res
79 (return res))
80 ;; is there an event waiting to be scheduled?
81 (with-slots (schedule-time) eq
82 (let* ((now (now))
83 (timeout (when schedule-time (- schedule-time now))))
84 (condition-wait (event-queue-processes eq) lock timeout))))))))
85
86 (defmethod event-queue-read-with-timeout ((eq standard-event-queue)
87 timeout wait-function)
88 (let ((lock (event-queue-lock eq)))
89 (with-lock-held (lock)
90 (loop
91 (check-schedule eq)
92 (let ((res (event-queue-read-no-hang/locked eq)))
93 (when res
94 (return res))
95 (warn "event-queue-read-with-timeout ignoring predicate")
96 (condition-wait (event-queue-processes eq) lock timeout))))))
97
98 (defmethod event-queue-append ((eq standard-event-queue) item)
99 "Append the item at the end of the queue. Does event compression."
100 (with-lock-held ((event-queue-lock eq))
101 (labels ((append-event ()
102 (cond ((null (event-queue-tail eq))
103 (setf (event-queue-head eq) (cons item nil)
104 (event-queue-tail eq) (event-queue-head eq)))
105 (t
106 (setf (event-queue-tail eq)
107 (setf (cdr (event-queue-tail eq)) (cons item nil))))))
108 (event-delete-if (predicate)
109 (when (not (null (event-queue-head eq)))
110 (setf (event-queue-head eq)
111 (delete-if predicate (event-queue-head eq))
112 (event-queue-tail eq)
113 (last (event-queue-head eq))))))
114 (cond
115 ;; Motion Event Compression
116 ;;
117 ;; . find the (at most one) motion event
118 ;; . delete it
119 ;; . append item to queue
120 ;;
121 ;; But leave enter/exit events.
122 ;;
123 ((and (typep item 'pointer-motion-event)
124 (not (typep item 'pointer-boundary-event)))
125 (let ((sheet (event-sheet item)))
126 (event-delete-if
127 #'(lambda (x)
128 (and (typep x 'pointer-motion-event)
129 (not (typep x 'pointer-boundary-event))
130 (eq (event-sheet x) sheet))))
131 (append-event)))
132 ;;
133 ;; Resize event compression
134 ;;
135 ((typep item 'window-configuration-event)
136 (when (typep (event-sheet item) 'top-level-sheet-pane)
137 (let ((sheet (event-sheet item)))
138 (event-delete-if
139 #'(lambda (ev)
140 (and (typep ev 'window-configuration-event)
141 (eq (event-sheet ev) sheet)))))
142 (append-event)))
143 ;;
144 ;; Repaint event compression
145 ;;
146 ((typep item 'window-repaint-event)
147 (let ((region (window-event-native-region item))
148 (sheet (event-sheet item))
149 (did-something-p nil))
150 (labels ((fun (xs)
151 (cond ((null xs)
152 ;; We reached the queue's tail: Append the new event, construct a new
153 ;; one if necessary.
154 (when did-something-p
155 (setf item
156 (make-instance 'window-repaint-event
157 :timestamp (event-timestamp item)
158 :sheet (event-sheet item)
159 :region region)))
160 (setf (event-queue-tail eq) (cons item nil)) )
161 ;;
162 ((and (typep (car xs) 'window-repaint-event)
163 (eq (event-sheet (car xs)) sheet))
164 ;; This is a repaint event for the same sheet, delete it and combine
165 ;; its region into the new event.
166 (setf region
167 (region-union region (window-event-native-region (car xs))))
168 ;; Here is an alternative, which just takes the bounding rectangle.
169 ;; NOTE: When doing this also take care that the new region really
170 ;; is cleared.
171 ;; (setf region
172 ;; (let ((old-region (window-event-native-region (car xs))))
173 ;; (make-rectangle*
174 ;; (min (bounding-rectangle-min-x region)
175 ;; (bounding-rectangle-min-x old-region))
176 ;; (min (bounding-rectangle-min-y region)
177 ;; (bounding-rectangle-min-y old-region))
178 ;; (max (bounding-rectangle-max-x region)
179 ;; (bounding-rectangle-max-x old-region))
180 ;; (max (bounding-rectangle-max-y region)
181 ;; (bounding-rectangle-max-y old-region)))))
182 (setf did-something-p t)
183 (fun (cdr xs)))
184 ;;
185 (t
186 (setf (cdr xs) (fun (cdr xs)))
187 xs))))
188 (setf (event-queue-head eq) (fun (event-queue-head eq))))))
189 ;; Regular events are just appended:
190 (t (append-event))))
191 (condition-notify (event-queue-processes eq))))
192
193 (defmethod event-queue-prepend ((eq standard-event-queue) item)
194 "Prepend the item to the beginning of the queue."
195 (with-lock-held ((event-queue-lock eq))
196 (cond ((null (event-queue-tail eq))
197 (setf (event-queue-head eq) (cons item nil)
198 (event-queue-tail eq) (event-queue-head eq)))
199 (t
200 (push item (event-queue-head eq))))
201 (condition-notify (event-queue-processes eq))))
202
203 (defmethod event-queue-peek ((eq standard-event-queue))
204 (with-lock-held ((event-queue-lock eq))
205 (check-schedule eq)
206 (first (event-queue-head eq))))
207
208 (defmethod event-queue-peek-if (predicate (eq standard-event-queue))
209 "Goes thru the whole event queue and returns the first event, which
210 satisfies 'predicate' and leaves the event in the queue.
211 Returns NIL, if there is no such event."
212 (with-lock-held ((event-queue-lock eq))
213 (find-if predicate (event-queue-head eq))))
214
215 (defmethod event-queue-listen ((eq standard-event-queue))
216 (check-schedule eq)
217 (not (null (event-queue-head eq))))
218
219 (defun now ()
220 (/ (get-internal-real-time)
221 internal-time-units-per-second))
222
223 (defmethod event-queue-listen-or-wait ((eq standard-event-queue) &key timeout)
224 (check-schedule eq)
225 (let ((lock (event-queue-lock eq)))
226 (with-lock-held (lock)
227 (with-slots (schedule-time) eq
228 (flet ((pred ()
229 (not (null (event-queue-head eq)))))
230 (cond
231 (timeout
232 (loop as timeout-time = (+ now timeout)
233 with now = (now)
234 do (when (pred)
235 (return t))
236 do (when (>= now timeout-time)
237 (return nil))
238 do (let ((timeout (if schedule-time
239 (min (- schedule-time now)
240 (- timeout-time now))
241 (- timeout-time now))))
242 (condition-wait (event-queue-processes eq)
243 lock timeout))
244 do (check-schedule eq)))
245 (schedule-time
246 (loop do (when (pred)
247 (return t))
248 do (condition-wait
249 (event-queue-processes eq) lock (- schedule-time (now)))
250 do (check-schedule eq)))
251 (t
252 (or (pred)
253 (progn
254 (condition-wait (event-queue-processes eq) lock)
255 t)))))))))
256
257 (defmethod check-schedule ((eq standard-event-queue))
258 ; see if it's time to inject a scheduled event into the queue.
259 (with-slots (schedule-time schedule) eq
260 (when (and schedule-time
261 (> (now) schedule-time))
262 (let* ((event (pop schedule))
263 (sheet (pop schedule)))
264 (setf schedule-time (pop schedule))
265 (dispatch-event sheet event))
266 t)))
267
268 ; ugh. FIXME when I work - build a priority queue or something
269 (defmethod schedule-event-queue ((eq standard-event-queue) sheet event delay)
270 (with-slots (schedule-time schedule) eq
271 (let ((when (+ (now) delay)))
272 (if schedule
273 (cond
274 ((< when schedule-time)
275 (push schedule-time schedule)
276 (push sheet schedule)
277 (push event schedule)
278 (setf schedule-time when))
279 (t
280 ; (format *trace-output* "queue = ~A~%" schedule)
281 (do* ((prev (cdr schedule) (cdddr prev))
282 (point (cddr schedule) (cdddr point))
283 (time (car point)))
284 ((or (null point)
285 (< when time))
286 (setf (cdr prev)
287 (cons when (cons event (cons sheet (cdr prev)))))))))
288 (progn
289 (setf schedule-time when)
290 (push sheet schedule)
291 (push event schedule))))))
292
293 ;; PORT-EVENT-QUEUE methods
294
295 (defun do-port-force-output (port-event-queue)
296 (let ((port (event-queue-port port-event-queue)))
297 (when port (port-force-output port))))
298
299 (defmethod event-queue-read :before ((eq port-event-queue))
300 (do-port-force-output eq))
301
302 (defmethod event-queue-read-no-hang :before ((eq port-event-queue))
303 (do-port-force-output eq))
304
305 (defmethod event-queue-read-with-timeout :before ((eq port-event-queue)
306 timeout wait-function)
307 (declare (ignore timeout wait-function))
308 (do-port-force-output eq))
309
310 (defmethod event-queue-listen :before ((eq port-event-queue))
311 (do-port-force-output eq))
312
313 (defmethod event-queue-listen-or-wait :before ((eq standard-event-queue)
314 &key timeout)
315 (declare (ignore timeout))
316 (do-port-force-output eq))
317
318 (defmethod event-queue-peek :before ((eq port-event-queue))
319 (do-port-force-output eq))
320
321 (defmethod event-queue-peek-if :before (predicate (eq port-event-queue))
322 (declare (ignore predicate))
323 (do-port-force-output eq))
324
325 ;; STANDARD-SHEET-INPUT-MIXIN
326
327 (defclass standard-sheet-input-mixin ()
328 ((queue :initform (make-instance 'port-event-queue)
329 :reader sheet-event-queue
330 :initarg :input-buffer)
331 (port :initform nil
332 :initarg :port
333 :reader port)))
334
335 (defmethod stream-input-buffer ((stream standard-sheet-input-mixin))
336 (sheet-event-queue stream))
337
338 (defmethod (setf stream-input-buffer) (new-val
339 (stream standard-sheet-input-mixin))
340 (setf (slot-value stream 'queue) new-val))
341
342 ;(defmethod dispatch-event ((sheet standard-sheet-input-mixin) event)
343 ; (if (typep event 'device-event)
344 ; (queue-event sheet event)
345 ; (handle-event sheet event)))
346
347 (defmethod dispatch-event ((sheet standard-sheet-input-mixin) event)
348 (queue-event sheet event))
349
350 (defmethod queue-event ((sheet standard-sheet-input-mixin) event)
351 (with-slots (queue) sheet
352 (event-queue-append queue event)))
353
354 (defmethod schedule-event ((sheet standard-sheet-input-mixin) event delay)
355 (with-slots (queue) sheet
356 (schedule-event-queue queue sheet event delay)))
357
358 (defmethod handle-event ((sheet standard-sheet-input-mixin) event)
359 ;; Standard practice is to ignore events
360 (declare (ignore event))
361 nil)
362
363 (defmethod event-read ((sheet standard-sheet-input-mixin))
364 (with-slots (queue) sheet
365 (event-queue-read queue)))
366
367 (defmethod event-read-with-timeout ((sheet standard-sheet-input-mixin)
368 &key (timeout nil) (wait-function nil))
369 ;; This one is not in the spec ;-( --GB
370 (with-slots (queue) sheet
371 (event-queue-read-with-timeout queue timeout wait-function)))
372
373 (defmethod event-read-no-hang ((sheet standard-sheet-input-mixin))
374 (with-slots (queue) sheet
375 (event-queue-read-no-hang queue)))
376
377 (defmethod event-peek ((sheet standard-sheet-input-mixin) &optional event-type)
378 (with-slots (queue) sheet
379 (if event-type
380 (event-queue-peek-if (lambda (x)
381 (typep x event-type))
382 queue)
383 (event-queue-peek-if (lambda (x) (declare (ignore x)) t)
384 queue))))
385
386 (defmethod event-unread ((sheet standard-sheet-input-mixin) event)
387 (with-slots (queue) sheet
388 (event-queue-prepend queue event)))
389
390 (defmethod event-listen ((sheet standard-sheet-input-mixin))
391 (with-slots (queue) sheet
392 (event-queue-listen queue)))
393
394 ;;;;
395
396 ;;; Support for callers that want to set an event queue for every pane.
397
398 (defclass no-event-queue-mixin ()
399 ())
400
401 (defmethod initialize-instance :after ((obj no-event-queue-mixin)
402 &key input-buffer)
403 (declare (ignore input-buffer))
404 nil)
405
406 (defmethod (setf stream-input-buffer) (new-val (stream no-event-queue-mixin))
407 new-val)
408
409 (defclass immediate-sheet-input-mixin (no-event-queue-mixin)
410 ())
411
412 (defmethod dispatch-event ((sheet immediate-sheet-input-mixin) event)
413 (handle-event sheet event))
414
415 (defmethod handle-event ((sheet immediate-sheet-input-mixin) event)
416 (declare (ignore event))
417 nil)
418
419 (define-condition sheet-is-mute-for-input (error)
420 ())
421
422 (defclass sheet-mute-input-mixin (no-event-queue-mixin)
423 ())
424
425 (defmethod dispatch-event ((sheet sheet-mute-input-mixin) event)
426 (declare (ignore event))
427 (error 'sheet-is-mute-for-input))
428
429 (defmethod queue-event ((sheet sheet-mute-input-mixin) event)
430 (declare (ignore event))
431 (error 'sheet-is-mute-for-input))
432
433 (defmethod schedule-event ((sheet sheet-mute-input-mixin) event delay)
434 (declare (ignore event delay))
435 (error 'sheet-is-mute-for-input))
436
437 (defmethod handle-event ((sheet sheet-mute-input-mixin) event)
438 (declare (ignore event))
439 (error 'sheet-is-mute-for-input))
440
441 (defmethod event-read ((sheet sheet-mute-input-mixin))
442 (error 'sheet-is-mute-for-input))
443
444 (defmethod event-read-with-timeout ((sheet sheet-mute-input-mixin)
445 &key (timeout nil) (wait-function nil))
446 (declare (ignore timeout wait-function))
447 (error 'sheet-is-mute-for-input))
448
449 (defmethod event-read-no-hang ((sheet sheet-mute-input-mixin))
450 (error 'sheet-is-mute-for-input))
451
452 (defmethod event-peek ((sheet sheet-mute-input-mixin) &optional event-type)
453 (declare (ignore event-type))
454 (error 'sheet-is-mute-for-input))
455
456 (defmethod event-unread ((sheet sheet-mute-input-mixin) event)
457 (declare (ignore event))
458 (error 'sheet-is-mute-for-input))
459
460 (defmethod event-listen ((sheet sheet-mute-input-mixin))
461 (error 'sheet-is-mute-for-input))
462
463 ;;;;
464
465 (defclass delegate-sheet-input-mixin ()
466 ((delegate :initform nil
467 :initarg :delegate
468 :accessor delegate-sheet-delegate) ))
469
470 ;;; Don't know if this event queue stuff is completely right, or if it matters
471 ;;; much...
472
473 (defmethod initialize-instance :after ((obj delegate-sheet-input-mixin)
474 &key input-buffer)
475 (declare (ignore input-buffer)))
476
477 (defmethod stream-input-buffer ((stream delegate-sheet-input-mixin))
478 (sheet-event-queue (delegate-sheet-delegate stream)))
479
480 (defmethod (setf stream-input-buffer) (new-val
481 (stream delegate-sheet-input-mixin))
482 (setf (stream-input-buffer (delegate-sheet-delegate stream)) new-val))
483
484 (defmethod dispatch-event ((sheet delegate-sheet-input-mixin) event)
485 (dispatch-event (delegate-sheet-delegate sheet) event))
486
487 (defmethod queue-event ((sheet delegate-sheet-input-mixin) event)
488 (queue-event (delegate-sheet-delegate sheet) event))
489
490 (defmethod schedule-event ((sheet delegate-sheet-input-mixin) event delay)
491 (schedule-event (delegate-sheet-delegate sheet) event delay))
492
493 (defmethod handle-event ((sheet delegate-sheet-input-mixin) event)
494 (handle-event (delegate-sheet-delegate sheet) event))
495
496 (defmethod event-read ((sheet delegate-sheet-input-mixin))
497 (event-read (delegate-sheet-delegate sheet)))
498
499 (defmethod event-read-with-timeout ((sheet delegate-sheet-input-mixin)
500 &key (timeout nil) (wait-function nil))
501 (event-read-with-timeout (delegate-sheet-delegate sheet)
502 :timeout timeout :wait-function wait-function))
503
504 (defmethod event-read-no-hang ((sheet delegate-sheet-input-mixin))
505 (event-read-no-hang (delegate-sheet-delegate sheet)))
506
507 (defmethod event-peek ((sheet delegate-sheet-input-mixin) &optional event-type)
508 (event-peek (delegate-sheet-delegate sheet) event-type))
509
510 (defmethod event-unread ((sheet delegate-sheet-input-mixin) event)
511 (event-unread (delegate-sheet-delegate sheet) event))
512
513 (defmethod event-listen ((sheet delegate-sheet-input-mixin))
514 (event-listen (delegate-sheet-delegate sheet)))
515
516 ;;; Class actually used by panes.
517
518 (defclass clim-sheet-input-mixin (#+clim-mp standard-sheet-input-mixin #-clim-mp immediate-sheet-input-mixin)
519 ())
520
521 ;;; Mixin for panes which want the mouse wheel to scroll vertically
522
523 (defclass mouse-wheel-scroll-mixin () ())
524
525 (defparameter *mouse-scroll-distance* 4
526 "Number of lines by which to scroll the window in response to the scroll wheel")
527
528 (defmethod dispatch-event :around ((sheet mouse-wheel-scroll-mixin)
529 (event pointer-button-press-event))
530 (let ((viewport (pane-viewport sheet))
531 (button (pointer-event-button event))
532 (dy (* *mouse-scroll-distance*
533 (stream-line-height sheet))))
534 (if (and viewport
535 (or (eql button +pointer-wheel-up+)
536 (eql button +pointer-wheel-down+)))
537 (multiple-value-bind (x0 y0 x1 y1)
538 (bounding-rectangle* (pane-viewport-region sheet))
539 (declare (ignore x1))
540 (multiple-value-bind (sx0 sy0 sx1 sy1)
541 (bounding-rectangle* (sheet-region sheet))
542 (declare (ignore sx0 sx1))
543 (let ((height (- y1 y0)))
544 (scroll-extent sheet x0 (if (eql button +pointer-wheel-up+)
545 (max sy0 (- y0 dy))
546 (- (min sy1 (+ y1 dy)) height))))))
547 (call-next-method))))

  ViewVC Help
Powered by ViewVC 1.1.5