Mercurial > hg > indyvon
view src/net/kryshen/indyvon/core.clj @ 125:11f2030257f9
Separate dynamic Var to specify clipping area for mouse events.
| author | Mikhail Kryshen <mikhail@kryshen.net> |
|---|---|
| date | Thu, 12 Apr 2012 19:40:05 +0400 |
| parents | 7b22c6d585f4 |
| children | 24c7935a8f06 |
line source
1 ;;
2 ;; Copyright 2010, 2011 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 *width*
38 "Width of the rendering area.")
40 (def ^:dynamic *height*
41 "Height of the rendering area.")
43 (def ^:dynamic ^Shape *clip*)
45 (def ^:dynamic ^Shape *input-clip*
46 "Clipping area used for dispatching pointer events (intersected with
47 *clip*). If nil, *clip* will be used.")
49 (def ^:dynamic *time*
50 "Timestamp of the current frame (in nanoseconds).")
52 (def ^:dynamic *scene*
53 "Encloses state that should be retained between repaints.")
55 (def ^:dynamic *states*
56 "Transient scene states, a map.")
58 (def ^:dynamic *event-dispatcher*)
60 (def ^:dynamic ^AffineTransform *initial-transform*
61 "Initial transform associated with the graphics context.")
63 (def ^:dynamic ^AffineTransform *inverse-initial-transform*
64 "Inversion of the initial transform associated with the graphics
65 context.")
67 (defrecord Theme [fore-color back-color alt-back-color border-color
68 shadow-color font])
70 ;; REMIND: use system colors, see java.awt.SystemColor.
71 (defn default-theme []
72 (Theme. Color/BLACK
73 Color/WHITE
74 (Color. 0xC8 0xD2 0xD8)
75 (Color. 0 0 0xC8)
76 (Color. 0x44 0x44 0x44)
77 (Font. "Sans" Font/PLAIN 12)))
79 (def ^:dynamic *theme* (default-theme))
81 ;;
82 ;; Core protocols and types
83 ;;
85 (defprotocol Layer
86 "Basic UI element."
87 (render! [layer]
88 "Draws layer in the current *graphics* context.")
89 (geometry [layer]
90 "Returns the preferred layer Geometry."))
92 (defprotocol Geometry
93 "Describes geometry of a Layer. Prefer using the available
94 implementations (Size, FixedGeometry and NestedGeometry) over
95 extending this protocol directly as it is likely to be changed in
96 the future versions."
97 (width [geom] [geom height])
98 (height [geom] [geom width])
99 (anchor-x [geom h-align width]
100 "Returns the x coordinate of the anchor point for the specified
101 horizontal alignment and width, h-align could be :left, :center
102 or :right.")
103 (anchor-y [geom v-align height]
104 "Returns the y coordinate of the anchor point for the specified
105 vertical alignment and height, v-align could be :top, :center
106 or :bottom."))
108 (defrecord Size [width height]
109 Geometry
110 (width [_] width)
111 (width [_ _] width)
112 (height [_] height)
113 (height [_ _] height)
114 (anchor-x [_ h-align width]
115 (case h-align
116 :left 0
117 :center (/ width 2)
118 :right width))
119 (anchor-y [_ v-align height]
120 (case v-align
121 :top 0
122 :center (/ height 2)
123 :bottom height)))
125 (defrecord FixedGeometry [ax ay width height]
126 Geometry
127 (width [_] width)
128 (width [_ _] width)
129 (height [_] height)
130 (height [_ _] height)
131 (anchor-x [_ _ _] ax)
132 (anchor-y [_ _ _] ay))
134 (defrecord NestedGeometry [geometry top left bottom right]
135 Geometry
136 (width [_]
137 (+ left right (width geometry)))
138 (width [_ h]
139 (+ left right (width geometry (- h top bottom))))
140 (height [_]
141 (+ top bottom (height geometry)))
142 (height [_ w]
143 (+ top bottom (height geometry (- w left right))))
144 (anchor-x [_ h-align w]
145 (+ left (anchor-x geometry h-align (- w left right))))
146 (anchor-y [_ v-align h]
147 (+ top (anchor-y geometry v-align (- h top bottom)))))
149 (defrecord ScaledGeometry [geometry sx sy]
150 Geometry
151 (width [_]
152 (* sx (width geometry)))
153 (width [_ h]
154 (* sx (width geometry (/ h sy))))
155 (height [_]
156 (* sy (height geometry)))
157 (height [_ w]
158 (* sy (height geometry (/ w sx))))
159 (anchor-x [_ h-align w]
160 (* sx (anchor-x geometry h-align (/ w sx))))
161 (anchor-y [_ v-align h]
162 (* sy (anchor-y geometry v-align (/ h sy)))))
164 ;; (defn ^:private to-integer
165 ;; ^long [align x]
166 ;; (if (integer? x)
167 ;; x
168 ;; (let [x (double x)]
169 ;; (Math/round
170 ;; (case align
171 ;; (:top :left) (Math/floor x)
172 ;; :center x
173 ;; (:bottom :right) (Math/ceil x))))))
175 ;; (defrecord IntegerGeometry [geometry]
176 ;; Geometry
177 ;; (width [_]
178 ;; (to-integer :right (width geometry)))
179 ;; (width [_ h]
180 ;; (to-integer :right (width geometry h)))
181 ;; (height [_]
182 ;; (to-integer :bottom (height geometry)))
183 ;; (height [_ w]
184 ;; (to-integer :bottom (height geometry w)))
185 ;; (anchor-x [_ h-align w]
186 ;; (to-integer h-align (anchor-x geometry h-align w)))
187 ;; (anchor-y [_ v-align h]
188 ;; (to-integer v-align (anchor-y geometry v-align h))))
190 ;; TODO: modifiers
191 (defrecord MouseEvent [id when x y x-on-screen y-on-screen button
192 wheel-rotation])
194 ;; TODO: KeyEvent
196 (defprotocol EventDispatcher
197 (listen! [this component]
198 "Listen for events on the specified AWT Component.")
199 (create-dispatcher [this handle handlers]
200 "Returns new event dispatcher associated with the specified event
201 handlers (an event-id -> handler-fn map). Handle is used to
202 match the contexts between commits.")
203 (commit [this]
204 "Apply the registered handlers for event processing.")
205 (handle-picked? [this handle]
206 "Returns true if the specified handle received the :mouse-pressed
207 event and have not yet received :moused-released.")
208 (handle-hovered? [this handle]
209 "Returns true if the specified handle received the :mouse-entered
210 event and have not yet received :mouse-exited."))
212 (defn- assoc-cons [m key val]
213 (->> (get m key) (cons val) (assoc m key)))
215 ;;
216 ;; Observers
217 ;; The mechanism used by layers to request repaints
218 ;;
220 (def ^ConcurrentMap observers
221 (-> (MapMaker.) (.weakKeys) (.makeMap)))
223 (defn- cm-replace!
224 "Wrap ConcurrentMap replace method to treat nil value as absent
225 mapping. Use with maps that does not support nil values."
226 [^ConcurrentMap cmap key old new]
227 (if (nil? old)
228 (nil? (.putIfAbsent cmap key new))
229 (.replace cmap key old new)))
231 (defn- cm-swap!
232 "Atomically swaps the value associated with key in ConcurrentMap
233 to be (apply f current-value args). Returns the new value."
234 [^ConcurrentMap cmap key f & args]
235 (loop []
236 (let [old (.get cmap key)
237 new (apply f old args)]
238 (if (cm-replace! cmap key old new)
239 new
240 (recur)))))
242 (defn add-observer
243 "Add observer fn for the target. Watcher identifies the group of
244 observers and could be used to remove the group. Watcher is weakly
245 referenced, all associated observers will be removed when the
246 wathcer is removed by gc. The observer fn will be called with
247 watcher and target arguments and any additional arguments specified
248 in update call."
249 [watcher target f]
250 (cm-swap! observers watcher assoc-cons target f)
251 nil)
253 (defn remove-observers
254 "Remove group of observers associated with the specified watcher."
255 [watcher]
256 (.remove observers watcher)
257 nil)
259 (defn- replace-observers-watcher
260 [old-watcher new-watcher]
261 (if-let [old (.remove observers old-watcher)]
262 (.put observers new-watcher old))
263 nil)
265 (defn update
266 "Notify observers."
267 [target & args]
268 (doseq [entry observers
269 f (get (val entry) target)]
270 (apply f (key entry) target args)))
272 (defn add-context-observer
273 "Observer registered with this function will be automatically
274 removed after the next repaint is complete."
275 [target f]
276 (add-observer *scene* target f))
278 (defn repaint-on-update
279 "Trigger repaint of the current scene when the target updates."
280 [target]
281 (let [scene *scene*]
282 (if-not (identical? scene target)
283 (add-observer scene target (fn [w _] (update w))))))
285 (defn repaint
286 "Requests repaint of the current scene. If handle and state are
287 specified, the handle will be associated with the state in the
288 *states* map for the next paint iteration."
289 ([]
290 (update *scene*))
291 ([handle state]
292 (let [scene *scene*]
293 (swap! (:next-state scene) assoc handle state)
294 (update scene))))
296 ;;
297 ;; Rendering
298 ;;
300 (defn ^FontRenderContext font-context
301 "Returns FontRenderContext for the current Layer context."
302 []
303 (if (bound? (var *graphics*))
304 (.getFontRenderContext *graphics*)
305 (let [scene *scene*]
306 (if-let [^Component c (:component scene)]
307 (.getFontRenderContext (.getFontMetrics c (.getFont c)))
308 (:font-context scene)))))
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 (DispatcherNode. handle handlers *event-dispatcher* clip
595 (inverse-relative-transform)
596 (get-thread-bindings))))
598 (defn- add-node [tree node]
599 (assoc-cons tree (:parent node) node))
601 (defn- nodes [tree]
602 (apply concat (vals tree)))
604 (defn- under-cursor
605 "Returns a vector of child nodes under cursor."
606 [x y tree node]
607 (some #(if (and (:clip %)
608 (.contains ^Shape (:clip %) x y))
609 (conj (vec (under-cursor x y tree %)) %))
610 (get tree node)))
612 (defn- remove-all [coll1 coll2 pred]
613 (filter #(not (some (partial pred %) coll2)) coll1))
615 (defn- translate-mouse-event [^java.awt.event.MouseEvent event
616 ^AffineTransform tr id]
617 (let [[x y] (transform-point tr (.getX event) (.getY event))
618 rotation (if (instance? MouseWheelEvent event)
619 (.getWheelRotation ^MouseWheelEvent event)
620 nil)]
621 (MouseEvent. id (.getWhen event) x y
622 (.getXOnScreen event) (.getYOnScreen event)
623 (.getButton event)
624 rotation)))
626 (defn- translate-and-dispatch
627 ([nodes first-only ^java.awt.event.MouseEvent event]
628 (translate-and-dispatch nodes first-only
629 event (awt-events (.getID event))))
630 ([nodes first-only event id]
631 (if-let [node (first nodes)]
632 (if-let [handler (get (:handlers node) id)]
633 (do
634 (let [translated (translate-mouse-event event (:transform node) id)]
635 (with-bindings* (:bindings node)
636 handler translated))
637 (if-not first-only
638 (recur (rest nodes) false event id)))
639 (recur (rest nodes) first-only event id)))))
641 (defn- dispatch-mouse-motion
642 "Dispatches mouse motion events."
643 [hovered-ref tree root ^java.awt.event.MouseEvent event]
644 (let [x (.getX event)
645 y (.getY event)
646 [hovered hovered2] (dosync
647 [@hovered-ref
648 (ref-set hovered-ref
649 (under-cursor x y tree root))])
650 pred #(= (:handle %1) (:handle %2))
651 exited (remove-all hovered hovered2 pred)
652 entered (remove-all hovered2 hovered pred)
653 moved (remove-all hovered2 entered pred)]
654 (translate-and-dispatch exited false event :mouse-exited)
655 (translate-and-dispatch entered false event :mouse-entered)
656 (translate-and-dispatch moved true event :mouse-moved)))
658 (defn- dispatch-mouse-button
659 [picked-ref hovered-ref ^java.awt.event.MouseEvent event]
660 (let [id (awt-events (.getID event))
661 nodes (case id
662 :mouse-pressed
663 (dosync
664 (ref-set picked-ref @hovered-ref))
665 :mouse-released
666 (dosync
667 (let [picked @picked-ref]
668 (ref-set picked-ref nil)
669 picked))
670 @hovered-ref)]
671 (translate-and-dispatch nodes true event id)))
673 (defn root-event-dispatcher []
674 (let [tree-r (ref {}) ; register
675 tree (ref {}) ; dispatch
676 hovered (ref '())
677 picked (ref '())]
678 (reify
679 EventDispatcher
680 (listen! [this component]
681 (doto ^Component component
682 (.addMouseListener this)
683 (.addMouseWheelListener this)
684 (.addMouseMotionListener this)))
685 (create-dispatcher [this handle handlers]
686 (let [node (make-node handle handlers)]
687 (dosync (alter tree-r add-node node))
688 node))
689 (commit [this]
690 ;; TODO: retain contexts that do not intersect graphics
691 ;; clipping area in tree.
692 (dosync (ref-set tree @tree-r)
693 (ref-set tree-r {})))
694 (handle-picked? [this handle]
695 (some #(= handle (:handle %)) @picked))
696 (handle-hovered? [this handle]
697 (some #(= handle (:handle %)) @hovered))
698 MouseListener
699 (mouseEntered [this event]
700 (dispatch-mouse-motion hovered @tree this event))
701 (mouseExited [this event]
702 (dispatch-mouse-motion hovered @tree this event))
703 (mouseClicked [this event]
704 (dispatch-mouse-button picked hovered event))
705 (mousePressed [this event]
706 (dispatch-mouse-button picked hovered event))
707 (mouseReleased [this event]
708 (dispatch-mouse-button picked hovered event))
709 MouseWheelListener
710 (mouseWheelMoved [this event]
711 (dispatch-mouse-button picked hovered event))
712 MouseMotionListener
713 (mouseDragged [this event]
714 (translate-and-dispatch @picked true event))
715 (mouseMoved [this event]
716 (dispatch-mouse-motion hovered @tree this event)))))
718 ;;
719 ;; Scene
720 ;;
722 (defrecord Scene [layer
723 event-dispatcher
724 component
725 rendering-hints
726 font-context
727 next-state])
729 ;; Define rendering hints that affect font metrics to make sure that
730 ;; Graphics and Scene FontRenderContexts are consistent.
731 (def ^:private default-rendering-hints
732 {RenderingHints/KEY_TEXT_ANTIALIASING
733 RenderingHints/VALUE_TEXT_ANTIALIAS_DEFAULT,
734 RenderingHints/KEY_FRACTIONALMETRICS
735 RenderingHints/VALUE_FRACTIONALMETRICS_DEFAULT})
737 (defn make-scene
738 ([layer]
739 (make-scene layer dummy-event-dispatcher nil))
740 ([layer event-dispatcher]
741 (make-scene layer event-dispatcher nil))
742 ([layer event-dispatcher ^Component component]
743 (make-scene layer event-dispatcher component nil))
744 ([layer event-dispatcher ^Component component hints]
745 (let [hints (merge default-rendering-hints hints)]
746 (->Scene layer
747 event-dispatcher
748 component
749 hints
750 (FontRenderContext.
751 nil
752 (get hints RenderingHints/KEY_TEXT_ANTIALIASING)
753 (get hints RenderingHints/KEY_FRACTIONALMETRICS))
754 (atom nil)))))
756 (defn- get-and-set!
757 "Atomically sets the value of atom to newval and returns the old
758 value."
759 [atom newval]
760 (loop [v @atom]
761 (if (compare-and-set! atom v newval)
762 v
763 (recur @atom))))
765 (defn draw-scene!
766 [scene ^Graphics2D graphics width height]
767 (.addRenderingHints graphics (:rendering-hints scene))
768 (binding [*states* (get-and-set! (:next-state scene) nil)
769 *scene* scene
770 *graphics* graphics
771 *initial-transform* (.getTransform graphics)
772 *inverse-initial-transform* (-> graphics
773 .getTransform
774 .createInverse)
775 *event-dispatcher* (:event-dispatcher scene)
776 *width* width
777 *height* height
778 *clip* (Rectangle2D$Double. 0.0 0.0 width height)
779 *input-clip* nil
780 *time* (System/nanoTime)]
781 (apply-theme)
782 (let [tmp-watcher (Object.)]
783 ;; Keep current context observers until the rendering is
784 ;; complete. Some observers may be invoked twice if they
785 ;; appear in both groups until tmp-watcher is removed.
786 (replace-observers-watcher scene tmp-watcher)
787 (try
788 (render! (:layer scene))
789 (finally
790 (remove-observers tmp-watcher)
791 (commit (:event-dispatcher scene)))))))
793 (defn scene-geometry [scene]
794 (binding [*scene* scene]
795 (geometry (:layer scene))))
797 (defn set-cursor! [^Cursor cursor]
798 (when-let [^Component component (:component *scene*)]
799 (EventQueue/invokeLater #(.setCursor component cursor))))