Mercurial > hg > indyvon
view src/net/kryshen/indyvon/core.clj @ 122:17aa55059b07
Added with-stroke macro.
| author | Mikhail Kryshen <mikhail@kryshen.net> |
|---|---|
| date | Fri, 06 Apr 2012 19:19:13 +0400 |
| parents | b5ac04d5fc8a |
| children | 7b22c6d585f4 |
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 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 *clipped*
46 "True value indicates that *clip* is a subset of
47 (Rectangle. 0 0 *width* *height*).")
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 ;; TODO: modifiers
165 (defrecord MouseEvent [id when x y x-on-screen y-on-screen button
166 wheel-rotation])
168 ;; TODO: KeyEvent
170 (defprotocol EventDispatcher
171 (listen! [this component]
172 "Listen for events on the specified AWT Component.")
173 (create-dispatcher [this handle handlers]
174 "Returns new event dispatcher associated with the specified event
175 handlers (an event-id -> handler-fn map). Handle is used to
176 match the contexts between commits.")
177 (commit [this]
178 "Apply the registered handlers for event processing.")
179 (handle-picked? [this handle]
180 "Returns true if the specified handle received the :mouse-pressed
181 event and have not yet received :moused-released.")
182 (handle-hovered? [this handle]
183 "Returns true if the specified handle received the :mouse-entered
184 event and have not yet received :mouse-exited."))
186 (defn- assoc-cons [m key val]
187 (->> (get m key) (cons val) (assoc m key)))
189 ;;
190 ;; Observers
191 ;; The mechanism used by layers to request repaints
192 ;;
194 (def ^ConcurrentMap observers
195 (-> (MapMaker.) (.weakKeys) (.makeMap)))
197 (defn- cm-replace!
198 "Wrap ConcurrentMap replace method to treat nil value as absent
199 mapping. Use with maps that does not support nil values."
200 [^ConcurrentMap cmap key old new]
201 (if (nil? old)
202 (nil? (.putIfAbsent cmap key new))
203 (.replace cmap key old new)))
205 (defn- cm-swap!
206 "Atomically swaps the value associated with key in ConcurrentMap
207 to be (apply f current-value args). Returns the new value."
208 [^ConcurrentMap cmap key f & args]
209 (loop []
210 (let [old (.get cmap key)
211 new (apply f old args)]
212 (if (cm-replace! cmap key old new)
213 new
214 (recur)))))
216 (defn add-observer
217 "Add observer fn for the target. Watcher identifies the group of
218 observers and could be used to remove the group. Watcher is weakly
219 referenced, all associated observers will be removed when the
220 wathcer is removed by gc. The observer fn will be called with
221 watcher and target arguments and any additional arguments specified
222 in update call."
223 [watcher target f]
224 (cm-swap! observers watcher assoc-cons target f)
225 nil)
227 (defn remove-observers
228 "Remove group of observers associated with the specified watcher."
229 [watcher]
230 (.remove observers watcher)
231 nil)
233 (defn- replace-observers-watcher
234 [old-watcher new-watcher]
235 (if-let [old (.remove observers old-watcher)]
236 (.put observers new-watcher old))
237 nil)
239 (defn update
240 "Notify observers."
241 [target & args]
242 (doseq [entry observers
243 f (get (val entry) target)]
244 (apply f (key entry) target args)))
246 (defn add-context-observer
247 "Observer registered with this function will be automatically
248 removed after the next repaint is complete."
249 [target f]
250 (add-observer *scene* target f))
252 (defn repaint-on-update
253 "Trigger repaint of the current scene when the target updates."
254 [target]
255 (let [scene *scene*]
256 (if-not (identical? scene target)
257 (add-observer scene target (fn [w _] (update w))))))
259 (defn repaint
260 "Requests repaint of the current scene. If handle and state are
261 specified, the handle will be associated with the state in the
262 *states* map for the next paint iteration."
263 ([]
264 (update *scene*))
265 ([handle state]
266 (let [scene *scene*]
267 (swap! (:next-state scene) assoc handle state)
268 (update scene))))
270 ;;
271 ;; Rendering
272 ;;
274 (defn ^FontRenderContext font-context
275 "Returns FontRenderContext for the current Layer context."
276 []
277 (if (bound? (var *graphics*))
278 (.getFontRenderContext *graphics*)
279 (let [scene *scene*]
280 (if-let [^Component c (:component scene)]
281 (.getFontRenderContext (.getFontMetrics c (.getFont c)))
282 (:font-context scene)))))
284 (defn ^AffineTransform relative-transform
285 "Returns AffineTransform: layer context -> AWT component."
286 []
287 (let [tr (.getTransform *graphics*)]
288 (.preConcatenate tr *inverse-initial-transform*)
289 tr))
291 (defn ^AffineTransform inverse-relative-transform
292 "Returns AffineTransform: AWT component -> layer context."
293 []
294 (let [tr (.getTransform *graphics*)]
295 (.invert tr) ; absolute -> layer
296 (.concatenate tr *initial-transform*) ; component -> absolute
297 tr))
299 (defn transform-point [^AffineTransform tr x y]
300 (let [p (Point2D$Double. x y)]
301 (.transform tr p p)
302 [(.x p) (.y p)]))
304 ;; (defn- clip
305 ;; "Intersect clipping area with the specified shape or bounds.
306 ;; Returns new clip (Shape or nil if empty)."
307 ;; ([x y w h]
308 ;; (clip (Rectangle2D$Double. x y w h)))
309 ;; ([shape]
310 ;; (let [a1 (Area. shape)
311 ;; a2 (if (instance? Area *clip*) *clip* (Area. *clip*))]
312 ;; (.transform a1 (relative-transform))
313 ;; (.intersect a1 a2)
314 ;; (if (.isEmpty a1)
315 ;; nil
316 ;; a1))))
318 ;; Use faster clipping calculation provided by Graphics2D.
319 (defn- clip
320 "Intersect clipping area with the specified bounds in current
321 transform coordinates. Returns new clip in the AWT component
322 coordinates (Shape or nil if empty)."
323 [x y w h]
324 (let [^Graphics2D clip-g (.create *graphics*)]
325 (try
326 (doto clip-g
327 (.setClip x y w h)
328 (.setTransform *initial-transform*)
329 (.clip *clip*))
330 (if (.isEmpty (.getClipBounds clip-g))
331 nil
332 (.getClip clip-g))
333 (finally
334 (.dispose clip-g)))))
336 (defn- ^Graphics2D apply-theme
337 "Set graphics' color and font to match theme.
338 Modifies and returns the first argument."
339 ([]
340 (apply-theme *graphics* *theme*))
341 ([^Graphics2D graphics theme]
342 (doto graphics
343 (.setColor (:fore-color theme))
344 (.setFont (:font theme)))))
346 (defn- ^Graphics2D create-graphics
347 ([]
348 (apply-theme (.create *graphics*) *theme*))
349 ([x y w h]
350 (apply-theme (.create *graphics* x y w h) *theme*)))
352 (defn- with-bounds-noclip*
353 [x y w h f & args]
354 (let [graphics (create-graphics)]
355 (try
356 (.translate graphics (int x) (int y))
357 (binding [*width* w
358 *height* h
359 *clipped* false
360 *graphics* graphics]
361 (apply f args))
362 (finally
363 (.dispose graphics)))))
365 (defn with-bounds*
366 [x y w h f & args]
367 (when-let [clip (clip x y w h)]
368 (let [graphics (create-graphics x y w h)]
369 (try
370 (binding [*width* w
371 *height* h
372 *clip* clip
373 *clipped* true
374 *graphics* graphics]
375 (apply f args))
376 (finally
377 (.dispose graphics))))))
379 (defmacro with-bounds
380 [x y w h & body]
381 `(with-bounds* ~x ~y ~w ~h (fn [] ~@body)))
383 (defmacro with-theme
384 [theme & body]
385 `(binding [*theme* (merge *theme* ~theme)]
386 ~@body))
388 (defmacro with-color
389 [color-or-keyword & body]
390 (let [color-form (if (keyword? color-or-keyword)
391 `(~color-or-keyword *theme*)
392 color-or-keyword)]
393 `(let [color# ~color-form
394 g# *graphics*
395 old-color# (.getColor g#)]
396 (try
397 (.setColor g# color#)
398 ~@body
399 (finally
400 (.setColor g# old-color#))))))
402 (defmacro with-stroke [stroke & body]
403 `(let [g# *graphics*
404 old-stroke# (.getStroke g#)]
405 (try
406 (.setStroke g# ~stroke)
407 ~@body
408 (finally
409 (.setStroke g# old-stroke#)))))
411 (defn with-hints*
412 [hints f & args]
413 (if hints
414 (let [g *graphics*
415 old (.getRenderingHints g)]
416 (try
417 (.addRenderingHints g hints)
418 (apply f args)
419 (finally
420 (.setRenderingHints g old))))
421 (apply f args)))
423 (defmacro with-hints
424 [hints & body]
425 `(with-hints ~hints (fn [] ~@body)))
427 ;; TODO: constructor for AffineTransform.
428 ;; (transform :scale 0.3 0.5
429 ;; :translate 5 10
430 ;; :rotate (/ Math/PI 2))
432 (defmacro with-transform [transform & body]
433 `(let [g# *graphics*
434 old-t# (.getTransform g#)]
435 (try
436 (.transform g# ~transform)
437 ~@body
438 (finally
439 (.setTransform g# old-t#)))))
441 (defmacro with-rotate [theta ax ay & body]
442 `(let [transform# (AffineTransform/getRotateInstance ~theta ~ax ~ay)]
443 (with-transform transform# ~@body)))
445 (defmacro with-translate [x y & body]
446 `(let [x# ~x
447 y# ~y
448 g# *graphics*]
449 (try
450 (.translate g# x# y#)
451 ~@body
452 (finally
453 (.translate g# (- x#) (- y#))))))
455 (defn draw!
456 "Draws layer."
457 ([layer]
458 (let [graphics (create-graphics)]
459 (try
460 (binding [*graphics* graphics]
461 (render! layer))
462 (finally
463 (.dispose graphics)))))
464 ([layer x y]
465 (draw! layer x y true))
466 ([layer x y clip?]
467 (let [geom (geometry layer)]
468 (draw! layer x y (width geom) (height geom) clip?)))
469 ([layer x y width height]
470 (draw! layer x y width height true))
471 ([layer x y width height clip?]
472 (if clip?
473 (with-bounds* x y width height render! layer)
474 (with-bounds-noclip* x y width height render! layer))))
476 (defn draw-aligned!
477 "Draws layer. Location is relative to the layer's anchor point for
478 the specified alignment."
479 ([layer h-align v-align x y]
480 (let [geom (geometry layer)
481 w (width geom)
482 h (height geom)]
483 (draw! layer
484 (- x (anchor-x geom h-align w))
485 (- y (anchor-y geom v-align h))
486 w h)))
487 ([layer h-align v-align x y w h]
488 (let [geom (geometry layer)]
489 (draw! layer
490 (- x (anchor-x geom h-align w))
491 (- y (anchor-y geom v-align h))
492 w h))))
494 ;;
495 ;; Event handling.
496 ;;
498 (defn with-handlers*
499 [handle handlers f & args]
500 (binding [*event-dispatcher* (create-dispatcher
501 *event-dispatcher* handle handlers)]
502 (apply f args)))
504 (defmacro with-handlers
505 "specs => (:event-id name & handler-body)*
507 Execute form with the specified event handlers."
508 [handle form & specs]
509 `(with-handlers* ~handle
510 ~(reduce (fn [m spec]
511 (assoc m (first spec)
512 `(fn [~(second spec)]
513 ~@(nnext spec)))) {}
514 specs)
515 (fn [] ~form)))
517 (defn picked? [handle]
518 (handle-picked? *event-dispatcher* handle))
520 (defn hovered? [handle]
521 (handle-hovered? *event-dispatcher* handle))
523 ;;
524 ;; EventDispatcher implementation
525 ;;
527 (def awt-events
528 {java.awt.event.MouseEvent/MOUSE_CLICKED :mouse-clicked
529 java.awt.event.MouseEvent/MOUSE_DRAGGED :mouse-dragged
530 java.awt.event.MouseEvent/MOUSE_ENTERED :mouse-entered
531 java.awt.event.MouseEvent/MOUSE_EXITED :mouse-exited
532 java.awt.event.MouseEvent/MOUSE_MOVED :mouse-moved
533 java.awt.event.MouseEvent/MOUSE_PRESSED :mouse-pressed
534 java.awt.event.MouseEvent/MOUSE_RELEASED :mouse-released
535 java.awt.event.MouseEvent/MOUSE_WHEEL :mouse-wheel})
537 (def dummy-event-dispatcher
538 (reify EventDispatcher
539 (listen! [_ _])
540 (create-dispatcher [this _ _] this)
541 (commit [_])
542 (handle-picked? [_ _])
543 (handle-hovered? [_ _])))
545 (defrecord DispatcherNode [handle handlers parent
546 ^Shape clip ^AffineTransform transform
547 bindings]
548 EventDispatcher
549 (listen! [this component]
550 (listen! parent component))
551 (create-dispatcher [this handle handlers]
552 (create-dispatcher parent handle handlers))
553 (commit [this]
554 (commit parent))
555 (handle-picked? [this handle]
556 (handle-picked? parent handle))
557 (handle-hovered? [this handle]
558 (handle-hovered? parent handle)))
560 (defn- make-node [handle handlers]
561 (let [clip (if *clipped*
562 *clip*
563 (clip 0 0 *width* *height*))]
564 (DispatcherNode. handle handlers *event-dispatcher* clip
565 (inverse-relative-transform)
566 (get-thread-bindings))))
568 (defn- add-node [tree node]
569 (assoc-cons tree (:parent node) node))
571 (defn- nodes [tree]
572 (apply concat (vals tree)))
574 (defn- under-cursor
575 "Returns a vector of child nodes under cursor."
576 [x y tree node]
577 (some #(if (and (:clip %)
578 (.contains ^Shape (:clip %) x y))
579 (conj (vec (under-cursor x y tree %)) %))
580 (get tree node)))
582 (defn- remove-all [coll1 coll2 pred]
583 (filter #(not (some (partial pred %) coll2)) coll1))
585 (defn- translate-mouse-event [^java.awt.event.MouseEvent event
586 ^AffineTransform tr id]
587 (let [[x y] (transform-point tr (.getX event) (.getY event))
588 rotation (if (instance? MouseWheelEvent event)
589 (.getWheelRotation ^MouseWheelEvent event)
590 nil)]
591 (MouseEvent. id (.getWhen event) x y
592 (.getXOnScreen event) (.getYOnScreen event)
593 (.getButton event)
594 rotation)))
596 (defn- translate-and-dispatch
597 ([nodes first-only ^java.awt.event.MouseEvent event]
598 (translate-and-dispatch nodes first-only
599 event (awt-events (.getID event))))
600 ([nodes first-only event id]
601 (if-let [node (first nodes)]
602 (if-let [handler (get (:handlers node) id)]
603 (do
604 (let [translated (translate-mouse-event event (:transform node) id)]
605 (with-bindings* (:bindings node)
606 handler translated))
607 (if-not first-only
608 (recur (rest nodes) false event id)))
609 (recur (rest nodes) first-only event id)))))
611 (defn- dispatch-mouse-motion
612 "Dispatches mouse motion events."
613 [hovered-ref tree root ^java.awt.event.MouseEvent event]
614 (let [x (.getX event)
615 y (.getY event)
616 [hovered hovered2] (dosync
617 [@hovered-ref
618 (ref-set hovered-ref
619 (under-cursor x y tree root))])
620 pred #(= (:handle %1) (:handle %2))
621 exited (remove-all hovered hovered2 pred)
622 entered (remove-all hovered2 hovered pred)
623 moved (remove-all hovered2 entered pred)]
624 (translate-and-dispatch exited false event :mouse-exited)
625 (translate-and-dispatch entered false event :mouse-entered)
626 (translate-and-dispatch moved true event :mouse-moved)))
628 (defn- dispatch-mouse-button
629 [picked-ref hovered-ref ^java.awt.event.MouseEvent event]
630 (let [id (awt-events (.getID event))
631 nodes (case id
632 :mouse-pressed
633 (dosync
634 (ref-set picked-ref @hovered-ref))
635 :mouse-released
636 (dosync
637 (let [picked @picked-ref]
638 (ref-set picked-ref nil)
639 picked))
640 @hovered-ref)]
641 (translate-and-dispatch nodes true event id)))
643 (defn root-event-dispatcher []
644 (let [tree-r (ref {}) ; register
645 tree (ref {}) ; dispatch
646 hovered (ref '())
647 picked (ref '())]
648 (reify
649 EventDispatcher
650 (listen! [this component]
651 (doto ^Component component
652 (.addMouseListener this)
653 (.addMouseWheelListener this)
654 (.addMouseMotionListener this)))
655 (create-dispatcher [this handle handlers]
656 (let [node (make-node handle handlers)]
657 (dosync (alter tree-r add-node node))
658 node))
659 (commit [this]
660 ;; TODO: retain contexts that do not intersect graphics
661 ;; clipping area in tree.
662 (dosync (ref-set tree @tree-r)
663 (ref-set tree-r {})))
664 (handle-picked? [this handle]
665 (some #(= handle (:handle %)) @picked))
666 (handle-hovered? [this handle]
667 (some #(= handle (:handle %)) @hovered))
668 MouseListener
669 (mouseEntered [this event]
670 (dispatch-mouse-motion hovered @tree this event))
671 (mouseExited [this event]
672 (dispatch-mouse-motion hovered @tree this event))
673 (mouseClicked [this event]
674 (dispatch-mouse-button picked hovered event))
675 (mousePressed [this event]
676 (dispatch-mouse-button picked hovered event))
677 (mouseReleased [this event]
678 (dispatch-mouse-button picked hovered event))
679 MouseWheelListener
680 (mouseWheelMoved [this event]
681 (dispatch-mouse-button picked hovered event))
682 MouseMotionListener
683 (mouseDragged [this event]
684 (translate-and-dispatch @picked true event))
685 (mouseMoved [this event]
686 (dispatch-mouse-motion hovered @tree this event)))))
688 ;;
689 ;; Scene
690 ;;
692 (defrecord Scene [layer
693 event-dispatcher
694 component
695 rendering-hints
696 font-context
697 next-state])
699 ;; Define rendering hints that affect font metrics to make sure that
700 ;; Graphics and Scene FontRenderContexts are consistent.
701 (def ^:private default-rendering-hints
702 {RenderingHints/KEY_TEXT_ANTIALIASING
703 RenderingHints/VALUE_TEXT_ANTIALIAS_DEFAULT,
704 RenderingHints/KEY_FRACTIONALMETRICS
705 RenderingHints/VALUE_FRACTIONALMETRICS_DEFAULT})
707 (defn make-scene
708 ([layer]
709 (make-scene layer dummy-event-dispatcher nil))
710 ([layer event-dispatcher]
711 (make-scene layer event-dispatcher nil))
712 ([layer event-dispatcher ^Component component]
713 (make-scene layer event-dispatcher component nil))
714 ([layer event-dispatcher ^Component component hints]
715 (let [hints (merge default-rendering-hints hints)]
716 (->Scene layer
717 event-dispatcher
718 component
719 hints
720 (FontRenderContext.
721 nil
722 (get hints RenderingHints/KEY_TEXT_ANTIALIASING)
723 (get hints RenderingHints/KEY_FRACTIONALMETRICS))
724 (atom nil)))))
726 (defn- get-and-set!
727 "Atomically sets the value of atom to newval and returns the old
728 value."
729 [atom newval]
730 (loop [v @atom]
731 (if (compare-and-set! atom v newval)
732 v
733 (recur @atom))))
735 (defn draw-scene!
736 [scene ^Graphics2D graphics width height]
737 (.addRenderingHints graphics (:rendering-hints scene))
738 (binding [*states* (get-and-set! (:next-state scene) nil)
739 *scene* scene
740 *graphics* graphics
741 *initial-transform* (.getTransform graphics)
742 *inverse-initial-transform* (-> graphics
743 .getTransform
744 .createInverse)
745 *event-dispatcher* (:event-dispatcher scene)
746 *width* width
747 *height* height
748 *clip* (Rectangle2D$Double. 0.0 0.0 width height)
749 *clipped* true
750 *time* (System/nanoTime)]
751 (apply-theme)
752 (let [tmp-watcher (Object.)]
753 ;; Keep current context observers until the rendering is
754 ;; complete. Some observers may be invoked twice if they
755 ;; appear in both groups until tmp-watcher is removed.
756 (replace-observers-watcher scene tmp-watcher)
757 (try
758 (render! (:layer scene))
759 (finally
760 (remove-observers tmp-watcher)
761 (commit (:event-dispatcher scene)))))))
763 (defn scene-geometry [scene]
764 (binding [*scene* scene]
765 (geometry (:layer scene))))
767 (defn set-cursor! [^Cursor cursor]
768 (when-let [^Component component (:component *scene*)]
769 (EventQueue/invokeLater #(.setCursor component cursor))))