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

Contents of /mcclim/pointer-tracking.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.9 - (hide annotations)
Tue Apr 27 12:55:18 2004 UTC (9 years, 11 months ago) by moore
Branch: MAIN
Changes since 1.8: +92 -60 lines
Some cleanup of pointer tracking. Insert a handler to ungrab the
pointer if there is any error, with the intent of solving the
complaints of problems during pointer grabs.
1 adejneka 1.1 ;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*-
2    
3     ;;; (c) copyright 2002 by Alexey Dejneka (adejneka@comail.ru)
4    
5     ;;; This library is free software; you can redistribute it and/or
6     ;;; modify it under the terms of the GNU Library General Public
7     ;;; License as published by the Free Software Foundation; either
8     ;;; version 2 of the License, or (at your option) any later version.
9     ;;;
10     ;;; This library is distributed in the hope that it will be useful,
11     ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12     ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13     ;;; Library General Public License for more details.
14     ;;;
15     ;;; You should have received a copy of the GNU Library General Public
16     ;;; License along with this library; if not, write to the
17     ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
18     ;;; Boston, MA 02111-1307 USA.
19    
20     ;;; TODO:
21     ;;;
22     ;;; - Keyboard gestures.
23     ;;;
24     ;;; - Optimization
25     ;;;
26     ;;; - - too many repeated checks within a loop;
27     ;;;
28     ;;; - - remove invoke-tracking-pointer; remove unnecessary checks.
29    
30 mikemac 1.3 (in-package :clim-internals)
31 adejneka 1.1
32 moore 1.6 ;;; The Spec specifies the tracking-pointer clause arguments as, e.g.,
33     ;;; (&key presentation event x y), implying that the user must write
34     ;;; the &key keyword, but real code doesn't do that. Check if &key is in
35     ;;; the arg list and add it if it is not.
36     (eval-when (:compile-toplevel :load-toplevel :execute)
37     (defun fix-tracking-pointer-args (args)
38     (unless (member '&allow-other-keys args)
39     (setq args (append args '(&allow-other-keys))))
40 hefner1 1.7 (if (eq (car args) '&key)
41     args
42     (cons '&key args))))
43 moore 1.6
44    
45 adejneka 1.1 (defmacro tracking-pointer
46     ((sheet &rest args
47     &key pointer multiple-window transformp context-type
48     (highlight nil highlight-p))
49     &body body)
50 hefner1 1.8 (declare (ignorable pointer transformp context-type highlight))
51 adejneka 1.1 (when (eq sheet 't)
52     (setq sheet '*standard-output*))
53     (check-type sheet symbol)
54     (loop
55 moore 1.2 with motion-events = (assoc :pointer-motion body)
56 adejneka 1.1 for event-name in '(:pointer-motion
57     :presentation
58     :pointer-button-press
59     :presentation-button-press
60     :pointer-button-release
61     :presentation-button-release
62     :keyboard)
63 moore 1.6 for (handler-args . handler-body) = (cdr (assoc event-name body))
64 adejneka 1.1 for handler-name = (if handler-body
65     (gensym (symbol-name event-name))
66     nil)
67 moore 1.6 when handler-body collect `(,handler-name ,(fix-tracking-pointer-args
68     handler-args)
69     ,@handler-body) into bindings
70 adejneka 1.1 and collect `#',handler-name into handler-names
71     collect (if handler-name `#',handler-name nil) into handlers
72     finally
73     (return `(flet ,bindings
74     (declare (dynamic-extent ,@handler-names))
75 moore 1.2 ,(if motion-events
76     `(letf (((sheet-motion-hints ,sheet) nil))
77     (invoke-tracking-pointer ,sheet ,@handlers ,@args))
78     `(invoke-tracking-pointer ,sheet ,@handlers ,@args))))))
79    
80 adejneka 1.1
81 moore 1.9 (defmacro with-pointer-grabbed ((port sheet &key pointer) &body body)
82     (with-gensyms (the-port the-sheet the-pointer grabbed)
83     `(let* ((,the-port ,port)
84     (,the-sheet ,sheet)
85     (,the-pointer (or ,pointer (port-pointer ,the-port)))
86     (,grabbed nil))
87     ;; Don't end up in the debugger with the pointer grabbed!
88     (handler-bind ((error #'(lambda (c)
89     (declare (ignore c))
90     (when ,grabbed
91     (port-ungrab-pointer ,the-port
92     ,the-pointer
93     ,the-sheet)
94     (setq ,grabbed nil)))))
95     (unwind-protect
96     (when (port-grab-pointer ,the-port ,the-pointer ,the-sheet)
97     (setq ,grabbed t)
98     ,@body)
99     (when ,grabbed
100     (port-ungrab-pointer ,the-port ,the-pointer ,the-sheet)))))))
101    
102    
103    
104 adejneka 1.1 (defun invoke-tracking-pointer
105     (sheet
106     pointer-motion-handler presentation-handler
107     pointer-button-press-handler presentation-button-press-handler
108     pointer-button-release-handler presentation-button-release-handler
109     keyboard-handler
110     &key pointer multiple-window transformp (context-type t)
111     (highlight nil highlight-p))
112     ;; (setq pointer (port-pointer (port sheet))) ; FIXME
113 hefner1 1.5 (let ((port (port sheet))
114 adejneka 1.1 (presentations-p (or presentation-handler
115     presentation-button-press-handler
116     presentation-button-release-handler)))
117     (unless highlight-p (setq highlight presentations-p))
118 hefner1 1.8 (with-sheet-medium (medium sheet)
119 moore 1.9 (flet ((do-tracking ()
120     (with-input-context (context-type :override t)
121     ()
122     (loop
123     (let ((event (event-read sheet)))
124     (when (and (eq sheet (event-sheet event))
125     (typep event 'pointer-motion-event))
126     (queue-event sheet event)
127     (highlight-applicable-presentation
128     (pane-frame sheet) sheet *input-context*))
129     (cond ((and (typep event 'pointer-event)
130     #+nil
131     (eq (pointer-event-pointer event)
132     pointer))
133     (let* ((x (pointer-event-x event))
134     (y (pointer-event-y event))
135     (window (event-sheet event))
136     (presentation
137     (and presentations-p
138     (find-innermost-applicable-presentation
139     *input-context*
140     sheet ; XXX
141     x y
142     :modifier-state (event-modifier-state event)))))
143     (when (and highlight presentation)
144     (frame-highlight-at-position
145     (pane-frame sheet) window x y))
146     ;; FIXME Convert X,Y to SHEET coordinates; user
147     ;; coordinates
148     (typecase event
149     (pointer-motion-event
150     (if (and presentation presentation-handler)
151     (funcall presentation-handler
152     :presentation presentation
153     :window window :x x :y y)
154     (maybe-funcall
155     pointer-motion-handler
156     :window window :x x :y y)))
157     (pointer-button-press-event
158     (if (and presentation
159     presentation-button-press-handler)
160     (funcall
161     presentation-button-press-handler
162     :presentation presentation
163     :event event :x x :y y)
164     (maybe-funcall
165     pointer-button-press-handler
166     :event event :x x :y y)))
167     (pointer-button-release-event
168     (if (and presentation
169     presentation-button-release-handler)
170     (funcall
171     presentation-button-release-handler
172     :presentation presentation
173     :event event :x x :y y)
174     (maybe-funcall
175     pointer-button-release-handler
176     :event event :x x :y y))))))
177     ((typep event
178     '(or keyboard-event character symbol))
179     (maybe-funcall keyboard-handler
180     :gesture event #|XXX|#))
181     (t (handle-event #|XXX|# (event-sheet event)
182     event))))))))
183     (if multiple-window
184     (with-pointer-grabbed ((port medium) sheet)
185     (do-tracking))
186     (do-tracking))
187     ))))
188 hefner1 1.8

  ViewVC Help
Powered by ViewVC 1.1.5