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

Contents of /mcclim/input.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.17 - (hide annotations)
Sat Jul 13 07:58:56 2002 UTC (11 years, 9 months ago) by adejneka
Branch: MAIN
Changes since 1.16: +64 -0 lines
Initial implementation of TRACKING-POINTER.
1 mikemac 1.1 ;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*-
2    
3     ;;; (c) copyright 1998,1999,2000 by Michael McDonald (mikemac@mikemac.com)
4 gilbert 1.5 ;;; (c) copyright 2002 by Gilbert Baumann <unk6@rz.uni-karlsruhe.de>
5 mikemac 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     (in-package :CLIM-INTERNALS)
22    
23     ;;; Input Protocol Classes
24    
25 gilbert 1.5 ;; 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    
37     (defmethod event-queue-read-no-hang ((eq standard-event-queue))
38     "Reads one event from the queue, if there is no event just return NIL."
39     (with-lock-held ((event-queue-lock eq))
40     (let ((res (pop (event-queue-head eq))))
41     (when (null (event-queue-head eq))
42     (setf (event-queue-tail eq) nil))
43     res)))
44    
45     (defmethod event-queue-read ((eq standard-event-queue))
46     "Reads one event from the queue, if there is no event, hang until here is one."
47     (loop
48     (let ((res (event-queue-read-no-hang eq)))
49     (when res
50     (return res))
51 brian 1.10 (if *multiprocessing-p*
52     (process-wait "Waiting for event"
53     (lambda ()
54     (not (null (event-queue-head eq)))))
55     (process-wait "Waiting for event"
56     (lambda ()
57     (loop for port in climi::*all-ports*
58     ; this is dubious
59     do (process-next-event port))
60     (not (null (event-queue-head eq)))))))))
61 gilbert 1.5
62 gilbert 1.13 (defmethod event-queue-read-with-timeout ((eq standard-event-queue)
63     timeout wait-function)
64     (loop
65     (let ((res (event-queue-read-no-hang eq)))
66     (when res
67     (return res))
68     (if *multiprocessing-p*
69     (process-wait-with-timeout "Waiting for event"
70     timeout
71     (lambda ()
72     (or
73     (not (null (event-queue-head eq)))
74     (funcall wait-function))))
75     (process-wait-with-timeout "Waiting for event"
76     timeout
77     (lambda ()
78     (loop for port in climi::*all-ports*
79     ;; this is dubious
80     do (process-next-event port))
81     (or
82     (not (null (event-queue-head eq)))
83     (funcall wait-function))))))))
84    
85 gilbert 1.5 (defmethod event-queue-append ((eq standard-event-queue) item)
86 gilbert 1.15 "Append the item at the end of the queue. Does event compression."
87 gilbert 1.5 (with-lock-held ((event-queue-lock eq))
88 gilbert 1.15 (cond
89     ;; Motion Event Compression
90     ;;
91     ;; . find the (at most one) motion event
92     ;; . delete it
93     ;; . append item to queue
94     ;;
95     ;; But leave enter/exit events.
96     ;;
97     ((and (typep item 'pointer-motion-event)
98     (not (typep item 'pointer-boundary-event)))
99     (let ((sheet (event-sheet item)))
100     (labels ((fun (xs)
101     (cond ((null xs)
102     (setf (event-queue-tail eq) (cons item nil)) )
103     ((and (typep (car xs) 'pointer-motion-event)
104     (not (typep (car xs) 'pointer-boundary-event))
105     (eq (event-sheet (car xs)) sheet))
106     ;; delete this
107     (fun (cdr xs)))
108     (t
109     (setf (cdr xs) (fun (cdr xs)))
110     xs))))
111     (setf (event-queue-head eq) (fun (event-queue-head eq))))))
112     ;;
113     ;; Repaint event compression
114     ;;
115     ((typep item 'window-repaint-event)
116     (let ((region (window-event-native-region item))
117     (sheet (event-sheet item))
118     (did-something-p nil))
119     (labels ((fun (xs)
120     (cond ((null xs)
121     ;; We reached the queue's tail: Append the new event, construct a new
122     ;; one if necessary.
123     (when did-something-p
124     (setf item
125     (make-instance 'window-repaint-event
126     :timestamp (event-timestamp item)
127     :sheet (event-sheet item)
128     :region region)))
129     (setf (event-queue-tail eq) (cons item nil)) )
130     ;;
131     ((and (typep (car xs) 'window-repaint-event)
132     (eq (event-sheet (car xs)) sheet))
133     ;; This is a repaint event for the same sheet, delete it and combine
134     ;; its region into the new event.
135     (setf region
136     (region-union region (window-event-native-region (car xs))))
137     ;; Here is an alternative, which just takes the bounding rectangle.
138     ;; NOTE: When doing this also take care that the new region really
139     ;; is cleared.
140     ;; (setf region
141     ;; (let ((old-region (window-event-native-region (car xs))))
142     ;; (make-rectangle*
143     ;; (min (bounding-rectangle-min-x region)
144     ;; (bounding-rectangle-min-x old-region))
145     ;; (min (bounding-rectangle-min-y region)
146     ;; (bounding-rectangle-min-y old-region))
147     ;; (max (bounding-rectangle-max-x region)
148     ;; (bounding-rectangle-max-x old-region))
149     ;; (max (bounding-rectangle-max-y region)
150     ;; (bounding-rectangle-max-y old-region)))))
151     (setf did-something-p t)
152     (fun (cdr xs)))
153     ;;
154     (t
155     (setf (cdr xs) (fun (cdr xs)))
156     xs))))
157     (setf (event-queue-head eq) (fun (event-queue-head eq))))))
158     ;; Regular events are just appended:
159     (t
160     (cond ((null (event-queue-tail eq))
161     (setf (event-queue-head eq) (cons item nil)
162     (event-queue-tail eq) (event-queue-head eq)))
163     (t
164     (setf (event-queue-tail eq)
165     (setf (cdr (event-queue-tail eq)) (cons item nil)))))))))
166 gilbert 1.5
167     (defmethod event-queue-prepend ((eq standard-event-queue) item)
168     "Prepend the item to the beginning of the queue."
169     (with-lock-held ((event-queue-lock eq))
170     (cond ((null (event-queue-tail eq))
171     (setf (event-queue-head eq) (cons item nil)
172     (event-queue-tail eq) (event-queue-head eq)))
173     (t
174     (push item (event-queue-head eq))))))
175    
176 mikemac 1.7 (defmethod event-queue-peek ((eq standard-event-queue))
177     (with-lock-held ((event-queue-lock eq))
178     (first (event-queue-head eq))))
179    
180 gilbert 1.5 (defmethod event-queue-peek-if (predicate (eq standard-event-queue))
181 gilbert 1.15 "Goes thru the whole event queue and returns the first event, which
182 gilbert 1.5 satisfies 'predicate' and leaves the event in the queue.
183     Returns NIL, if there is no such event."
184     (with-lock-held ((event-queue-lock eq))
185     (find-if predicate (event-queue-head eq))))
186    
187     (defmethod event-queue-listen ((eq standard-event-queue))
188     (not (null (event-queue-head eq))))
189    
190 moore 1.8 (defmethod event-queue-listen-or-wait ((eq standard-event-queue) &key timeout)
191     (or (not (null (event-queue-peek eq)))
192     (flet ((pred ()
193     (not (null (event-queue-head eq)))))
194     (if timeout
195     (process-wait-with-timeout "Listening for event" timeout #'pred)
196 moore 1.16 (progn
197     (process-wait "Listening for event" #'pred)
198     t)))))
199 moore 1.8
200    
201 gilbert 1.5 ;; STANDARD-SHEET-INPUT-MIXIN
202    
203 mikemac 1.1 (defclass standard-sheet-input-mixin ()
204 mikemac 1.7 ((queue :initform (make-instance 'standard-event-queue)
205 moore 1.14 :reader sheet-event-queue
206     :initarg :input-buffer)
207 mikemac 1.1 (port :initform nil
208     :initarg :port
209 moore 1.14 :reader port)))
210 mikemac 1.1
211 mikemac 1.7 (defmethod stream-input-buffer ((stream standard-sheet-input-mixin))
212     (sheet-event-queue stream))
213    
214 moore 1.14 (defmethod (setf stream-input-buffer) (new-val
215     (stream standard-sheet-input-mixin))
216     (setf (slot-value stream 'queue) new-val))
217    
218 mikemac 1.7 ;(defmethod dispatch-event ((sheet standard-sheet-input-mixin) event)
219     ; (if (typep event 'device-event)
220     ; (queue-event sheet event)
221     ; (handle-event sheet event)))
222    
223 mikemac 1.1 (defmethod dispatch-event ((sheet standard-sheet-input-mixin) event)
224 moore 1.9 (queue-event sheet event))
225 mikemac 1.1
226     (defmethod queue-event ((sheet standard-sheet-input-mixin) event)
227     (with-slots (queue) sheet
228 gilbert 1.5 (event-queue-append queue event)))
229 mikemac 1.1
230     (defmethod handle-event ((sheet standard-sheet-input-mixin) event)
231 moore 1.14 ;; Standard practice is to ignore events
232 mikemac 1.1 (declare (ignore event))
233     nil)
234    
235     (defmethod event-read ((sheet standard-sheet-input-mixin))
236     (with-slots (queue) sheet
237 gilbert 1.5 (event-queue-read queue)))
238 boninfan 1.3
239     (defmethod event-read-with-timeout ((sheet standard-sheet-input-mixin)
240     &key (timeout nil) (wait-function nil))
241 gilbert 1.5 ;; This one is not in the spec ;-( --GB
242 boninfan 1.3 (with-slots (queue) sheet
243 gilbert 1.13 (event-queue-read-with-timeout queue timeout wait-function)))
244 mikemac 1.1
245     (defmethod event-read-no-hang ((sheet standard-sheet-input-mixin))
246     (with-slots (queue) sheet
247 gilbert 1.5 (event-queue-read-no-hang queue)))
248 mikemac 1.1
249     (defmethod event-peek ((sheet standard-sheet-input-mixin) &optional event-type)
250     (with-slots (queue) sheet
251     (if event-type
252 gilbert 1.5 (event-queue-peek-if (lambda (x)
253     (typep x event-type))
254     queue)
255     (event-queue-peek-if (lambda (x) (declare (ignore x)) t)
256     queue))))
257 mikemac 1.1
258     (defmethod event-unread ((sheet standard-sheet-input-mixin) event)
259     (with-slots (queue) sheet
260 gilbert 1.5 (event-queue-prepend queue event)))
261 mikemac 1.1
262     (defmethod event-listen ((sheet standard-sheet-input-mixin))
263     (with-slots (queue) sheet
264 gilbert 1.5 (event-queue-listen queue)))
265    
266     ;;;;
267 mikemac 1.1
268 moore 1.14 ;;; Support for callers that want to set an event queue for every pane.
269    
270     (defclass no-event-queue-mixin ()
271     ())
272    
273     (defmethod initialize-instance :after ((obj no-event-queue-mixin)
274     &key input-buffer)
275     (declare (ignore input-buffer))
276     nil)
277    
278     (defmethod (setf stream-input-buffer) (new-val (stream no-event-queue-mixin))
279     new-val)
280    
281     (defclass immediate-sheet-input-mixin (no-event-queue-mixin)
282 moore 1.9 ())
283 mikemac 1.1
284     (defmethod dispatch-event ((sheet immediate-sheet-input-mixin) event)
285     (handle-event sheet event))
286    
287 moore 1.11 (defmethod handle-event ((sheet immediate-sheet-input-mixin) event)
288     (declare (ignore event))
289     nil)
290    
291 mikemac 1.1 (define-condition sheet-is-mute-for-input (error)
292 moore 1.14 ())
293 mikemac 1.1
294 moore 1.14 (defclass sheet-mute-input-mixin (no-event-queue-mixin)
295     ())
296 mikemac 1.1
297 rouanet 1.4 (defmethod dispatch-event ((sheet sheet-mute-input-mixin) event)
298 mikemac 1.1 (declare (ignore event))
299     (error 'sheet-is-mute-for-input))
300    
301 rouanet 1.4 (defmethod queue-event ((sheet sheet-mute-input-mixin) event)
302 mikemac 1.1 (declare (ignore event))
303     (error 'sheet-is-mute-for-input))
304    
305 rouanet 1.4 (defmethod handle-event ((sheet sheet-mute-input-mixin) event)
306 mikemac 1.1 (declare (ignore event))
307     (error 'sheet-is-mute-for-input))
308    
309 rouanet 1.4 (defmethod event-read ((sheet sheet-mute-input-mixin))
310 mikemac 1.1 (error 'sheet-is-mute-for-input))
311    
312 rouanet 1.4 (defmethod event-read-with-timeout ((sheet sheet-mute-input-mixin)
313 boninfan 1.3 &key (timeout nil) (wait-function nil))
314     (declare (ignore timeout wait-function))
315     (error 'sheet-is-mute-for-input))
316    
317 rouanet 1.4 (defmethod event-read-no-hang ((sheet sheet-mute-input-mixin))
318 mikemac 1.1 (error 'sheet-is-mute-for-input))
319    
320 rouanet 1.4 (defmethod event-peek ((sheet sheet-mute-input-mixin) &optional event-type)
321 mikemac 1.1 (declare (ignore event-type))
322     (error 'sheet-is-mute-for-input))
323    
324 rouanet 1.4 (defmethod event-unread ((sheet sheet-mute-input-mixin) event)
325 mikemac 1.1 (declare (ignore event))
326     (error 'sheet-is-mute-for-input))
327    
328 rouanet 1.4 (defmethod event-listen ((sheet sheet-mute-input-mixin))
329 mikemac 1.1 (error 'sheet-is-mute-for-input))
330    
331 gilbert 1.5 ;;;;
332    
333 mikemac 1.1 (defclass delegate-sheet-input-mixin ()
334     ((delegate :initform nil
335     :initarg :delegate
336 gilbert 1.5 :accessor delegate-sheet-delegate) ))
337 moore 1.14
338     ;;; Don't know if this event queue stuff is completely right, or if it matters
339     ;;; much...
340    
341     (defmethod initialize-instance :after ((obj delegate-sheet-input-mixin)
342     &key input-buffer)
343     (declare (ignore input-buffer)))
344    
345     (defmethod stream-input-buffer ((stream delegate-sheet-input-mixin))
346     (sheet-event-queue (delegate-sheet-delegate stream)))
347    
348     (defmethod (setf stream-input-buffer) (new-val
349     (stream delegate-sheet-input-mixin))
350     (setf (stream-input-buffer (delegate-sheet-delegate stream)) new-val))
351 mikemac 1.1
352     (defmethod dispatch-event ((sheet delegate-sheet-input-mixin) event)
353     (dispatch-event (delegate-sheet-delegate sheet) event))
354    
355     (defmethod queue-event ((sheet delegate-sheet-input-mixin) event)
356     (queue-event (delegate-sheet-delegate sheet) event))
357    
358     (defmethod handle-event ((sheet delegate-sheet-input-mixin) event)
359     (handle-event (delegate-sheet-delegate sheet) event))
360    
361     (defmethod event-read ((sheet delegate-sheet-input-mixin))
362     (event-read (delegate-sheet-delegate sheet)))
363 boninfan 1.3
364     (defmethod event-read-with-timeout ((sheet delegate-sheet-input-mixin)
365     &key (timeout nil) (wait-function nil))
366     (event-read-with-timeout (delegate-sheet-delegate sheet)
367     :timeout timeout :wait-function wait-function))
368 mikemac 1.1
369     (defmethod event-read-no-hang ((sheet delegate-sheet-input-mixin))
370     (event-read-no-hang (delegate-sheet-delegate sheet)))
371    
372     (defmethod event-peek ((sheet delegate-sheet-input-mixin) &optional event-type)
373     (event-peek (delegate-sheet-delegate sheet) event-type))
374    
375     (defmethod event-unread ((sheet delegate-sheet-input-mixin) event)
376     (event-unread (delegate-sheet-delegate sheet) event))
377    
378     (defmethod event-listen ((sheet delegate-sheet-input-mixin))
379     (event-listen (delegate-sheet-delegate sheet)))
380 moore 1.9
381     ;;; Class actually used by panes.
382    
383     (defclass clim-sheet-input-mixin (#+clim-mp standard-sheet-input-mixin #-clim-mp immediate-sheet-input-mixin)
384     ())
385 adejneka 1.17
386     ;;;
387     (defmacro tracking-pointer
388     ((sheet &rest args
389     &key pointer multiple-window transformp context-type highlight)
390     &body body)
391     (declare (ignorable pointer multiple-window transformp context-type highlight))
392     (when (eq sheet 't)
393     (setq sheet '*standard-output*))
394     (check-type sheet symbol)
395     (loop for event-name in '(:pointer-motion
396     :presentation
397     :pointer-button-press
398     :presentation-button-press
399     :pointer-button-release
400     :presentation-button-release
401     :keyboard)
402     for handler-name = (gensym (symbol-name event-name))
403     collect `(,handler-name ,@ (or (cdr (assoc event-name body))
404     '((&rest args) (declare (ignore args)))))
405     into bindings
406     collect `#',handler-name into handler-names
407     finally
408     (return `(flet ,bindings
409     (declare (dynamic-extent ,@handler-names))
410     (invoke-tracking-pointer ,sheet ,@handler-names
411     ,@args)))))
412    
413     (defun invoke-tracking-pointer
414     (sheet
415     pointer-motion-handler presentation-handler
416     pointer-button-press-handler presentation-button-press-handler
417     pointer-button-release-handler presentation-button-release-handler
418     keyboard-handler
419     &key pointer multiple-window transformp context-type highlight)
420     ;; (setq pointer (port-pointer sheet))
421     (let ((port (port sheet)))
422     (with-method (distribute-event :around ((port (eql port)) event)
423     ;; XXX specialize on EVENT?
424     (queue-event sheet event))
425     (loop for event = (event-read sheet)
426     do (cond ((and (typep event 'pointer-event)
427     #+nil
428     (eq (pointer-event-pointer event)
429     pointer))
430     (let ((x (pointer-event-x event))
431     (y (pointer-event-y event))
432     (window (event-sheet event)))
433     ;; XXX Convert X,Y to SHEET coordinates
434     ;; XXX user coordinates
435     (typecase event
436     (pointer-motion-event
437     (funcall pointer-motion-handler
438     :window window :x x :y y))
439     (pointer-button-press-event
440     (funcall pointer-button-press-handler
441     :event event :x x :y y))
442     (pointer-button-release-event
443     (funcall pointer-button-release-handler
444     :event event :x x :y y)))))
445     ((typep event 'keyboard-event)
446     (funcall keyboard-handler
447     :gesture event #|XXX|#))
448     (t (handle-event #|XXX|# (event-sheet event) event)))))))

  ViewVC Help
Powered by ViewVC 1.1.5