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

Contents of /mcclim/pointer-tracking.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.14 - (show annotations)
Mon Oct 18 06:10:14 2004 UTC (9 years, 6 months ago) by hefner1
Branch: MAIN
Changes since 1.13: +4 -4 lines
Workaround initialize-instance bug in CMUCL 18e via reader conditional.
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) :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 (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 (setq stream (stream-designator-symbol stream '*standard-output*))
240 (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

  ViewVC Help
Powered by ViewVC 1.1.5