view src/net/kryshen/indyvon/core.clj @ 129:137e64553123

Added root binding for *font-context*.
author Mikhail Kryshen <mikhail@kryshen.net>
date Fri, 13 Apr 2012 04:25:18 +0400
parents 911228da1bc8
children 24d4c9f3be90
line source
1 ;;
2 ;; Copyright 2010, 2011, 2012 Mikhail Kryshen <mikhail@kryshen.net>
3 ;;
4 ;; This file is part of Indyvon.
5 ;;
6 ;; Indyvon is free software: you can redistribute it and/or modify it
7 ;; under the terms of the GNU Lesser General Public License version 3
8 ;; only, as published by the Free Software Foundation.
9 ;;
10 ;; Indyvon is distributed in the hope that it will be useful, but
11 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
12 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13 ;; Lesser General Public License for more details.
14 ;;
15 ;; You should have received a copy of the GNU Lesser General Public
16 ;; License along with Indyvon. If not, see
17 ;; <http://www.gnu.org/licenses/>.
18 ;;
20 (ns net.kryshen.indyvon.core
21 (:import
22 (java.awt Graphics2D RenderingHints Component Color Font Shape
23 Rectangle Cursor EventQueue)
24 (java.awt.geom AffineTransform Point2D$Double Rectangle2D$Double Area)
25 (java.awt.event MouseListener MouseMotionListener
26 MouseWheelListener MouseWheelEvent)
27 (java.awt.font FontRenderContext)
28 java.util.concurrent.ConcurrentMap
29 com.google.common.collect.MapMaker))
31 ;;
32 ;; Layer context
33 ;;
35 (def ^:dynamic ^Graphics2D *graphics*)
37 (def ^:dynamic ^FontRenderContext *font-context*
38 "FontRenderContext to use when Graphics2D is not available."
39 (FontRenderContext.
40 nil
41 RenderingHints/VALUE_TEXT_ANTIALIAS_DEFAULT
42 RenderingHints/VALUE_FRACTIONALMETRICS_DEFAULT))
44 (def ^:dynamic *width*
45 "Width of the rendering area.")
47 (def ^:dynamic *height*
48 "Height of the rendering area.")
50 (def ^:dynamic ^Shape *clip*)
52 (def ^:dynamic ^Shape *input-clip*
53 "Clipping area used for dispatching pointer events (intersected with
54 *clip*). If nil, *clip* will be used.")
56 (def ^:dynamic *time*
57 "Timestamp of the current frame (in nanoseconds).")
59 (def ^:dynamic *scene*
60 "Encloses state that should be retained between repaints.")
62 (def ^:dynamic *states*
63 "Transient scene states, a map.")
65 (def ^:dynamic *event-dispatcher*)
67 (def ^:dynamic ^AffineTransform *initial-transform*
68 "Initial transform associated with the graphics context.")
70 (def ^:dynamic ^AffineTransform *inverse-initial-transform*
71 "Inversion of the initial transform associated with the graphics
72 context.")
74 (defrecord Theme [fore-color back-color alt-back-color border-color
75 shadow-color font])
77 ;; REMIND: use system colors, see java.awt.SystemColor.
78 (defn default-theme []
79 (Theme. Color/BLACK
80 Color/WHITE
81 (Color. 0xC8 0xD2 0xD8)
82 (Color. 0 0 0xC8)
83 (Color. 0x44 0x44 0x44)
84 (Font. "Sans" Font/PLAIN 12)))
86 (def ^:dynamic *theme* (default-theme))
88 ;;
89 ;; Core protocols and types
90 ;;
92 (defprotocol Layer
93 "Basic UI element."
94 (render! [layer]
95 "Draws layer in the current *graphics* context.")
96 (geometry [layer]
97 "Returns the preferred layer Geometry."))
99 (defprotocol Geometry
100 "Describes geometry of a Layer. Prefer using the available
101 implementations (Size, FixedGeometry and NestedGeometry) over
102 extending this protocol directly as it is likely to be changed in
103 the future versions."
104 (width [geom] [geom height])
105 (height [geom] [geom width])
106 (anchor-x [geom h-align width]
107 "Returns the x coordinate of the anchor point for the specified
108 horizontal alignment and width, h-align could be :left, :center
109 or :right.")
110 (anchor-y [geom v-align height]
111 "Returns the y coordinate of the anchor point for the specified
112 vertical alignment and height, v-align could be :top, :center
113 or :bottom."))
115 (defrecord Size [width height]
116 Geometry
117 (width [_] width)
118 (width [_ _] width)
119 (height [_] height)
120 (height [_ _] height)
121 (anchor-x [_ h-align width]
122 (case h-align
123 :left 0
124 :center (/ width 2)
125 :right width))
126 (anchor-y [_ v-align height]
127 (case v-align
128 :top 0
129 :center (/ height 2)
130 :bottom height)))
132 (defrecord FixedGeometry [ax ay width height]
133 Geometry
134 (width [_] width)
135 (width [_ _] width)
136 (height [_] height)
137 (height [_ _] height)
138 (anchor-x [_ _ _] ax)
139 (anchor-y [_ _ _] ay))
141 (defrecord NestedGeometry [geometry top left bottom right]
142 Geometry
143 (width [_]
144 (+ left right (width geometry)))
145 (width [_ h]
146 (+ left right (width geometry (- h top bottom))))
147 (height [_]
148 (+ top bottom (height geometry)))
149 (height [_ w]
150 (+ top bottom (height geometry (- w left right))))
151 (anchor-x [_ h-align w]
152 (+ left (anchor-x geometry h-align (- w left right))))
153 (anchor-y [_ v-align h]
154 (+ top (anchor-y geometry v-align (- h top bottom)))))
156 (defrecord ScaledGeometry [geometry sx sy]
157 Geometry
158 (width [_]
159 (* sx (width geometry)))
160 (width [_ h]
161 (* sx (width geometry (/ h sy))))
162 (height [_]
163 (* sy (height geometry)))
164 (height [_ w]
165 (* sy (height geometry (/ w sx))))
166 (anchor-x [_ h-align w]
167 (* sx (anchor-x geometry h-align (/ w sx))))
168 (anchor-y [_ v-align h]
169 (* sy (anchor-y geometry v-align (/ h sy)))))
171 ;; (defn ^:private to-integer
172 ;; ^long [align x]
173 ;; (if (integer? x)
174 ;; x
175 ;; (let [x (double x)]
176 ;; (Math/round
177 ;; (case align
178 ;; (:top :left) (Math/floor x)
179 ;; :center x
180 ;; (:bottom :right) (Math/ceil x))))))
182 ;; (defrecord IntegerGeometry [geometry]
183 ;; Geometry
184 ;; (width [_]
185 ;; (to-integer :right (width geometry)))
186 ;; (width [_ h]
187 ;; (to-integer :right (width geometry h)))
188 ;; (height [_]
189 ;; (to-integer :bottom (height geometry)))
190 ;; (height [_ w]
191 ;; (to-integer :bottom (height geometry w)))
192 ;; (anchor-x [_ h-align w]
193 ;; (to-integer h-align (anchor-x geometry h-align w)))
194 ;; (anchor-y [_ v-align h]
195 ;; (to-integer v-align (anchor-y geometry v-align h))))
197 ;; TODO: modifiers
198 (defrecord MouseEvent [id when x y x-on-screen y-on-screen button
199 wheel-rotation])
201 ;; TODO: KeyEvent
203 (defprotocol EventDispatcher
204 (listen! [this component]
205 "Listen for events on the specified AWT Component.")
206 (create-dispatcher [this handle handlers]
207 "Returns new event dispatcher associated with the specified event
208 handlers (an event-id -> handler-fn map). Handle is used to
209 match the contexts between commits.")
210 (commit [this]
211 "Apply the registered handlers for event processing.")
212 (handle-picked? [this handle]
213 "Returns true if the specified handle received the :mouse-pressed
214 event and have not yet received :moused-released.")
215 (handle-hovered? [this handle]
216 "Returns true if the specified handle received the :mouse-entered
217 event and have not yet received :mouse-exited."))
219 (defn- assoc-cons [m key val]
220 (->> (get m key) (cons val) (assoc m key)))
222 ;;
223 ;; Observers
224 ;; The mechanism used by layers to request repaints
225 ;;
227 (def ^ConcurrentMap observers
228 (-> (MapMaker.) (.weakKeys) (.makeMap)))
230 (defn- cm-replace!
231 "Wrap ConcurrentMap replace method to treat nil value as absent
232 mapping. Use with maps that does not support nil values."
233 [^ConcurrentMap cmap key old new]
234 (if (nil? old)
235 (nil? (.putIfAbsent cmap key new))
236 (.replace cmap key old new)))
238 (defn- cm-swap!
239 "Atomically swaps the value associated with key in ConcurrentMap
240 to be (apply f current-value args). Returns the new value."
241 [^ConcurrentMap cmap key f & args]
242 (loop []
243 (let [old (.get cmap key)
244 new (apply f old args)]
245 (if (cm-replace! cmap key old new)
246 new
247 (recur)))))
249 (defn add-observer
250 "Add observer fn for the target. Watcher identifies the group of
251 observers and could be used to remove the group. Watcher is weakly
252 referenced, all associated observers will be removed when the
253 wathcer is removed by gc. The observer fn will be called with
254 watcher and target arguments and any additional arguments specified
255 in update call."
256 [watcher target f]
257 (cm-swap! observers watcher assoc-cons target f)
258 nil)
260 (defn remove-observers
261 "Remove group of observers associated with the specified watcher."
262 [watcher]
263 (.remove observers watcher)
264 nil)
266 (defn- replace-observers-watcher
267 [old-watcher new-watcher]
268 (if-let [old (.remove observers old-watcher)]
269 (.put observers new-watcher old))
270 nil)
272 (defn update
273 "Notify observers."
274 [target & args]
275 (doseq [entry observers
276 f (get (val entry) target)]
277 (apply f (key entry) target args)))
279 (defn add-context-observer
280 "Observer registered with this function will be automatically
281 removed after the next repaint is complete."
282 [target f]
283 (add-observer *scene* target f))
285 (defn repaint-on-update
286 "Trigger repaint of the current scene when the target updates."
287 [target]
288 (let [scene *scene*]
289 (if-not (identical? scene target)
290 (add-observer scene target (fn [w _] (update w))))))
292 (defn repaint
293 "Requests repaint of the current scene. If handle and state are
294 specified, the handle will be associated with the state in the
295 *states* map for the next paint iteration."
296 ([]
297 (update *scene*))
298 ([handle state]
299 (let [scene *scene*]
300 (swap! (:next-state scene) assoc handle state)
301 (update scene))))
303 ;;
304 ;; Rendering
305 ;;
307 (defn ^FontRenderContext font-context
308 "Returns FontRenderContext for the current Layer context."
309 []
310 (if (bound? (var *graphics*))
311 (.getFontRenderContext *graphics*)
312 *font-context*))
314 (defn ^AffineTransform relative-transform
315 "Returns AffineTransform: layer context -> AWT component."
316 []
317 (let [tr (.getTransform *graphics*)]
318 (.preConcatenate tr *inverse-initial-transform*)
319 tr))
321 (defn ^AffineTransform inverse-relative-transform
322 "Returns AffineTransform: AWT component -> layer context."
323 []
324 (let [tr (.getTransform *graphics*)]
325 (.invert tr) ; absolute -> layer
326 (.concatenate tr *initial-transform*) ; component -> absolute
327 tr))
329 (defn transform-point [^AffineTransform tr x y]
330 (let [p (Point2D$Double. x y)]
331 (.transform tr p p)
332 [(.x p) (.y p)]))
334 ;; (defn- clip
335 ;; "Intersect clipping area with the specified shape or bounds.
336 ;; Returns new clip (Shape or nil if empty)."
337 ;; ([x y w h]
338 ;; (clip (Rectangle2D$Double. x y w h)))
339 ;; ([shape]
340 ;; (let [a1 (Area. shape)
341 ;; a2 (if (instance? Area *clip*) *clip* (Area. *clip*))]
342 ;; (.transform a1 (relative-transform))
343 ;; (.intersect a1 a2)
344 ;; (if (.isEmpty a1)
345 ;; nil
346 ;; a1))))
348 ;; Use faster clipping calculation provided by Graphics2D.
349 (defn- clip
350 "Intersect clipping area with the specified Shape in current
351 transform coordinates. Returns new clip in the AWT component
352 coordinates (Shape or nil if empty)."
353 [^Shape shape]
354 (let [^Graphics2D clip-g (.create *graphics*)]
355 (try
356 (doto clip-g
357 (.setClip shape)
358 (.setTransform *initial-transform*)
359 (.clip *clip*))
360 (if (.isEmpty (.getClipBounds clip-g))
361 nil
362 (.getClip clip-g))
363 (finally
364 (.dispose clip-g)))))
366 (defn- ^Graphics2D apply-theme
367 "Set graphics' color and font to match theme.
368 Modifies and returns the first argument."
369 ([]
370 (apply-theme *graphics* *theme*))
371 ([^Graphics2D graphics theme]
372 (doto graphics
373 (.setColor (:fore-color theme))
374 (.setFont (:font theme)))))
376 (defn- ^Graphics2D create-graphics
377 ([]
378 (apply-theme (.create *graphics*) *theme*))
379 ([^long x ^long y ^long w ^long h]
380 (apply-theme (.create *graphics* x y w h) *theme*)))
382 (defn- with-bounds-noclip*
383 [x y w h f & args]
384 (let [graphics (create-graphics)]
385 (try
386 (.translate graphics (double x) (double y))
387 (binding [*width* w
388 *height* h
389 *input-clip* (Rectangle2D$Double. 0.0 0.0 w h)
390 *graphics* graphics]
391 (apply f args))
392 (finally
393 (.dispose graphics)))))
395 (defn with-bounds*
396 [x y w h f & args]
397 (let [x (long x)
398 y (long y)
399 w (long w)
400 h (long h)]
401 (when-let [clip (clip (Rectangle. x y w h))]
402 (let [^Graphics2D graphics (create-graphics x y w h)]
403 (try
404 (binding [*width* w
405 *height* h
406 *clip* clip
407 *input-clip* nil
408 *graphics* graphics]
409 (apply f args))
410 (finally
411 (.dispose graphics)))))))
413 (defmacro with-bounds
414 [x y w h & body]
415 `(with-bounds* ~x ~y ~w ~h (fn [] ~@body)))
417 (defmacro with-theme
418 [theme & body]
419 `(binding [*theme* (merge *theme* ~theme)]
420 ~@body))
422 (defmacro with-color
423 [color-or-keyword & body]
424 (let [color-form (if (keyword? color-or-keyword)
425 `(~color-or-keyword *theme*)
426 color-or-keyword)]
427 `(let [color# ~color-form
428 g# *graphics*
429 old-color# (.getColor g#)]
430 (try
431 (.setColor g# color#)
432 ~@body
433 (finally
434 (.setColor g# old-color#))))))
436 (defmacro with-stroke [stroke & body]
437 `(let [g# *graphics*
438 old-stroke# (.getStroke g#)]
439 (try
440 (.setStroke g# ~stroke)
441 ~@body
442 (finally
443 (.setStroke g# old-stroke#)))))
445 (defn with-hints*
446 [hints f & args]
447 (if hints
448 (let [g *graphics*
449 old (.getRenderingHints g)]
450 (try
451 (.addRenderingHints g hints)
452 (apply f args)
453 (finally
454 (.setRenderingHints g old))))
455 (apply f args)))
457 (defmacro with-hints
458 [hints & body]
459 `(with-hints ~hints (fn [] ~@body)))
461 ;; TODO: constructor for AffineTransform.
462 ;; (transform :scale 0.3 0.5
463 ;; :translate 5 10
464 ;; :rotate (/ Math/PI 2))
466 (defmacro with-transform [transform & body]
467 `(let [g# *graphics*
468 old-t# (.getTransform g#)]
469 (try
470 (.transform g# ~transform)
471 ~@body
472 (finally
473 (.setTransform g# old-t#)))))
475 (defmacro with-rotate [theta ax ay & body]
476 `(let [transform# (AffineTransform/getRotateInstance ~theta ~ax ~ay)]
477 (with-transform transform# ~@body)))
479 (defmacro with-translate [x y & body]
480 `(let [x# ~x
481 y# ~y
482 g# *graphics*]
483 (try
484 (.translate g# x# y#)
485 ~@body
486 (finally
487 (.translate g# (- x#) (- y#))))))
489 (defn draw!
490 "Draws layer."
491 ([layer]
492 (let [graphics (create-graphics)]
493 (try
494 (binding [*graphics* graphics]
495 (render! layer))
496 (finally
497 (.dispose graphics)))))
498 ([layer x y]
499 (draw! layer x y true))
500 ([layer x y clip?]
501 (let [geom (geometry layer)]
502 (draw! layer x y (width geom) (height geom) clip?)))
503 ([layer x y width height]
504 (draw! layer x y width height true))
505 ([layer x y width height clip?]
506 (if clip?
507 (with-bounds* x y width height render! layer)
508 (with-bounds-noclip* x y width height render! layer))))
510 (defn draw-aligned!
511 "Draws layer. Location is relative to the layer's anchor point for
512 the specified alignment."
513 ([layer h-align v-align x y]
514 (let [geom (geometry layer)
515 w (width geom)
516 h (height geom)]
517 (draw! layer
518 (- x (anchor-x geom h-align w))
519 (- y (anchor-y geom v-align h))
520 w h)))
521 ([layer h-align v-align x y w h]
522 (let [geom (geometry layer)]
523 (draw! layer
524 (- x (anchor-x geom h-align w))
525 (- y (anchor-y geom v-align h))
526 w h))))
528 ;;
529 ;; Event handling.
530 ;;
532 (defn with-handlers*
533 [handle handlers f & args]
534 (binding [*event-dispatcher* (create-dispatcher
535 *event-dispatcher* handle handlers)]
536 (apply f args)))
538 (defmacro with-handlers
539 "specs => (:event-id name & handler-body)*
541 Execute form with the specified event handlers."
542 [handle form & specs]
543 `(with-handlers* ~handle
544 ~(reduce (fn [m spec]
545 (assoc m (first spec)
546 `(fn [~(second spec)]
547 ~@(nnext spec)))) {}
548 specs)
549 (fn [] ~form)))
551 (defn picked? [handle]
552 (handle-picked? *event-dispatcher* handle))
554 (defn hovered? [handle]
555 (handle-hovered? *event-dispatcher* handle))
557 ;;
558 ;; EventDispatcher implementation
559 ;;
561 (def awt-events
562 {java.awt.event.MouseEvent/MOUSE_CLICKED :mouse-clicked
563 java.awt.event.MouseEvent/MOUSE_DRAGGED :mouse-dragged
564 java.awt.event.MouseEvent/MOUSE_ENTERED :mouse-entered
565 java.awt.event.MouseEvent/MOUSE_EXITED :mouse-exited
566 java.awt.event.MouseEvent/MOUSE_MOVED :mouse-moved
567 java.awt.event.MouseEvent/MOUSE_PRESSED :mouse-pressed
568 java.awt.event.MouseEvent/MOUSE_RELEASED :mouse-released
569 java.awt.event.MouseEvent/MOUSE_WHEEL :mouse-wheel})
571 (def dummy-event-dispatcher
572 (reify EventDispatcher
573 (listen! [_ _])
574 (create-dispatcher [this _ _] this)
575 (commit [_])
576 (handle-picked? [_ _])
577 (handle-hovered? [_ _])))
579 (defrecord DispatcherNode [handle handlers parent
580 ^Shape clip ^AffineTransform transform
581 bindings]
582 EventDispatcher
583 (listen! [this component]
584 (listen! parent component))
585 (create-dispatcher [this handle handlers]
586 (create-dispatcher parent handle handlers))
587 (commit [this]
588 (commit parent))
589 (handle-picked? [this handle]
590 (handle-picked? parent handle))
591 (handle-hovered? [this handle]
592 (handle-hovered? parent handle)))
594 (defn- make-node [handle handlers]
595 (let [clip (if *input-clip*
596 (clip *input-clip*)
597 *clip*)
598 bindings (-> (get-thread-bindings)
599 (dissoc (var *graphics*))
600 (assoc (var *font-context*) (font-context)))]
601 (DispatcherNode. handle handlers *event-dispatcher* clip
602 (inverse-relative-transform)
603 bindings)))
605 (defn- add-node [tree node]
606 (assoc-cons tree (:parent node) node))
608 (defn- nodes [tree]
609 (apply concat (vals tree)))
611 (defn- under-cursor
612 "Returns a vector of child nodes under cursor."
613 [x y tree node]
614 (some #(if (and (:clip %)
615 (.contains ^Shape (:clip %) x y))
616 (conj (vec (under-cursor x y tree %)) %))
617 (get tree node)))
619 (defn- remove-all [coll1 coll2 pred]
620 (filter #(not (some (partial pred %) coll2)) coll1))
622 (defn- translate-mouse-event [^java.awt.event.MouseEvent event
623 ^AffineTransform tr id]
624 (let [[x y] (transform-point tr (.getX event) (.getY event))
625 rotation (if (instance? MouseWheelEvent event)
626 (.getWheelRotation ^MouseWheelEvent event)
627 nil)]
628 (MouseEvent. id (.getWhen event) x y
629 (.getXOnScreen event) (.getYOnScreen event)
630 (.getButton event)
631 rotation)))
633 (defn- translate-and-dispatch
634 ([nodes first-only ^java.awt.event.MouseEvent event]
635 (translate-and-dispatch nodes first-only
636 event (awt-events (.getID event))))
637 ([nodes first-only event id]
638 (if-let [node (first nodes)]
639 (if-let [handler (get (:handlers node) id)]
640 (do
641 (let [translated (translate-mouse-event event (:transform node) id)]
642 (with-bindings* (:bindings node)
643 handler translated))
644 (if-not first-only
645 (recur (rest nodes) false event id)))
646 (recur (rest nodes) first-only event id)))))
648 (defn- dispatch-mouse-motion
649 "Dispatches mouse motion events."
650 [hovered-ref tree root ^java.awt.event.MouseEvent event]
651 (let [x (.getX event)
652 y (.getY event)
653 [hovered hovered2] (dosync
654 [@hovered-ref
655 (ref-set hovered-ref
656 (under-cursor x y tree root))])
657 pred #(= (:handle %1) (:handle %2))
658 exited (remove-all hovered hovered2 pred)
659 entered (remove-all hovered2 hovered pred)
660 moved (remove-all hovered2 entered pred)]
661 (translate-and-dispatch exited false event :mouse-exited)
662 (translate-and-dispatch entered false event :mouse-entered)
663 (translate-and-dispatch moved true event :mouse-moved)))
665 (defn- dispatch-mouse-button
666 [picked-ref hovered-ref ^java.awt.event.MouseEvent event]
667 (let [id (awt-events (.getID event))
668 nodes (case id
669 :mouse-pressed
670 (dosync
671 (ref-set picked-ref @hovered-ref))
672 :mouse-released
673 (dosync
674 (let [picked @picked-ref]
675 (ref-set picked-ref nil)
676 picked))
677 @hovered-ref)]
678 (translate-and-dispatch nodes true event id)))
680 (defn root-event-dispatcher []
681 (let [tree-r (ref {}) ; register
682 tree (ref {}) ; dispatch
683 hovered (ref '())
684 picked (ref '())]
685 (reify
686 EventDispatcher
687 (listen! [this component]
688 (doto ^Component component
689 (.addMouseListener this)
690 (.addMouseWheelListener this)
691 (.addMouseMotionListener this)))
692 (create-dispatcher [this handle handlers]
693 (let [node (make-node handle handlers)]
694 (dosync (alter tree-r add-node node))
695 node))
696 (commit [this]
697 ;; TODO: retain contexts that do not intersect graphics
698 ;; clipping area in tree.
699 (dosync (ref-set tree @tree-r)
700 (ref-set tree-r {})))
701 (handle-picked? [this handle]
702 (some #(= handle (:handle %)) @picked))
703 (handle-hovered? [this handle]
704 (some #(= handle (:handle %)) @hovered))
705 MouseListener
706 (mouseEntered [this event]
707 (dispatch-mouse-motion hovered @tree this event))
708 (mouseExited [this event]
709 (dispatch-mouse-motion hovered @tree this event))
710 (mouseClicked [this event]
711 (dispatch-mouse-button picked hovered event))
712 (mousePressed [this event]
713 (dispatch-mouse-button picked hovered event))
714 (mouseReleased [this event]
715 (dispatch-mouse-button picked hovered event))
716 MouseWheelListener
717 (mouseWheelMoved [this event]
718 (dispatch-mouse-button picked hovered event))
719 MouseMotionListener
720 (mouseDragged [this event]
721 (translate-and-dispatch @picked true event))
722 (mouseMoved [this event]
723 (dispatch-mouse-motion hovered @tree this event)))))
725 ;;
726 ;; Scene
727 ;;
729 (defrecord Scene [layer
730 event-dispatcher
731 component
732 rendering-hints
733 next-state])
735 ;; Define rendering hints that affect font metrics to make sure that
736 ;; Graphics and Scene FontRenderContexts are consistent.
737 (def ^:private default-rendering-hints
738 {RenderingHints/KEY_TEXT_ANTIALIASING
739 RenderingHints/VALUE_TEXT_ANTIALIAS_DEFAULT,
740 RenderingHints/KEY_FRACTIONALMETRICS
741 RenderingHints/VALUE_FRACTIONALMETRICS_DEFAULT})
743 (defn make-scene
744 ([layer]
745 (make-scene layer dummy-event-dispatcher nil))
746 ([layer event-dispatcher]
747 (make-scene layer event-dispatcher nil))
748 ([layer event-dispatcher ^Component component]
749 (make-scene layer event-dispatcher component nil))
750 ([layer event-dispatcher ^Component component hints]
751 (let [hints (merge default-rendering-hints hints)]
752 (->Scene layer
753 event-dispatcher
754 component
755 hints
756 (atom nil)))))
758 (defn- get-and-set!
759 "Atomically sets the value of atom to newval and returns the old
760 value."
761 [atom newval]
762 (loop [v @atom]
763 (if (compare-and-set! atom v newval)
764 v
765 (recur @atom))))
767 (defn draw-scene!
768 [scene ^Graphics2D graphics width height]
769 (.addRenderingHints graphics (:rendering-hints scene))
770 (binding [*states* (get-and-set! (:next-state scene) nil)
771 *scene* scene
772 *graphics* graphics
773 *initial-transform* (.getTransform graphics)
774 *inverse-initial-transform* (-> graphics
775 .getTransform
776 .createInverse)
777 *event-dispatcher* (:event-dispatcher scene)
778 *width* width
779 *height* height
780 *clip* (Rectangle2D$Double. 0.0 0.0 width height)
781 *input-clip* nil
782 *time* (System/nanoTime)]
783 (apply-theme)
784 (let [tmp-watcher (Object.)]
785 ;; Keep current context observers until the rendering is
786 ;; complete. Some observers may be invoked twice if they
787 ;; appear in both groups until tmp-watcher is removed.
788 (replace-observers-watcher scene tmp-watcher)
789 (try
790 (render! (:layer scene))
791 (finally
792 (remove-observers tmp-watcher)
793 (commit (:event-dispatcher scene)))))))
795 (defn- scene-font-context [scene]
796 (let [hints (:rendering-hints scene)
797 ^Component c (:component scene)
798 t (if c (->> c
799 .getFont
800 (.getFontMetrics c)
801 .getFontRenderContext
802 .getTransform))]
803 (FontRenderContext.
804 t
805 (get hints RenderingHints/KEY_TEXT_ANTIALIASING)
806 (get hints RenderingHints/KEY_FRACTIONALMETRICS))))
808 (defn scene-geometry [scene]
809 (binding [*scene* scene
810 *font-context* (scene-font-context scene)]
811 (geometry (:layer scene))))
813 (defn set-cursor! [^Cursor cursor]
814 (when-let [^Component component (:component *scene*)]
815 (EventQueue/invokeLater #(.setCursor component cursor))))