Mercurial > hg > indyvon
view src/kryshen/indyvon/core.clj @ 40:a96dfbfd6d4e
Do not call event handlers inside transaction.
| author | Mikhail Kryshen <mikhail@kryshen.net> |
|---|---|
| date | Sat, 10 Jul 2010 03:04:47 +0400 |
| parents | 930c088e1367 |
| children | d3e3c43df1cd |
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 AWTEvent)
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 nodes first-only
226 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-not first-only
236 (recur (rest nodes) false event id)))
237 (recur (rest nodes) first-only event id)))))
239 (defn- dispatch-mouse-motion
240 "Dispatches mouse motion events."
241 [hovered-ref tree root ^java.awt.event.MouseEvent event]
242 (let [x (.getX event)
243 y (.getY event)
244 [hovered hovered2] (dosync
245 [@hovered-ref
246 (ref-set hovered-ref
247 (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)))
256 (defn- dispatch-mouse-button
257 [picked-ref hovered-ref ^java.awt.event.MouseEvent event]
258 (let [id (awt-events (.getID event))
259 hovered (if (= id :mouse-pressed)
260 (dosync (ref-set picked-ref @hovered-ref))
261 @hovered-ref)]
262 (translate-and-dispatch hovered true event id)))
264 (defn root-event-dispatcher []
265 (let [tree-r (ref {}) ; register
266 tree (ref {}) ; dispatch
267 hovered (ref '())
268 picked (ref '())]
269 (reify
270 EventDispatcher
271 (listen! [this component]
272 (doto component
273 (.addMouseListener this)
274 (.addMouseMotionListener this)))
275 (create-dispatcher [this handle handlers]
276 (let [node (make-node handle handlers)]
277 (dosync (alter tree-r add-node node))
278 node))
279 (commit [this]
280 (dosync (ref-set tree @tree-r)
281 (ref-set tree-r {})))
282 MouseListener
283 (mouseEntered [this event]
284 (dispatch-mouse-motion hovered @tree this event))
285 (mouseExited [this event]
286 (dispatch-mouse-motion hovered @tree this event))
287 (mouseClicked [this event]
288 (dispatch-mouse-button picked hovered event))
289 (mousePressed [this event]
290 (dispatch-mouse-button picked hovered event))
291 (mouseReleased [this event]
292 (dispatch-mouse-button picked hovered event))
293 MouseMotionListener
294 (mouseDragged [this event]
295 (translate-and-dispatch @picked true event))
296 (mouseMoved [this event]
297 (dispatch-mouse-motion hovered @tree this event)))))
299 ;;
300 ;; ИДЕИ:
301 ;;
302 ;; Контекст: биндинги или запись?
303 ;;
304 ;; Установка обработчиков (в контексте слоя):
305 ;;
306 ;; (listen
307 ;; (:mouse-entered e
308 ;; ...)
309 ;; (:mouse-exited e
310 ;; ...))
311 ;;
312 ;; Не надо IMGUI.
313 ;; Построение сцены путем декорирования слоев:
314 ;;
315 ;; (listener
316 ;; (:action e (println e))
317 ;; (:mouse-dragged e (println e))
318 ;; (theme :font "Helvetica-14"
319 ;; (vbox
320 ;; (button (text-layer "Button 1"))
321 ;; (button (text-layer "Button 2")))))
322 ;;