Mercurial > hg > indyvon
view src/kryshen/indyvon/core.clj @ 39:930c088e1367
Graph drawing.
Some events should be dispatched only to the first handler.
Code cleanup.
| author | Mikhail Kryshen <mikhail@kryshen.net> |
|---|---|
| date | Fri, 09 Jul 2010 11:42:58 +0400 |
| parents | af3187fdc44d |
| children | a96dfbfd6d4e |
line source
1 ;;
2 ;; Copyright (C) 2010 Mikhail Kryshen <mikhail@kryshen.net>
3 ;;
4 ;; This file is part of Indyvon.
5 ;;
7 (ns kryshen.indyvon.core
8 (:import
9 (java.awt Graphics2D Component Color Font)
10 (java.awt.event MouseListener MouseMotionListener)
11 (java.awt.font FontRenderContext)))
13 (def ^Graphics2D *graphics*)
14 (def ^FontRenderContext *font-context*)
15 (def ^Component *target*)
16 (def *bounds*)
17 (def *clip*)
18 (def *update*)
19 (def *event-dispatcher*)
21 (defrecord Theme [fore-color back-color border-color font])
23 (defn default-theme []
24 (Theme. Color/BLACK Color/WHITE Color/BLUE (Font. "Sans" Font/PLAIN 12)))
26 (def *theme* (default-theme))
28 (defrecord Location [x y])
29 (defrecord Size [width height])
30 (defrecord Bounds [x y width height])
32 (defprotocol Layer
33 "Basic UI element."
34 (render! [this])
35 (size [this]))
37 ;; TODO: modifiers
38 (defrecord MouseEvent [id when x y x-on-screen y-on-screen button])
40 (defprotocol EventDispatcher
41 (listen! [this ^Component component]
42 "Listen for events on the specified AWT Component.")
43 (create-dispatcher [this handle handlers]
44 "Returns new event dispatcher associated with the specified event
45 handlers (an event-id -> handler-fn map). Handle is used to
46 match the contexts between commits.")
47 (commit [this]
48 "Apply the registered handlers for event processing."))
50 (defprotocol Anchored
51 "Provide anchor point for Layers. Used by viewport."
52 (anchor [this h-align v-align]
53 "Anchor point: [x y], h-align could be :left, :center or :right,
54 v-align is :top, :center or :bottom"))
56 ;; Default implementation of Anchored for any Layer.
57 (extend-protocol Anchored
58 kryshen.indyvon.core.Layer
59 (anchor [this h-align v-align]
60 (if (and (= h-align :left)
61 (= v-align :top))
62 (Location. 0 0)
63 (let [size (size this)]
64 (Location.
65 (case h-align
66 :top 0
67 :center (/ (:width size) 2)
68 :right (:width size))
69 (case v-align
70 :left 0
71 :center (/ (:height size) 2)
72 :bottom (:height size)))))))
74 (defn- ^Graphics2D make-graphics [^Graphics2D graphics x y w h]
75 (.create graphics x y w h))
77 (defn- ^Graphics2D apply-theme [^Graphics2D graphics theme]
78 (doto graphics
79 (.setColor (:fore-color theme))
80 (.setFont (:font theme))))
82 (defn intersect
83 ([b1 b2]
84 (let [x1 (:x b1)
85 y1 (:y b1)
86 x2 (:x b2)
87 y2 (:y b2)]
88 (intersect x1 y1 (+ x1 (:width b1)) (+ y1 (:height b1))
89 x2 y2 (+ x2 (:width b2)) (+ y2 (:height b2)))))
90 ([x11 y11 x12 y12, x21 y21 x22 y22]
91 (let [x1 (max x11 x21)
92 y1 (max y11 y21)
93 x2 (min x12 x22)
94 y2 (min y12 y22)]
95 (Bounds. x1 y1 (- x2 x1) (- y2 y1)))))
97 (defn- ^Graphics2D create-graphics
98 ([]
99 (create-graphics 0 0 (:width *bounds*) (:height *bounds*)))
100 ([x y w h]
101 (apply-theme (.create *graphics* x y w h) *theme*)))
103 (defn with-bounds* [x y w h f & args]
104 (let [graphics (create-graphics x y w h)
105 bounds (Bounds. (+ x (:x *bounds*))
106 (+ y (:y *bounds*))
107 w h)]
108 (try
109 (apply with-bindings* {#'*bounds* bounds
110 #'*clip* (intersect bounds *clip*)
111 #'*graphics* graphics}
112 f args)
113 (finally
114 (.dispose graphics)))))
116 (defmacro with-bounds [x y w h & body]
117 `(with-bounds* ~x ~y ~w ~h (fn [] ~@body)))
119 (defn with-handlers* [handle handlers f & args]
120 (apply with-bindings*
121 {#'*event-dispatcher*
122 (create-dispatcher *event-dispatcher* handle handlers)}
123 f args))
125 (defmacro with-handlers
126 "specs => (:event-id name & handler-body)*
128 Execute form with the specified event handlers."
129 [handle form & specs]
130 `(with-handlers* ~handle
131 ~(reduce (fn [m spec]
132 (assoc m (first spec)
133 `(fn [~(second spec)]
134 ~@(nnext spec)))) {}
135 specs)
136 (fn [] ~form)))
138 (defn- geometry-vec [geometry]
139 (if (vector? geometry)
140 geometry
141 [(:x geometry) (:y geometry) (:width geometry) (:height geometry)]))
143 (defn draw!
144 ([layer]
145 (let [graphics (create-graphics)]
146 (try
147 (with-bindings* {#'*graphics* graphics} render! layer)
148 (finally
149 (.dispose graphics)))))
150 ([layer x y]
151 (let [size (size layer)]
152 (draw! layer x y (:width size) (:height size))))
153 ([layer x y width height]
154 (with-bounds* x y width height render! layer)))
156 (defn draw-anchored!
157 "Draw with location relative to the anchor point."
158 ([layer h-align v-align x y]
159 (let [anchor (anchor layer h-align v-align)]
160 (draw! layer (- x (:x anchor)) (- y (:y anchor)))))
161 ([layer h-align v-align x y w h]
162 (let [anchor (anchor layer h-align v-align)]
163 (draw! layer (- x (:x anchor)) (- y (:y anchor)) w h))))
165 ;;
166 ;; EventDispatcher implementation
167 ;;
169 (def awt-events
170 {java.awt.event.MouseEvent/MOUSE_CLICKED :mouse-clicked
171 java.awt.event.MouseEvent/MOUSE_DRAGGED :mouse-dragged
172 java.awt.event.MouseEvent/MOUSE_ENTERED :mouse-entered
173 java.awt.event.MouseEvent/MOUSE_EXITED :mouse-exited
174 java.awt.event.MouseEvent/MOUSE_MOVED :mouse-moved
175 java.awt.event.MouseEvent/MOUSE_PRESSED :mouse-pressed
176 java.awt.event.MouseEvent/MOUSE_RELEASED :mouse-released})
178 (defrecord DispatcherNode [handle handlers parent bounds bindings]
179 EventDispatcher
180 (listen! [this component]
181 (listen! parent component))
182 (create-dispatcher [this handle handlers]
183 (create-dispatcher parent handle handlers))
184 (commit [this]
185 (commit parent)))
187 (defn- make-node [handle handlers]
188 (DispatcherNode. handle handlers *event-dispatcher* *clip*
189 (get-thread-bindings)))
191 (defn- assoc-cons [m key val]
192 (assoc m key (cons val (get m key))))
194 (defn- add-node [tree node]
195 (assoc-cons tree (:parent node) node))
197 (defn- inside?
198 ([x y bounds]
199 (inside? x y (:x bounds) (:y bounds)
200 (:width bounds) (:height bounds)))
201 ([px py x y w h]
202 (and (>= px x)
203 (>= py y)
204 (< px (+ x w))
205 (< py (+ y h)))))
207 (defn- under-cursor
208 "Returns a vector of child nodes under cursor."
209 [x y tree node]
210 (some #(if (inside? x y (:bounds %))
211 (conj (vec (under-cursor x y tree %)) %))
212 (get tree node)))
214 (defn- remove-all [coll1 coll2 pred]
215 (filter #(not (some (partial pred %) coll2)) coll1))
217 (defn- translate-mouse-event [^java.awt.event.MouseEvent event x y id]
218 (MouseEvent. id (.getWhen event)
219 (- (.getX event) x) (- (.getY event) y)
220 (.getXOnScreen event) (.getYOnScreen event)
221 (.getButton event)))
223 (defn- translate-and-dispatch
224 ([nodes first-only ^java.awt.event.MouseEvent event]
225 (translate-and-dispatch
226 nodes first-only event (awt-events (.getID event))))
227 ([nodes first-only event id]
228 (if-let [node (first nodes)]
229 (if-let [handler (get (:handlers node) id)]
230 (do
231 (with-bindings* (:bindings node)
232 handler
233 (translate-mouse-event event
234 (-> node :bounds :x) (-> node :bounds :y) id))
235 (if first-only
236 id
237 (recur (rest nodes) false event id)))
238 (recur (rest nodes) first-only event id))
239 id)))
241 (defn- dispatch-mouse-motion*
242 "Dispatches mouse motion events. Returns a new set of nodes which
243 currently are under cursor."
244 [hovered tree root ^java.awt.event.MouseEvent event]
245 (let [x (.getX event)
246 y (.getY event)
247 hovered2 (under-cursor x y tree root)
248 pred #(= (:handle %1) (:handle %2))
249 exited (remove-all hovered hovered2 pred)
250 entered (remove-all hovered2 hovered pred)
251 moved (remove-all hovered2 entered pred)]
252 (translate-and-dispatch exited false event :mouse-exited)
253 (translate-and-dispatch entered false event :mouse-entered)
254 (translate-and-dispatch moved true event :mouse-moved)
255 hovered2))
257 (defn- dispatch-mouse-motion
258 [hovered-ref tree root event]
259 (dosync
260 (alter hovered-ref dispatch-mouse-motion* tree root event)))
262 (defn- dispatch-mouse-button*
263 "Dispatches mouse button events. Returns a new set of nodes which
264 currently are picked with a pressed button."
265 [picked hovered event]
266 (if (= (translate-and-dispatch hovered true event) :mouse-pressed)
267 hovered
268 nil))
270 (defn- dispatch-mouse-button
271 [picked-ref hovered-ref event]
272 (dosync
273 (alter picked-ref dispatch-mouse-button* @hovered-ref event)))
275 (defn root-event-dispatcher []
276 (let [tree-r (ref {}) ; register
277 tree (ref {}) ; dispatch
278 hovered (ref '())
279 picked (ref '())]
280 (reify
281 EventDispatcher
282 (listen! [this component]
283 (doto component
284 (.addMouseListener this)
285 (.addMouseMotionListener this)))
286 (create-dispatcher [this handle handlers]
287 (let [node (make-node handle handlers)]
288 (dosync (alter tree-r add-node node))
289 node))
290 (commit [this]
291 (dosync (ref-set tree @tree-r)
292 (ref-set tree-r {})))
293 MouseListener
294 (mouseEntered [this event]
295 (dispatch-mouse-motion hovered @tree this event))
296 (mouseExited [this event]
297 (dispatch-mouse-motion hovered @tree this event))
298 (mouseClicked [this event]
299 (dispatch-mouse-button picked hovered event))
300 (mousePressed [this event]
301 (dispatch-mouse-button picked hovered event))
302 (mouseReleased [this event]
303 (dispatch-mouse-button picked hovered event))
304 MouseMotionListener
305 (mouseDragged [this event]
306 (translate-and-dispatch @picked true event))
307 (mouseMoved [this event]
308 (dispatch-mouse-motion hovered @tree this event)))))
310 ;;
311 ;; ИДЕИ:
312 ;;
313 ;; Контекст: биндинги или запись?
314 ;;
315 ;; Установка обработчиков (в контексте слоя):
316 ;;
317 ;; (listen
318 ;; (:mouse-entered e
319 ;; ...)
320 ;; (:mouse-exited e
321 ;; ...))
322 ;;
323 ;; Не надо IMGUI.
324 ;; Построение сцены путем декорирования слоев:
325 ;;
326 ;; (listener
327 ;; (:action e (println e))
328 ;; (:mouse-dragged e (println e))
329 ;; (theme :font "Helvetica-14"
330 ;; (vbox
331 ;; (button (text-layer "Button 1"))
332 ;; (button (text-layer "Button 2")))))
333 ;;