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

Contents of /mcclim/input.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.31 - (show annotations)
Fri Apr 23 19:29:48 2004 UTC (10 years ago) by moore
Branch: MAIN
Changes since 1.30: +4 -0 lines
Changes to turn off, and then turn on again, presentation highlighting
when redrawing a pane, with the aim of fixing various screwups that
happen with tricky presentation highlighting that uses
+flipping-ink+. As part of this I removed redisplay-changed-panes and
rewrote the CLIM standard functions redisplay-frame-panes,
redisplay-frame-pane, and pane-redisplay-needed. I did various
refactoring among methods on panes, frames, and
updating-output-mixin too.

Moved a bunch of :initform forms to :default-initargs.

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

  ViewVC Help
Powered by ViewVC 1.1.5