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