Mercurial > hg > indyvon
view src/net/kryshen/indyvon/core.clj @ 73:0465aaf01664
Keep old context observers until rendering is complete.
| author | Mikhail Kryshen <mikhail@kryshen.net> |
|---|---|
| date | Mon, 30 Aug 2010 06:01:27 +0400 |
| parents | b2f6c78413d3 |
| children | a823dd0c2736 |
line source
1 ;;
2 ;; Copyright (C) 2010 Mikhail Kryshen <mikhail@kryshen.net>
3 ;;
4 ;; This file is part of Indyvon.
5 ;;
7 (ns net.kryshen.indyvon.core
8 (:import
9 (java.awt Graphics2D RenderingHints Component Color Font AWTEvent Shape)
10 (java.awt.geom AffineTransform Point2D$Double Rectangle2D$Double Area)
11 (java.awt.event MouseListener MouseMotionListener)
12 (java.awt.font FontRenderContext)))
14 ;;
15 ;; Layer context
16 ;;
18 (def ^Graphics2D *graphics*)
20 (def ^FontRenderContext *font-context*)
22 (def ^{:tag Component
23 :doc "Target AWT component, may be nil if drawing off-screen."}
24 *target*)
26 (def ^{:doc "Width of the rendering area."}
27 *width*)
29 (def ^{:doc "Height of the rendering area."}
30 *height*)
32 (def ^Shape *clip*)
34 (def *root*)
36 (def *event-dispatcher*)
38 (def ^{:tag AffineTransform
39 :doc "Initial transform associated with the graphics context."}
40 *initial-transform*)
42 (def ^{:tag AffineTransform
43 :doc "Inversion of the initial transform associated with
44 the graphics context."}
45 *inverse-initial-transform*)
47 (defrecord Theme [fore-color back-color alt-back-color border-color font])
49 ;; REMIND: use system colors, see java.awt.SystemColor.
50 (defn default-theme []
51 (Theme. Color/BLACK Color/WHITE Color/LIGHT_GRAY
52 Color/BLUE (Font. "Sans" Font/PLAIN 12)))
54 (def *theme* (default-theme))
56 (defrecord Location [x y])
57 (defrecord Size [width height])
58 (defrecord Bounds [x y width height])
60 ;;
61 ;; Core protocols and types
62 ;;
64 (defprotocol Layer
65 "Basic UI element."
66 (render! [this])
67 (layer-size [this]))
69 ;; TODO: modifiers
70 (defrecord MouseEvent [id when x y x-on-screen y-on-screen button])
72 (defprotocol EventDispatcher
73 (listen! [this ^Component component]
74 "Listen for events on the specified AWT Component.")
75 (create-dispatcher [this handle handlers]
76 "Returns new event dispatcher associated with the specified event
77 handlers (an event-id -> handler-fn map). Handle is used to
78 match the contexts between commits.")
79 (commit [this]
80 "Apply the registered handlers for event processing."))
82 (defprotocol Anchored
83 "Provide anchor point for Layers. Used by viewport."
84 (anchor [this h-align v-align]
85 "Anchor point: [x y], h-align could be :left, :center or :right,
86 v-align is :top, :center or :bottom"))
88 (defn default-anchor [layer h-align v-align]
89 (if (and (= h-align :left)
90 (= v-align :top))
91 (Location. 0 0)
92 (let [size (layer-size layer)]
93 (Location.
94 (case h-align
95 :top 0
96 :center (/ (:width size) 2)
97 :right (:width size))
98 (case v-align
99 :left 0
100 :center (/ (:height size) 2)
101 :bottom (:height size))))))
103 ;; Default implementation of Anchored for any Layer.
104 (extend-protocol Anchored
105 net.kryshen.indyvon.core.Layer
106 (anchor [this h-align v-align]
107 (default-anchor this h-align v-align)))
109 (defn- assoc-cons [m key val]
110 (->> (get m key) (cons val) (assoc m key)))
112 (defn- assoc-in-cons [m keys val]
113 (->> (get-in m keys) (cons val) (assoc-in m keys)))
115 ;;
116 ;; Observers
117 ;;
119 (def observers (atom nil))
121 ;; TODO: groups should be weakly referenced.
122 (defn add-observer
123 "Add observer fn for the target to the specified group."
124 [group target f]
125 (swap! observers assoc-in-cons [group target] f)
126 nil)
128 (defn remove-observer-group
129 "Remove group of observers."
130 [group]
131 (swap! observers dissoc group)
132 nil)
134 (defn- replace-observer-group*
135 [observers old-id new-id]
136 (let [group (get observers old-id)]
137 (assoc (dissoc observers old-id)
138 new-id group)))
140 (defn- replace-observer-group
141 [old-id new-id]
142 (swap! observers replace-observer-group* old-id new-id))
144 (defn update
145 "Notify observers."
146 [target & args]
147 (doseq [f (reduce #(concat %1 (get %2 target)) nil (vals @observers))]
148 (apply f target args)))
150 (defn add-context-observer
151 "Observer registered with this function will be automatically
152 removed after the next frame rendering is complete."
153 [target f]
154 (let [root *root*]
155 (add-observer root target f)))
157 (defn repaint-on-update
158 "Trigger repaint of the current scene when the target updates."
159 [target]
160 (let [root *root*]
161 (if (not= root target)
162 (add-observer root target (fn [_] (update root))))))
164 (defn repaint
165 "Repaint the current scene."
166 []
167 (update *root*))
169 ;;
170 ;; Rendering
171 ;;
173 (defn- relative-transform
174 "AffineTransform: layer context -> awt component."
175 []
176 (let [tr (.getTransform *graphics*)]
177 (.preConcatenate tr *inverse-initial-transform*)
178 tr))
180 (defn- inverse-relative-transform
181 "AffineTransform: awt component -> layer context."
182 []
183 (let [tr (.getTransform *graphics*)]
184 (.invert tr) ; absolute -> layer
185 (.concatenate tr *initial-transform*) ; component -> absolute
186 tr))
188 (defn- clip
189 "Intersect clipping area with the specified shape or bounds.
190 Returns new clip (Shape or nil if empty)."
191 ([x y w h]
192 (clip (Rectangle2D$Double. x y w h)))
193 ([shape]
194 (let [a1 (Area. shape)
195 a2 (if (instance? Area *clip*) *clip* (Area. *clip*))]
196 (.transform a1 (relative-transform))
197 (.intersect a1 a2)
198 (if (.isEmpty a1)
199 nil
200 a1))))
202 (defn- ^Graphics2D apply-theme
203 "Set graphics' color and font to match theme.
204 Modifies and returns the first argument."
205 ([]
206 (apply-theme *graphics* *theme*))
207 ([^Graphics2D graphics theme]
208 (doto graphics
209 (.setColor (:fore-color theme))
210 (.setFont (:font theme)))))
212 (defn- ^Graphics2D create-graphics
213 ([]
214 (create-graphics 0 0 *width* *height*))
215 ([x y w h]
216 (apply-theme (.create *graphics* x y w h) *theme*)))
218 (defn with-bounds*
219 [x y w h f & args]
220 (when-let [clip (clip x y w h)]
221 (let [graphics (create-graphics x y w h)]
222 (try
223 (binding [*width* w
224 *height* h
225 *clip* clip
226 *graphics* graphics]
227 (apply f args))
228 (finally
229 (.dispose graphics))))))
231 (defmacro with-bounds
232 [x y w h & body]
233 `(with-bounds* ~x ~y ~w ~h (fn [] ~@body)))
235 (defn with-handlers*
236 [handle handlers f & args]
237 (binding
238 [*event-dispatcher* (create-dispatcher
239 *event-dispatcher* handle handlers)]
240 (apply f args)))
242 (defmacro with-handlers
243 "specs => (:event-id name & handler-body)*
245 Execute form with the specified event handlers."
246 [handle form & specs]
247 `(with-handlers* ~handle
248 ~(reduce (fn [m spec]
249 (assoc m (first spec)
250 `(fn [~(second spec)]
251 ~@(nnext spec)))) {}
252 specs)
253 (fn [] ~form)))
255 (defmacro with-theme
256 [theme & body]
257 `(binding [*theme* (merge *theme* ~theme)]
258 ~@body))
260 (defmacro with-color
261 [color-or-keyword & body]
262 (let [color-form (if (keyword? color-or-keyword)
263 `(~color-or-keyword *theme*)
264 color-or-keyword)]
265 `(let [color# ~color-form
266 old-color# (.getColor *graphics*)]
267 (try
268 (.setColor *graphics* color#)
269 ~@body
270 (finally
271 (.setColor *graphics* old-color#))))))
273 ;; TODO: constructor for AffineTransform.
274 ;; (transform :scale 0.3 0.5
275 ;; :translate 5 10
276 ;; :rotate (/ Math/PI 2))
278 (defmacro with-transform [transform & body]
279 `(let [old-t# (.getTransform *graphics*)]
280 (try
281 (.transform *graphics* ~transform)
282 ~@body
283 (finally
284 (.setTransform *graphics* old-t#)))))
286 (defmacro with-rotate [theta ax ay & body]
287 `(let [transform# (AffineTransform/getRotateInstance ~theta ~ax ~ay)]
288 (with-transform transform# ~@body)))
290 (defn draw!
291 "Draws layer."
292 ([layer]
293 (let [graphics (create-graphics)]
294 (try
295 (binding [*graphics* graphics]
296 (render! layer))
297 (finally
298 (.dispose graphics)))))
299 ([layer x y]
300 (let [size (layer-size layer)]
301 (draw! layer x y (:width size) (:height size))))
302 ([layer x y width height]
303 (with-bounds* x y width height render! layer)))
305 (defn draw-anchored!
306 "Draws layer. Location is relative to the layer's anchor point for
307 the specified alignment."
308 ([layer h-align v-align x y]
309 (let [anchor (anchor layer h-align v-align)]
310 (draw! layer (- x (:x anchor)) (- y (:y anchor)))))
311 ([layer h-align v-align x y w h]
312 (let [anchor (anchor layer h-align v-align)]
313 (draw! layer (- x (:x anchor)) (- y (:y anchor)) w h))))
315 (defn draw-root!
316 "Draws the root layer."
317 ([layer graphics width height event-dispatcher]
318 (draw-root! layer graphics width height event-dispatcher nil))
319 ([layer ^Graphics2D graphics width height event-dispatcher target]
320 (binding [*root* layer
321 *target* target
322 *graphics* graphics
323 *font-context* (.getFontRenderContext graphics)
324 *initial-transform* (.getTransform graphics)
325 *inverse-initial-transform*
326 (-> graphics .getTransform .createInverse)
327 *event-dispatcher* event-dispatcher
328 *width* width
329 *height* height
330 *clip* (Rectangle2D$Double. 0 0 width height)]
331 ;; (.setRenderingHint graphics
332 ;; RenderingHints/KEY_INTERPOLATION
333 ;; RenderingHints/VALUE_INTERPOLATION_BILINEAR)
334 ;; (.setRenderingHint graphics
335 ;; RenderingHints/KEY_ALPHA_INTERPOLATION
336 ;; RenderingHints/VALUE_ALPHA_INTERPOLATION_QUALITY)
337 ;; (.setRenderingHint graphics
338 ;; RenderingHints/KEY_ANTIALIASING
339 ;; RenderingHints/VALUE_ANTIALIAS_ON)
340 (apply-theme)
341 (with-color (:back-color *theme*)
342 (.fillRect graphics 0 0 width height))
343 (let [tmp-group (Object.)]
344 ;; Keep current context observers until the rendering is complete.
345 ;; Some observers may be invoked twice if they appear in both
346 ;; groups until tmp-group is removed.
347 (replace-observer-group layer tmp-group)
348 (try
349 (render! layer)
350 (finally
351 (remove-observer-group tmp-group)
352 (commit event-dispatcher)))))))
354 (defn root-size
355 ([layer font-context]
356 (root-size layer font-context nil))
357 ([layer font-context target]
358 (binding [*root* layer
359 *target* target
360 *font-context* font-context]
361 (layer-size layer))))
363 ;;
364 ;; EventDispatcher implementation
365 ;;
367 (def awt-events
368 {java.awt.event.MouseEvent/MOUSE_CLICKED :mouse-clicked
369 java.awt.event.MouseEvent/MOUSE_DRAGGED :mouse-dragged
370 java.awt.event.MouseEvent/MOUSE_ENTERED :mouse-entered
371 java.awt.event.MouseEvent/MOUSE_EXITED :mouse-exited
372 java.awt.event.MouseEvent/MOUSE_MOVED :mouse-moved
373 java.awt.event.MouseEvent/MOUSE_PRESSED :mouse-pressed
374 java.awt.event.MouseEvent/MOUSE_RELEASED :mouse-released})
376 (def dummy-event-dispatcher
377 (reify
378 EventDispatcher
379 (listen! [this component])
380 (create-dispatcher [this handle handlers] this)
381 (commit [this])))
383 (defrecord DispatcherNode [handle handlers parent
384 ^Shape clip ^AffineTransform transform
385 bindings]
386 EventDispatcher
387 (listen! [this component]
388 (listen! parent component))
389 (create-dispatcher [this handle handlers]
390 (create-dispatcher parent handle handlers))
391 (commit [this]
392 (commit parent)))
394 (defn- make-node [handle handlers]
395 (DispatcherNode. handle handlers *event-dispatcher* *clip*
396 (inverse-relative-transform)
397 (get-thread-bindings)))
399 (defn- add-node [tree node]
400 (assoc-cons tree (:parent node) node))
402 (defn- under-cursor
403 "Returns a vector of child nodes under cursor."
404 [x y tree node]
405 (some #(if (.contains ^Shape (:clip %) x y)
406 (conj (vec (under-cursor x y tree %)) %))
407 (get tree node)))
409 (defn- remove-all [coll1 coll2 pred]
410 (filter #(not (some (partial pred %) coll2)) coll1))
412 (defn- transform [^AffineTransform tr x y]
413 (let [p (Point2D$Double. x y)]
414 (.transform tr p p)
415 [(.x p) (.y p)]))
417 (defn- translate-mouse-event [^java.awt.event.MouseEvent event
418 ^AffineTransform tr id]
419 (let [[x y] (transform tr (.getX event) (.getY event))]
420 (MouseEvent. id (.getWhen event) x y
421 (.getXOnScreen event) (.getYOnScreen event)
422 (.getButton event))))
424 (defn- translate-and-dispatch
425 ([nodes first-only ^java.awt.event.MouseEvent event]
426 (translate-and-dispatch nodes first-only
427 event (awt-events (.getID event))))
428 ([nodes first-only event id]
429 (if-let [node (first nodes)]
430 (if-let [handler (get (:handlers node) id)]
431 (do
432 (with-bindings* (:bindings node)
433 handler
434 (translate-mouse-event event (:transform node) id))
435 (if-not first-only
436 (recur (rest nodes) false event id)))
437 (recur (rest nodes) first-only event id)))))
439 (defn- dispatch-mouse-motion
440 "Dispatches mouse motion events."
441 [hovered-ref tree root ^java.awt.event.MouseEvent event]
442 (let [x (.getX event)
443 y (.getY event)
444 [hovered hovered2] (dosync
445 [@hovered-ref
446 (ref-set hovered-ref
447 (under-cursor x y tree root))])
448 pred #(= (:handle %1) (:handle %2))
449 exited (remove-all hovered hovered2 pred)
450 entered (remove-all hovered2 hovered pred)
451 moved (remove-all hovered2 entered pred)]
452 (translate-and-dispatch exited false event :mouse-exited)
453 (translate-and-dispatch entered false event :mouse-entered)
454 (translate-and-dispatch moved true event :mouse-moved)))
456 (defn- dispatch-mouse-button
457 [picked-ref hovered-ref ^java.awt.event.MouseEvent event]
458 (let [id (awt-events (.getID event))
459 hovered (if (= id :mouse-pressed)
460 (dosync (ref-set picked-ref @hovered-ref))
461 @hovered-ref)]
462 (translate-and-dispatch hovered true event id)))
464 (defn root-event-dispatcher []
465 (let [tree-r (ref {}) ; register
466 tree (ref {}) ; dispatch
467 hovered (ref '())
468 picked (ref '())]
469 (reify
470 EventDispatcher
471 (listen! [this component]
472 (doto component
473 (.addMouseListener this)
474 (.addMouseMotionListener this)))
475 (create-dispatcher [this handle handlers]
476 (let [node (make-node handle handlers)]
477 (dosync (alter tree-r add-node node))
478 node))
479 (commit [this]
480 (dosync (ref-set tree @tree-r)
481 (ref-set tree-r {})))
482 MouseListener
483 (mouseEntered [this event]
484 (dispatch-mouse-motion hovered @tree this event))
485 (mouseExited [this event]
486 (dispatch-mouse-motion hovered @tree this event))
487 (mouseClicked [this event]
488 (dispatch-mouse-button picked hovered event))
489 (mousePressed [this event]
490 (dispatch-mouse-button picked hovered event))
491 (mouseReleased [this event]
492 (translate-and-dispatch @picked true event))
493 ;;(dispatch-mouse-button picked hovered event))
494 MouseMotionListener
495 (mouseDragged [this event]
496 (translate-and-dispatch @picked true event))
497 (mouseMoved [this event]
498 (dispatch-mouse-motion hovered @tree this event)))))
500 ;;
501 ;; ИДЕИ:
502 ;;
503 ;; Контекст: биндинги или запись?
504 ;;
505 ;; Установка обработчиков (в контексте слоя):
506 ;;
507 ;; (listen
508 ;; (:mouse-entered e
509 ;; ...)
510 ;; (:mouse-exited e
511 ;; ...))
512 ;;
513 ;; Не надо IMGUI.
514 ;; Построение сцены путем декорирования слоев:
515 ;;
516 ;; (listener
517 ;; (:action e (println e))
518 ;; (:mouse-dragged e (println e))
519 ;; (theme :font "Helvetica-14"
520 ;; (vbox
521 ;; (button (text-layer "Button 1"))
522 ;; (button (text-layer "Button 2")))))
523 ;;