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

Contents of /mcclim/pointer-tracking.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.15 - (hide annotations)
Fri Nov 12 06:39:44 2004 UTC (9 years, 5 months ago) by hefner1
Branch: MAIN
Changes since 1.14: +1 -1 lines
Add support for event keyword in :pointer-motion clauses of tracking-pointer.
The specs omission of :event for just this one clause is braindead.
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     :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 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     (defgeneric drag-output-record
177     (stream output
178     &key repaint erase feedback finish-on-release multiple-window))
179    
180     (defmethod drag-output-record
181     ((stream output-recording-stream) (record output-record)
182     &key (repaint t) (erase #'erase-output-record)
183     feedback finish-on-release multiple-window
184     feedback-event)
185     (declare (ignore repaint multiple-window))
186     (multiple-value-bind (dx dy)
187     (output-record-position record)
188     (flet ((feedback-fn (record stream initial-x initial-y x y action)
189     (declare (ignore initial-x initial-y))
190     (if (eq action :erase)
191     (funcall erase record stream)
192     (progn
193     (setf (output-record-position record)
194     (values (+ dx x) (+ dy y)))
195     (stream-add-output-record stream record)
196     (stream-replay stream record))))
197     (feedback-event-fn (record stream initial-x initial-y x y
198     action event)
199     (declare (ignore event))
200     (when (or (eq action :draw) (eq action :erase))
201     (funcall feedback record stream initial-x initial-y x y
202     action))))
203     (declare (dynamic-extent #'feedback-fn #'feedback-event-fn))
204     (unless feedback
205     (setq feedback #'feedback-fn))
206     (unless feedback-event
207     (setq feedback-event #'feedback-event-fn))
208     (setf (stream-current-output-record stream)
209     (stream-output-history stream))
210     (let* ((pointer (port-pointer (port stream)))
211     (pointer-state (pointer-button-state pointer)))
212     (multiple-value-bind (x0 y0)
213     (stream-pointer-position stream)
214     (funcall feedback-event record stream x0 y0 x0 y0 :draw nil)
215     (tracking-pointer (stream)
216     (:pointer-motion (&key event x y)
217     ;; XXX What about the sheet?
218     (funcall feedback-event record stream x0 y0 x y :erase event)
219     (funcall feedback-event record stream x0 y0 x y :draw event))
220     (:pointer-button-press (&key event x y)
221     (funcall feedback-event record stream x0 y0 x y
222     :button-press event)
223     (unless finish-on-release
224     (return-from drag-output-record (values x y))))
225     (:pointer-button-release (&key event x y)
226     ;; If the button released was one of those held down on entry to
227     ;; drag-output-record, we're done.
228     (when (and finish-on-release
229     (not (zerop (logand pointer-state
230     (pointer-event-button event)))))
231     (funcall feedback-event record stream x0 y0 x y
232     :button-release event)
233     (return-from drag-output-record (values x y))))))))))
234    
235     (defmacro dragging-output ((&optional (stream '*standard-output*) &rest args
236     &key repaint finish-on-release multiple-window)
237     &body body)
238     (declare (ignore repaint finish-on-release multiple-window))
239 moore 1.12 (setq stream (stream-designator-symbol stream '*standard-output*))
240 moore 1.10 (with-gensyms (record)
241     `(let ((,record (with-output-to-output-record (,stream)
242     ,@body)))
243     (multiple-value-prog1
244     (drag-output-record ,stream ,record ,@args)
245     (erase-output-record ,record ,stream)))))
246 hefner1 1.8

  ViewVC Help
Powered by ViewVC 1.1.5