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

Contents of /mcclim/pointer-tracking.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.11 - (show annotations)
Sat Jul 24 15:07:50 2004 UTC (9 years, 9 months ago) by moore
Branch: MAIN
Changes since 1.10: +1 -1 lines
Change invoke-with-new-output-record and invoke-with-output-to-output-record
to take a constructor argument, as per the Franz CLIM user
manual. This permits one to call make-instance with a constant class
argument, which can be a big win in some
implementations. Change with-new-output-record and friends to use
this new form. This change requires a recompile of user code.

Change stream-write-output to take a width argument. If the width of
the string is already available (and it usually is), this saves an
extra call to the expensive function stream-string-width.
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))
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
100 (defun invoke-tracking-pointer-loop (frame sheet &rest args)
101 (apply #'tracking-pointer-loop
102 (make-tracking-pointer-state frame sheet args)
103 frame sheet args))
104
105 (defun default-tracking-handler (&rest args)
106 (declare (ignore args))
107 nil)
108
109 (defclass tracking-pointer-state ()
110 ((motion-handler :reader motion-handler :initarg :pointer-motion)
111 (button-press-handler :reader button-press-handler
112 :initarg :pointer-button-press)
113 (buttton-release-handler :reader button-release-handler
114 :initarg :pointer-button-release)
115 (keyboard-handler :reader keyboard-handler :initarg :keyboard))
116 (:default-initargs :pointer-motion #'default-tracking-handler
117 :pointer-button-press #'default-tracking-handler
118 :pointer-button-release #'default-tracking-handler
119 :keyboard #'default-tracking-handler))
120
121
122 (defmethod tracking-pointer-loop
123 ((state tracking-pointer-state) frame sheet &rest args
124 &key pointer multiple-window transformp context-type highlight)
125 (declare (ignore pointer context-type highlight frame))
126 (with-sheet-medium (medium sheet)
127 (flet ((do-tracking ()
128 (loop
129 for event = (event-read sheet)
130 do (if (typep event 'pointer-event)
131 (multiple-value-bind (sheet-x sheet-y)
132 (pointer-event-position* event)
133 (multiple-value-bind (x y)
134 (if transformp
135 (transform-position
136 (medium-transformation medium)
137 sheet-x
138 sheet-y)
139 (values sheet-x sheet-y))
140 (tracking-pointer-loop-step state event x y)))
141 (tracking-pointer-loop-step state event 0 0)))))
142 (if multiple-window
143 (with-pointer-grabbed ((port medium) sheet)
144 (do-tracking))
145 (do-tracking)))))
146
147 (defmethod tracking-pointer-loop-step
148 ((state tracking-pointer-state) (event pointer-motion-event) x y)
149 (funcall (motion-handler state) :window (event-sheet event) :x x :y y))
150
151 (defmethod tracking-pointer-loop-step
152 ((state tracking-pointer-state) (event pointer-button-press-event) x y)
153 (funcall (button-press-handler state)
154 :event event :window (event-sheet event) :x x :y y))
155
156 (defmethod tracking-pointer-loop-step
157 ((state tracking-pointer-state) (event pointer-button-release-event) x y)
158 (funcall (button-release-handler state)
159 :event event :window (event-sheet event) :x x :y y))
160
161 (defmethod tracking-pointer-loop-step
162 ((state tracking-pointer-state) (event t) x y)
163 (declare (ignore x y))
164 (if (typep event '(or keyboard-event character symbol))
165 (funcall (keyboard-handler state) :gesture event)
166 (handle-event (event-sheet event) event)))
167
168
169 ;;; DRAG-OUTPUT-RECORD and DRAGGING-OUTPUT.
170 ;;;
171 ;;; XXX Unresolved issues:
172 ;;; multiple-window is completely unsupported.
173 ;;; window-repaint events while dragging.
174
175 (defgeneric drag-output-record
176 (stream output
177 &key repaint erase feedback finish-on-release multiple-window))
178
179 (defmethod drag-output-record
180 ((stream output-recording-stream) (record output-record)
181 &key (repaint t) (erase #'erase-output-record)
182 feedback finish-on-release multiple-window
183 feedback-event)
184 (declare (ignore repaint multiple-window))
185 (multiple-value-bind (dx dy)
186 (output-record-position record)
187 (flet ((feedback-fn (record stream initial-x initial-y x y action)
188 (declare (ignore initial-x initial-y))
189 (if (eq action :erase)
190 (funcall erase record stream)
191 (progn
192 (setf (output-record-position record)
193 (values (+ dx x) (+ dy y)))
194 (stream-add-output-record stream record)
195 (stream-replay stream record))))
196 (feedback-event-fn (record stream initial-x initial-y x y
197 action event)
198 (declare (ignore event))
199 (when (or (eq action :draw) (eq action :erase))
200 (funcall feedback record stream initial-x initial-y x y
201 action))))
202 (declare (dynamic-extent #'feedback-fn #'feedback-event-fn))
203 (unless feedback
204 (setq feedback #'feedback-fn))
205 (unless feedback-event
206 (setq feedback-event #'feedback-event-fn))
207 (setf (stream-current-output-record stream)
208 (stream-output-history stream))
209 (let* ((pointer (port-pointer (port stream)))
210 (pointer-state (pointer-button-state pointer)))
211 (multiple-value-bind (x0 y0)
212 (stream-pointer-position stream)
213 (funcall feedback-event record stream x0 y0 x0 y0 :draw nil)
214 (tracking-pointer (stream)
215 (:pointer-motion (&key event x y)
216 ;; XXX What about the sheet?
217 (funcall feedback-event record stream x0 y0 x y :erase event)
218 (funcall feedback-event record stream x0 y0 x y :draw event))
219 (:pointer-button-press (&key event x y)
220 (funcall feedback-event record stream x0 y0 x y
221 :button-press event)
222 (unless finish-on-release
223 (return-from drag-output-record (values x y))))
224 (:pointer-button-release (&key event x y)
225 ;; If the button released was one of those held down on entry to
226 ;; drag-output-record, we're done.
227 (when (and finish-on-release
228 (not (zerop (logand pointer-state
229 (pointer-event-button event)))))
230 (funcall feedback-event record stream x0 y0 x y
231 :button-release event)
232 (return-from drag-output-record (values x y))))))))))
233
234 (defmacro dragging-output ((&optional (stream '*standard-output*) &rest args
235 &key repaint finish-on-release multiple-window)
236 &body body)
237 (declare (ignore repaint finish-on-release multiple-window))
238 (setq stream (stream-designator-symbol stream))
239 (with-gensyms (record)
240 `(let ((,record (with-output-to-output-record (,stream)
241 ,@body)))
242 (multiple-value-prog1
243 (drag-output-record ,stream ,record ,@args)
244 (erase-output-record ,record ,stream)))))
245

  ViewVC Help
Powered by ViewVC 1.1.5