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

Contents of /mcclim/pointer-tracking.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.11 - (hide 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 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     (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 moore 1.11 frame sheet args))
104 moore 1.10
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 moore 1.9 (do-tracking))
145 moore 1.10 (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 hefner1 1.8

  ViewVC Help
Powered by ViewVC 1.1.5