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

Contents of /mcclim/pointer-tracking.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1 - (hide annotations)
Fri Aug 2 11:59:09 2002 UTC (11 years, 8 months ago) by adejneka
Branch: MAIN
* Moved TRACKING-POINTER to a separate file.

* Added tracking of presentations.
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     (in-package :CLIM-INTERNALS)
33    
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     for event-name in '(:pointer-motion
45     :presentation
46     :pointer-button-press
47     :presentation-button-press
48     :pointer-button-release
49     :presentation-button-release
50     :keyboard)
51     for handler-body = (cdr (assoc event-name body))
52     for handler-name = (if handler-body
53     (gensym (symbol-name event-name))
54     nil)
55     when handler-body collect `(,handler-name ,@handler-body) into bindings
56     and collect `#',handler-name into handler-names
57     collect (if handler-name `#',handler-name nil) into handlers
58     finally
59     (return `(flet ,bindings
60     (declare (dynamic-extent ,@handler-names))
61     (invoke-tracking-pointer ,sheet ,@handlers
62     ,@args)))))
63    
64     (defun invoke-tracking-pointer
65     (sheet
66     pointer-motion-handler presentation-handler
67     pointer-button-press-handler presentation-button-press-handler
68     pointer-button-release-handler presentation-button-release-handler
69     keyboard-handler
70     &key pointer multiple-window transformp (context-type t)
71     (highlight nil highlight-p))
72     ;; (setq pointer (port-pointer (port sheet))) ; FIXME
73     (let ((port (port sheet))
74     (presentations-p (or presentation-handler
75     presentation-button-press-handler
76     presentation-button-release-handler)))
77     (unless highlight-p (setq highlight presentations-p))
78     (with-method (distribute-event :around ((port (eql port)) event)
79     ;; XXX specialize on EVENT?
80     ;; :SUPER-AROUND?
81     (queue-event sheet event))
82     (with-input-context (context-type :override t) ()
83     (loop for event = (event-read sheet)
84     do (cond ((and (typep event 'pointer-event)
85     #+nil
86     (eq (pointer-event-pointer event)
87     pointer))
88     (let* ((x (pointer-event-x event))
89     (y (pointer-event-y event))
90     (window (event-sheet event))
91     (presentation (and presentations-p
92     (find-innermost-applicable-presentation
93     *input-context*
94     sheet ; XXX
95     x y
96     :modifier-state (event-modifier-state event)))))
97     (when presentation
98     (print presentation *debug-io*))
99     (when (and highlight presentation)
100     #+nil ; FIXME
101     (highlight-applicable-presentation
102     (pane-frame sheet) #|XXX|# sheet #|XXX|# *input-context*))
103     ;; FIXME Convert X,Y to SHEET coordinates; user
104     ;; coordinates
105     (typecase event
106     (pointer-motion-event
107     (if (and presentation presentation-handler)
108     (funcall presentation-handler
109     :presentation presentation
110     :window window :x x :y y)
111     (maybe-funcall pointer-motion-handler
112     :window window :x x :y y)))
113     (pointer-button-press-event
114     (if (and presentation presentation-button-press-handler)
115     (funcall presentation-button-press-handler
116     :presentation presentation
117     :event event :x x :y y)
118     (maybe-funcall pointer-button-press-handler
119     :event event :x x :y y)))
120     (pointer-button-release-event
121     (if (and presentation presentation-button-release-handler)
122     (funcall presentation-button-release-handler
123     :presentation presentation
124     :event event :x x :y y)
125     (maybe-funcall pointer-button-release-handler
126     :event event :x x :y y))))))
127     ((typep event '(or keyboard-event character symbol))
128     (maybe-funcall keyboard-handler
129     :gesture event #|XXX|#))
130     (t (handle-event #|XXX|# (event-sheet event) event))))))))

  ViewVC Help
Powered by ViewVC 1.1.5