Mercurial > hg > indyvon
view src/indyvon/core.clj @ 9:160e9ec945a2
Fix dispatching of mouse motion events.
| author | Mikhail Kryshen <mikhail@kryshen.net> |
|---|---|
| date | Sun, 13 Jun 2010 02:49:09 +0400 |
| parents | c53ec3052ae7 |
| children | 9af27ccccfac |
line source
1 (ns indyvon.core
2 (:require (clojure [set :as s]))
3 (:import (java.awt Dimension Point Component Graphics2D Color AWTEvent)
4 (java.awt.event MouseEvent MouseAdapter MouseMotionAdapter
5 MouseListener MouseMotionListener)))
7 (defprotocol Layer
8 (render! [this context graphics])
9 (size [this context])
10 (anchor [this context]))
12 (defrecord LayerContext [layer parent x y width height update-fn dispatcher])
14 (defn default-context []
15 (LayerContext. nil nil 0 0 0 0 nil nil))
17 (defmacro reify-layer [& fns]
18 (let [method-map {'size [['_ '_] [0 0]]
19 'anchor [['_ '_] [0 0]]}
20 method-map (loop [fns fns
21 mm method-map]
22 (if-let [form (first fns)]
23 (recur (next fns)
24 (conj mm [(first form) (next form)]))
25 mm))
26 methods (for [m method-map]
27 (cons (first m) (second m)))]
28 `(reify Layer ~@methods)))
30 (defn- make-graphics [g x y w h clip]
31 (if clip
32 (.create g x y w h)
33 (doto (.create g)
34 (.translate x y))))
36 (defn render-layer!
37 "Render layer in a new graphics context."
38 ([context layer graphics]
39 (render-layer! context layer graphics
40 0 0 (:width context) (:height context)))
41 ([context layer graphics x y]
42 (render-layer! context layer graphics x y true))
43 ([context layer graphics x y clip]
44 (let [s (size layer context)]
45 (render-layer! context layer graphics
46 x y (s 0) (s 1) clip)))
47 ([context layer graphics x y w h]
48 (render-layer! context layer graphics
49 x y w h true))
50 ([context layer graphics x y w h clip]
51 (let [graphics (make-graphics graphics x y w h clip)]
52 (try
53 (render! layer
54 (assoc context
55 :layer layer
56 :parent context
57 :x (+ (:x context) x)
58 :y (+ (:y context) y)
59 :width w
60 :height h)
61 graphics)
62 (finally
63 (.dispose graphics))))))
65 ;;
66 ;; Event handling
67 ;;
69 (defmulti handle-layer-event
70 (fn [layer context event]
71 [layer (.getID event)]))
73 (defmethod handle-layer-event :default [layer context event])
75 (defprotocol EventDispatcher
76 (register [this context])
77 (commit [this])
78 (hovered? [this layer])
79 (picked? [this layer]))
81 (defn- registered-parent
82 "Returns first context parent registered for event processing."
83 [context-tree context]
84 (let [parent (:parent context)]
85 (cond
86 (nil? parent) nil
87 (contains? context-tree parent) parent
88 :default (recur context-tree parent))))
90 (defn- register-context
91 [context-tree context]
92 (let [parent (registered-parent context-tree context)]
93 (assoc context-tree parent (conj (context-tree parent) context)
94 context nil)))
96 (defn- inside?
97 ([x y context]
98 (inside? x y (:x context) (:y context)
99 (:width context) (:height context)))
100 ([px py x y w h]
101 (and (>= px x)
102 (>= py y)
103 (< px (+ x w))
104 (< py (+ y h)))))
106 (defn- under-cursor
107 "Returns a sequence of contexts under cursor."
108 ([context-tree x y]
109 (under-cursor context-tree x y nil))
110 ([context-tree x y context]
111 (some #(if (inside? x y %)
112 (conj (under-cursor context-tree x y %) %))
113 (context-tree context))))
115 (defn- remove-all [coll1 coll2 pred]
116 (filter #(not (some (partial pred %) coll2)) coll1))
118 (defn- translate-mouse-event
119 [#^MouseEvent event x y id]
120 (proxy [MouseEvent] [(.getComponent event)
121 id
122 (.getWhen event)
123 (.getModifiers event)
124 (- (.getX event) x)
125 (- (.getY event) y)
126 (.getClickCount event)
127 (.isPopupTrigger event)]
128 (getXOnScreen []
129 (.getXOnScreen event))
130 (getYOnScreen []
131 (.getYOnScreen event))))
133 (defn- translate-and-dispatch
134 ([contexts event]
135 (translate-and-dispatch contexts event (.getID event)))
136 ([contexts event id]
137 (doseq [c contexts]
138 (handle-layer-event
139 (:layer c)
140 c
141 (translate-mouse-event event (:x c) (:y c) id)))))
143 (defn- dispatch-mouse-motion*
144 "Dispatches mouse motion events. Returns a new set of contexts which
145 currently are under cursor."
146 [hovered context-tree #^MouseEvent event]
147 (let [x (.getX event)
148 y (.getY event)
149 hovered2 (under-cursor context-tree x y)
150 pred #(= (:layer %1) (:layer %2))
151 exited (remove-all hovered hovered2 pred)
152 entered (remove-all hovered2 hovered pred)
153 moved (remove-all hovered2 entered pred)]
154 (translate-and-dispatch exited event MouseEvent/MOUSE_EXITED)
155 (translate-and-dispatch entered event MouseEvent/MOUSE_ENTERED)
156 (translate-and-dispatch moved event MouseEvent/MOUSE_MOVED)
157 hovered2))
159 (defn- dispatch-mouse-motion
160 [hovered-ref context-tree #^MouseEvent event]
161 (dosync
162 (alter hovered-ref dispatch-mouse-motion* context-tree event)))
164 (defn make-event-dispatcher []
165 (let [context-tree-r (ref {}) ; register
166 context-tree (ref {}) ; dispatch
167 hovered (ref '())
168 picked (ref '())]
169 (reify
170 EventDispatcher
171 (register [this context]
172 (dosync (alter context-tree-r register-context context)))
173 (commit [this]
174 (dosync (ref-set context-tree @context-tree-r)
175 (ref-set context-tree-r {})))
176 (picked? [this layer] false)
177 (hovered? [this layer] false)
178 MouseListener
179 (mouseClicked [this event])
180 (mouseEntered [this event]
181 (dispatch-mouse-motion hovered context-tree event))
182 (mouseExited [this event]
183 (dispatch-mouse-motion hovered context-tree event))
184 (mousePressed [this event])
185 (mouseReleased [this event])
186 MouseMotionListener
187 (mouseDragged [this event]
188 (translate-and-dispatch @picked event))
189 (mouseMoved [this event]
190 (dispatch-mouse-motion hovered context-tree event)))))
192 ;;
193 ;; Connection to AWT.
194 ;;
196 (defn- make-update-fn [component]
197 (fn [] (.repaint component)))
199 (defn make-component
200 ([layer]
201 (make-component layer (make-event-dispatcher)))
202 ([layer event-dispatcher]
203 (doto
204 (proxy [Component] []
205 (update [g] (.paint this g))
206 (paint [g]
207 (let [size (.getSize this)
208 width (.width size)
209 height (.height size)
210 context (assoc (default-context)
211 :dispatcher event-dispatcher
212 :update-fn (make-update-fn this))]
213 (render-layer! context layer g 0 0 width height false))
214 (commit event-dispatcher))
215 (getPreferredSize []
216 (let [s (size layer nil)] ;; TODO: supply context
217 (Dimension. (s 0) (s 1)))))
218 (.addMouseListener event-dispatcher)
219 (.addMouseMotionListener event-dispatcher))))
221 (comment
222 (do
223 (def frame (java.awt.Frame. "Test"))
224 (def layer1
225 (reify-layer
226 (render! [this context g]
227 (register (:dispatcher context) context)
228 (.setColor g Color/WHITE)
229 (.fillRect g 0 0 (:width context) (:height context)))
230 (size [this context] [50 30])))
231 (def layer2
232 (reify-layer
233 (render! [this context g]
234 (register (:dispatcher context) context)
235 (.setColor g Color/BLUE)
236 (.fillRect g 0 0 (:width context) (:height context))
237 (render-layer! context layer1 g 10 5))
238 (size [this context] [70 65])))
239 (def layer
240 (reify-layer
241 (render! [this context g]
242 ;;(register (:dispatcher context) context)
243 (.drawLine g 0 0 (:width context) (:height context))
244 (render-layer! context layer2 g 15 20))
245 (size [this context] [100 100])))
246 (doto frame
247 (.addWindowListener
248 (proxy [java.awt.event.WindowAdapter] []
249 (windowClosing [event] (.dispose frame))))
250 (.add (make-component layer))
251 (.pack)
252 (.setVisible true))
254 (defmethod handle-layer-event [layer1 MouseEvent/MOUSE_ENTERED]
255 [layer context event]
256 (println "1 ENTERED"))
257 (defmethod handle-layer-event [layer1 MouseEvent/MOUSE_EXITED]
258 [layer context event]
259 (println "1 EXITED"))
260 (defmethod handle-layer-event [layer1 MouseEvent/MOUSE_MOVED]
261 [layer context event]
262 (println "1 MOVED"))
263 (defmethod handle-layer-event [layer2 MouseEvent/MOUSE_ENTERED]
264 [layer context event]
265 (println "2 ENTERED"))
266 (defmethod handle-layer-event [layer2 MouseEvent/MOUSE_EXITED]
267 [layer context event]
268 (println "2 EXITED"))
269 (defmethod handle-layer-event [layer2 MouseEvent/MOUSE_MOVED]
270 [layer context event]
271 (println "2 MOVED"))
272 )
273 )