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

Contents of /mcclim/pointer-tracking.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.3 - (hide annotations)
Fri Mar 21 21:36:59 2003 UTC (11 years, 1 month ago) by mikemac
Branch: MAIN
Changes since 1.2: +1 -1 lines
make all of the package names passed to in-package be lowercase keywords for ACL's java mode
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     (defmacro tracking-pointer
35     ((sheet &rest args
36     &key pointer multiple-window transformp context-type
37     (highlight nil highlight-p))
38     &body body)
39     (declare (ignorable pointer multiple-window transformp context-type highlight))
40     (when (eq sheet 't)
41     (setq sheet '*standard-output*))
42     (check-type sheet symbol)
43     (loop
44 moore 1.2 with motion-events = (assoc :pointer-motion body)
45 adejneka 1.1 for event-name in '(:pointer-motion
46     :presentation
47     :pointer-button-press
48     :presentation-button-press
49     :pointer-button-release
50     :presentation-button-release
51     :keyboard)
52     for handler-body = (cdr (assoc event-name body))
53     for handler-name = (if handler-body
54     (gensym (symbol-name event-name))
55     nil)
56     when handler-body collect `(,handler-name ,@handler-body) into bindings
57     and collect `#',handler-name into handler-names
58     collect (if handler-name `#',handler-name nil) into handlers
59     finally
60     (return `(flet ,bindings
61     (declare (dynamic-extent ,@handler-names))
62 moore 1.2 ,(if motion-events
63     `(letf (((sheet-motion-hints ,sheet) nil))
64     (invoke-tracking-pointer ,sheet ,@handlers ,@args))
65     `(invoke-tracking-pointer ,sheet ,@handlers ,@args))))))
66    
67 adejneka 1.1
68     (defun invoke-tracking-pointer
69     (sheet
70     pointer-motion-handler presentation-handler
71     pointer-button-press-handler presentation-button-press-handler
72     pointer-button-release-handler presentation-button-release-handler
73     keyboard-handler
74     &key pointer multiple-window transformp (context-type t)
75     (highlight nil highlight-p))
76     ;; (setq pointer (port-pointer (port sheet))) ; FIXME
77     (let ((port (port sheet))
78     (presentations-p (or presentation-handler
79     presentation-button-press-handler
80     presentation-button-release-handler)))
81     (unless highlight-p (setq highlight presentations-p))
82     (with-method (distribute-event :around ((port (eql port)) event)
83     ;; XXX specialize on EVENT?
84     ;; :SUPER-AROUND?
85     (queue-event sheet event))
86     (with-input-context (context-type :override t) ()
87     (loop for event = (event-read sheet)
88     do (cond ((and (typep event 'pointer-event)
89     #+nil
90     (eq (pointer-event-pointer event)
91     pointer))
92     (let* ((x (pointer-event-x event))
93     (y (pointer-event-y event))
94     (window (event-sheet event))
95     (presentation (and presentations-p
96     (find-innermost-applicable-presentation
97     *input-context*
98     sheet ; XXX
99     x y
100     :modifier-state (event-modifier-state event)))))
101     (when presentation
102     (print presentation *debug-io*))
103     (when (and highlight presentation)
104     #+nil ; FIXME
105     (highlight-applicable-presentation
106     (pane-frame sheet) #|XXX|# sheet #|XXX|# *input-context*))
107     ;; FIXME Convert X,Y to SHEET coordinates; user
108     ;; coordinates
109     (typecase event
110     (pointer-motion-event
111     (if (and presentation presentation-handler)
112     (funcall presentation-handler
113     :presentation presentation
114     :window window :x x :y y)
115     (maybe-funcall pointer-motion-handler
116     :window window :x x :y y)))
117     (pointer-button-press-event
118     (if (and presentation presentation-button-press-handler)
119     (funcall presentation-button-press-handler
120     :presentation presentation
121     :event event :x x :y y)
122     (maybe-funcall pointer-button-press-handler
123     :event event :x x :y y)))
124     (pointer-button-release-event
125     (if (and presentation presentation-button-release-handler)
126     (funcall presentation-button-release-handler
127     :presentation presentation
128     :event event :x x :y y)
129     (maybe-funcall pointer-button-release-handler
130     :event event :x x :y y))))))
131     ((typep event '(or keyboard-event character symbol))
132     (maybe-funcall keyboard-handler
133     :gesture event #|XXX|#))
134     (t (handle-event #|XXX|# (event-sheet event) event))))))))

  ViewVC Help
Powered by ViewVC 1.1.5