Mercurial > hg > indyvon
view src/indyvon/core.clj @ 8:c53ec3052ae7
Dispatching mouse motion events.
| author | Mikhail Kryshen <mikhail@kryshen.net> |
|---|---|
| date | Sat, 12 Jun 2010 06:06:41 +0400 |
| parents | f6d10a68b01d |
| children | 160e9ec945a2 |
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- assoc-conj [vmap key val]
82 "Add val to the sequence associated with key in vmap."
83 (assoc vmap key (conj (get vmap key) val)))
85 (defn- registered-parent
86 "Returns first context parent registered for event processing."
87 [context-tree context]
88 (let [parent (:parent context)]
89 (cond
90 (nil? parent) nil
91 (contains? context-tree parent) parent
92 :default (recur context-tree parent))))
94 (defn- register-context
95 [context-tree context]
96 (assoc-conj
97 context-tree (registered-parent context-tree context) context))
99 (defn- inside?
100 ([x y context]
101 (inside? x y (:x context) (:y context)
102 (:width context) (:height context)))
103 ([px py x y w h]
104 (and (>= px x)
105 (>= py y)
106 (< px (+ x w))
107 (< py (+ y h)))))
109 (defn- under-cursor
110 "Returns a sequence of contexts under cursor."
111 ([context-tree x y]
112 (under-cursor context-tree x y nil))
113 ([context-tree x y context]
114 (some #(if (inside? x y %)
115 (conj (under-cursor context-tree x y %) %))
116 (context-tree context))))
118 (defn- remove-all [coll1 coll2 pred]
119 (filter #(not (some (partial pred %) coll2)) coll1))
121 (defn- translate-mouse-event
122 [#^MouseEvent event x y id]
123 (proxy [MouseEvent] [(.getComponent event)
124 id
125 (.getWhen event)
126 (.getModifiers event)
127 (- (.getX event) x)
128 (- (.getY event) y)
129 (.getClickCount event)
130 (.isPopupTrigger event)]
131 (getXOnScreen []
132 (.getXOnScreen event))
133 (getYOnScreen []
134 (.getYOnScreen event))))
136 (defn- translate-and-dispatch
137 ([contexts event]
138 (translate-and-dispatch contexts event (.getID event)))
139 ([contexts event id]
140 (doseq [c contexts]
141 (handle-layer-event
142 (:layer c)
143 c
144 (translate-mouse-event event (:x c) (:y c) id)))))
146 (defn- dispatch-mouse-motion*
147 "Dispatches mouse motion events. Returns a new set of contexts which
148 currently are under cursor."
149 [hovered context-tree #^MouseEvent event]
150 (let [x (.getX event)
151 y (.getY event)
152 hovered2 (under-cursor context-tree x y)
153 pred #(= (:layer %1) (:layer %2))
154 exited (remove-all hovered hovered2 pred)
155 entered (remove-all hovered2 hovered pred)
156 moved (remove-all hovered2 entered pred)]
157 (translate-and-dispatch exited event MouseEvent/MOUSE_EXITED)
158 (translate-and-dispatch entered event MouseEvent/MOUSE_ENTERED)
159 (translate-and-dispatch moved event MouseEvent/MOUSE_MOVED)
160 hovered2))
162 (defn- dispatch-mouse-motion
163 [hovered-ref context-tree #^MouseEvent event]
164 (dosync
165 (alter hovered-ref dispatch-mouse-motion* context-tree event)))
167 (defn make-event-dispatcher []
168 (let [context-tree-r (ref {}) ; register
169 context-tree (ref {}) ; dispatch
170 hovered (ref '())
171 picked (ref '())]
172 (reify
173 EventDispatcher
174 (register [this context]
175 (dosync (alter context-tree-r register-context context)))
176 (commit [this]
177 (dosync (ref-set context-tree @context-tree-r)
178 (ref-set context-tree-r {})))
179 (picked? [this layer] false)
180 (hovered? [this layer] false)
181 MouseListener
182 (mouseClicked [this event])
183 (mouseEntered [this event]
184 (dispatch-mouse-motion hovered context-tree event))
185 (mouseExited [this event]
186 (dispatch-mouse-motion hovered context-tree event))
187 (mousePressed [this event])
188 (mouseReleased [this event])
189 MouseMotionListener
190 (mouseDragged [this event]
191 (translate-and-dispatch @picked event))
192 (mouseMoved [this event]
193 (dispatch-mouse-motion hovered context-tree event)))))
195 ;;
196 ;; Connection to AWT.
197 ;;
199 (defn- make-update-fn [component]
200 (fn [] (.repaint component)))
202 (defn make-component
203 ([layer]
204 (make-component layer (make-event-dispatcher)))
205 ([layer event-dispatcher]
206 (doto
207 (proxy [Component] []
208 (update [g] (.paint this g))
209 (paint [g]
210 (let [size (.getSize this)
211 width (.width size)
212 height (.height size)
213 context (assoc (default-context)
214 :dispatcher event-dispatcher
215 :update-fn (make-update-fn this))]
216 (render-layer! context layer g 0 0 width height false))
217 (commit event-dispatcher))
218 (getPreferredSize []
219 (let [s (size layer nil)] ;; TODO: supply context
220 (Dimension. (s 0) (s 1)))))
221 (.addMouseListener event-dispatcher)
222 (.addMouseMotionListener event-dispatcher))))
224 (comment
225 (do
226 (def frame (java.awt.Frame. "Test"))
227 (def layer1
228 (reify-layer
229 (render! [this context g]
230 (register (:dispatcher context) context)
231 (.setColor g Color/BLUE)
232 (.fillRect g 0 0 50 30))
233 (size [this context] [50 30])))
234 (def layer
235 (reify-layer
236 (render! [this context g]
237 (register (:dispatcher context) context)
238 (.drawLine g 0 0 (:width context) (:height context))
239 (render-layer! context layer1 g 15 20))
240 (size [this context] [100 100])))
241 (doto frame
242 (.addWindowListener
243 (proxy [java.awt.event.WindowAdapter] []
244 (windowClosing [event] (.dispose frame))))
245 (.add (make-component layer))
246 (.pack)
247 (.setVisible true))
249 (defmethod handle-layer-event [layer1 MouseEvent/MOUSE_ENTERED]
250 [layer context event]
251 (println "ENTERED"))
252 (defmethod handle-layer-event [layer1 MouseEvent/MOUSE_EXITED]
253 [layer context event]
254 (println "EXITED"))
255 (defmethod handle-layer-event [layer1 MouseEvent/MOUSE_MOVED]
256 [layer context event]
257 (println "MOVED"))
258 )
259 )