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

Contents of /mcclim/pointer-tracking.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.7 - (hide annotations)
Mon Nov 10 08:32:52 2003 UTC (10 years, 5 months ago) by hefner1
Branch: MAIN
CVS Tags: McCLIM-0-9
Changes since 1.6: +3 -2 lines
fix-tracking-pointer-args was not returning the arglist if args was already
preceded by &key, breaking menu-choose-from-drawer.
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     ;;; - Single/multiple window tracking.
23     ;;;
24     ;;; - Keyboard gestures.
25     ;;;
26     ;;; - Optimization
27     ;;;
28     ;;; - - too many repeated checks within a loop;
29     ;;;
30     ;;; - - remove invoke-tracking-pointer; remove unnecessary checks.
31    
32 mikemac 1.3 (in-package :clim-internals)
33 adejneka 1.1
34 moore 1.6 ;;; The Spec specifies the tracking-pointer clause arguments as, e.g.,
35     ;;; (&key presentation event x y), implying that the user must write
36     ;;; the &key keyword, but real code doesn't do that. Check if &key is in
37     ;;; the arg list and add it if it is not.
38     (eval-when (:compile-toplevel :load-toplevel :execute)
39     (defun fix-tracking-pointer-args (args)
40     (unless (member '&allow-other-keys args)
41     (setq args (append args '(&allow-other-keys))))
42 hefner1 1.7 (if (eq (car args) '&key)
43     args
44     (cons '&key args))))
45 moore 1.6
46    
47 adejneka 1.1 (defmacro tracking-pointer
48     ((sheet &rest args
49     &key pointer multiple-window transformp context-type
50     (highlight nil highlight-p))
51     &body body)
52     (declare (ignorable pointer multiple-window transformp context-type highlight))
53     (when (eq sheet 't)
54     (setq sheet '*standard-output*))
55     (check-type sheet symbol)
56     (loop
57 moore 1.2 with motion-events = (assoc :pointer-motion body)
58 adejneka 1.1 for event-name in '(:pointer-motion
59     :presentation
60     :pointer-button-press
61     :presentation-button-press
62     :pointer-button-release
63     :presentation-button-release
64     :keyboard)
65 moore 1.6 for (handler-args . handler-body) = (cdr (assoc event-name body))
66 adejneka 1.1 for handler-name = (if handler-body
67     (gensym (symbol-name event-name))
68     nil)
69 moore 1.6 when handler-body collect `(,handler-name ,(fix-tracking-pointer-args
70     handler-args)
71     ,@handler-body) into bindings
72 adejneka 1.1 and collect `#',handler-name into handler-names
73     collect (if handler-name `#',handler-name nil) into handlers
74     finally
75     (return `(flet ,bindings
76     (declare (dynamic-extent ,@handler-names))
77 moore 1.2 ,(if motion-events
78     `(letf (((sheet-motion-hints ,sheet) nil))
79     (invoke-tracking-pointer ,sheet ,@handlers ,@args))
80     `(invoke-tracking-pointer ,sheet ,@handlers ,@args))))))
81    
82 adejneka 1.1
83     (defun invoke-tracking-pointer
84     (sheet
85     pointer-motion-handler presentation-handler
86     pointer-button-press-handler presentation-button-press-handler
87     pointer-button-release-handler presentation-button-release-handler
88     keyboard-handler
89     &key pointer multiple-window transformp (context-type t)
90     (highlight nil highlight-p))
91     ;; (setq pointer (port-pointer (port sheet))) ; FIXME
92 hefner1 1.5 (let ((port (port sheet))
93 adejneka 1.1 (presentations-p (or presentation-handler
94     presentation-button-press-handler
95     presentation-button-release-handler)))
96     (unless highlight-p (setq highlight presentations-p))
97     (with-method (distribute-event :around ((port (eql port)) event)
98     ;; XXX specialize on EVENT?
99     ;; :SUPER-AROUND?
100     (queue-event sheet event))
101 hefner1 1.5 (with-input-context (context-type :override t) ()
102     (loop
103     (let ((event (event-read sheet)))
104     (when (and (eq sheet (event-sheet event))
105     (typep event 'pointer-motion-event))
106     (queue-event sheet event)
107     (highlight-applicable-presentation (pane-frame sheet) sheet *input-context*))
108     (cond ((and (typep event 'pointer-event)
109 adejneka 1.1 #+nil
110     (eq (pointer-event-pointer event)
111 hefner1 1.5 pointer))
112 adejneka 1.1 (let* ((x (pointer-event-x event))
113     (y (pointer-event-y event))
114     (window (event-sheet event))
115     (presentation (and presentations-p
116     (find-innermost-applicable-presentation
117     *input-context*
118     sheet ; XXX
119     x y
120     :modifier-state (event-modifier-state event)))))
121     (when (and highlight presentation)
122 hefner1 1.5 (frame-highlight-at-position (pane-frame sheet) window x y))
123 adejneka 1.1 ;; FIXME Convert X,Y to SHEET coordinates; user
124     ;; coordinates
125     (typecase event
126     (pointer-motion-event
127     (if (and presentation presentation-handler)
128     (funcall presentation-handler
129     :presentation presentation
130     :window window :x x :y y)
131     (maybe-funcall pointer-motion-handler
132     :window window :x x :y y)))
133     (pointer-button-press-event
134     (if (and presentation presentation-button-press-handler)
135     (funcall presentation-button-press-handler
136     :presentation presentation
137     :event event :x x :y y)
138     (maybe-funcall pointer-button-press-handler
139     :event event :x x :y y)))
140     (pointer-button-release-event
141     (if (and presentation presentation-button-release-handler)
142     (funcall presentation-button-release-handler
143     :presentation presentation
144     :event event :x x :y y)
145     (maybe-funcall pointer-button-release-handler
146     :event event :x x :y y))))))
147     ((typep event '(or keyboard-event character symbol))
148     (maybe-funcall keyboard-handler
149     :gesture event #|XXX|#))
150 hefner1 1.5 (t (handle-event #|XXX|# (event-sheet event) event)))))))))

  ViewVC Help
Powered by ViewVC 1.1.5