Mercurial > hg > indyvon
view src/net/kryshen/indyvon/core.clj @ 138:e3eeb1478df1
Performance improvements.
| author | Mikhail Kryshen <mikhail@kryshen.net> |
|---|---|
| date | Mon, 07 Jan 2013 19:51:21 +0400 |
| parents | 7eddb035d9c4 |
| children | 4dd98ea3b475 |
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 transform component])
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 ^double x ^double y]
330 (let [p (Point2D$Double. x y)]
331 (.transform tr p p)
332 [(.x p) (.y p)]))
334 (defn inverse-transform-point [^AffineTransform tr ^double x ^double y]
335 (let [p (Point2D$Double. x y)]
336 (.inverseTransform tr p p)
337 [(.x p) (.y p)]))
339 ;; (defn- clip
340 ;; "Intersect clipping area with the specified shape or bounds.
341 ;; Returns new clip (Shape or nil if empty)."
342 ;; ([x y w h]
343 ;; (clip (Rectangle2D$Double. x y w h)))
344 ;; ([shape]
345 ;; (let [a1 (Area. shape)
346 ;; a2 (if (instance? Area *clip*) *clip* (Area. *clip*))]
347 ;; (.transform a1 (relative-transform))
348 ;; (.intersect a1 a2)
349 ;; (if (.isEmpty a1)
350 ;; nil
351 ;; a1))))
353 ;; Use faster clipping calculation provided by Graphics2D.
354 (defn- clip
355 "Intersect clipping area with the specified Shape in current
356 transform coordinates. Returns new clip in the AWT component
357 coordinates (Shape or nil if empty)."
358 [^Shape shape]
359 (let [^Graphics2D clip-g (.create *graphics*)]
360 (try
361 (doto clip-g
362 (.setClip shape)
363 (.setTransform *initial-transform*)
364 (.clip *clip*))
365 (if (.isEmpty (.getClipBounds clip-g))
366 nil
367 (.getClip clip-g))
368 (finally
369 (.dispose clip-g)))))
371 (defn- ^Graphics2D apply-theme
372 "Set graphics' color and font to match theme.
373 Modifies and returns the first argument."
374 ([]
375 (apply-theme *graphics* *theme*))
376 ([^Graphics2D graphics theme]
377 (doto graphics
378 (.setColor (:fore-color theme))
379 (.setFont (:font theme)))))
381 (defn- ^Graphics2D create-graphics
382 ([]
383 (apply-theme (.create *graphics*) *theme*))
384 ([^long x ^long y ^long w ^long h]
385 (apply-theme (.create *graphics* x y w h) *theme*)))
387 (defn- with-bounds-noclip*
388 [x y w h f & args]
389 (let [graphics (create-graphics)]
390 (try
391 (.translate graphics (double x) (double y))
392 (binding [*width* w
393 *height* h
394 *input-clip* (Rectangle2D$Double. 0.0 0.0 w h)
395 *graphics* graphics]
396 (apply f args))
397 (finally
398 (.dispose graphics)))))
400 (defn with-bounds*
401 [x y w h f & args]
402 (let [x (double x)
403 y (double y)
404 bounds (Rectangle2D$Double. x y w h)]
405 (when-let [clip (clip bounds)]
406 (let [^Graphics2D graphics (create-graphics)]
407 (try
408 (.clip graphics bounds)
409 (.translate graphics x y)
410 (binding [*width* w
411 *height* h
412 *clip* clip
413 *input-clip* nil
414 *graphics* graphics]
415 (apply f args))
416 (finally
417 (.dispose graphics)))))))
419 (defmacro with-bounds
420 [x y w h & body]
421 `(with-bounds* ~x ~y ~w ~h (fn [] ~@body)))
423 (defmacro with-theme
424 [theme & body]
425 `(binding [*theme* (merge *theme* ~theme)]
426 ~@body))
428 (defmacro with-color
429 [color-or-keyword & body]
430 (let [color-form (if (keyword? color-or-keyword)
431 `(~color-or-keyword *theme*)
432 color-or-keyword)]
433 `(let [color# ~color-form
434 g# *graphics*
435 old-color# (.getColor g#)]
436 (try
437 (.setColor g# color#)
438 ~@body
439 (finally
440 (.setColor g# old-color#))))))
442 (defmacro with-stroke [stroke & body]
443 `(let [g# *graphics*
444 old-stroke# (.getStroke g#)]
445 (try
446 (.setStroke g# ~stroke)
447 ~@body
448 (finally
449 (.setStroke g# old-stroke#)))))
451 (defmacro with-hints
452 [hints & body]
453 `(let [h# ~hints
454 g# *graphics*
455 old# (.getRenderingHints g#)]
456 (try
457 (.addRenderingHints g# h#)
458 ~@body
459 (finally
460 (.setRenderingHints g# old#)))))
462 (defn with-hints* [hints f & args]
463 (with-hints hints
464 (apply f args)))
466 ;; TODO: constructor for AffineTransform.
467 ;; (transform :scale 0.3 0.5
468 ;; :translate 5 10
469 ;; :rotate (/ Math/PI 2))
471 (defmacro with-transform [transform & body]
472 `(let [g# *graphics*
473 old-t# (.getTransform g#)]
474 (try
475 (.transform g# ~transform)
476 ~@body
477 (finally
478 (.setTransform g# old-t#)))))
480 (defmacro with-rotate [theta ax ay & body]
481 `(let [transform# (AffineTransform/getRotateInstance ~theta ~ax ~ay)]
482 (with-transform transform# ~@body)))
484 (defmacro with-translate [x y & body]
485 `(let [x# ~x
486 y# ~y
487 g# *graphics*]
488 (try
489 (.translate g# x# y#)
490 ~@body
491 (finally
492 (.translate g# (- x#) (- y#))))))
494 (defn draw!
495 "Draws layer."
496 ([layer]
497 (let [graphics (create-graphics)]
498 (try
499 (binding [*graphics* graphics]
500 (render! layer))
501 (finally
502 (.dispose graphics)))))
503 ([layer x y]
504 (draw! layer x y true))
505 ([layer x y clip?]
506 (let [geom (geometry layer)]
507 (draw! layer x y (width geom) (height geom) clip?)))
508 ([layer x y width height]
509 (draw! layer x y width height true))
510 ([layer x y width height clip?]
511 (if clip?
512 (with-bounds* x y width height render! layer)
513 (with-bounds-noclip* x y width height render! layer))))
515 (defn draw-aligned!
516 "Draws layer. Location is relative to the layer's anchor point for
517 the specified alignment."
518 ([layer h-align v-align x y]
519 (let [geom (geometry layer)
520 w (width geom)
521 h (height geom)]
522 (draw! layer
523 (- x (anchor-x geom h-align w))
524 (- y (anchor-y geom v-align h))
525 w h)))
526 ([layer h-align v-align x y w h]
527 (let [geom (geometry layer)]
528 (draw! layer
529 (- x (anchor-x geom h-align w))
530 (- y (anchor-y geom v-align h))
531 w h))))
533 ;;
534 ;; Event handling.
535 ;;
537 (defn with-handlers*
538 [handle handlers f & args]
539 (binding [*event-dispatcher* (create-dispatcher
540 *event-dispatcher* handle handlers)]
541 (apply f args)))
543 (defmacro with-handlers
544 "specs => (:event-id name & handler-body)*
546 Execute form with the specified event handlers."
547 [handle form & specs]
548 `(with-handlers* ~handle
549 ~(reduce (fn [m spec]
550 (assoc m (first spec)
551 `(fn [~(second spec)]
552 ~@(nnext spec)))) {}
553 specs)
554 (fn [] ~form)))
556 (defn picked? [handle]
557 (handle-picked? *event-dispatcher* handle))
559 (defn hovered? [handle]
560 (handle-hovered? *event-dispatcher* handle))
562 ;;
563 ;; EventDispatcher implementation
564 ;;
566 (def awt-events
567 {java.awt.event.MouseEvent/MOUSE_CLICKED :mouse-clicked
568 java.awt.event.MouseEvent/MOUSE_DRAGGED :mouse-dragged
569 java.awt.event.MouseEvent/MOUSE_ENTERED :mouse-entered
570 java.awt.event.MouseEvent/MOUSE_EXITED :mouse-exited
571 java.awt.event.MouseEvent/MOUSE_MOVED :mouse-moved
572 java.awt.event.MouseEvent/MOUSE_PRESSED :mouse-pressed
573 java.awt.event.MouseEvent/MOUSE_RELEASED :mouse-released
574 java.awt.event.MouseEvent/MOUSE_WHEEL :mouse-wheel})
576 (def dummy-event-dispatcher
577 (reify EventDispatcher
578 (listen! [_ _])
579 (create-dispatcher [this _ _] this)
580 (commit [_])
581 (handle-picked? [_ _])
582 (handle-hovered? [_ _])))
584 ;; Not using defrecord to avoid unacceptable overhead of recursive
585 ;; hash code calculation.
586 (deftype DispatcherNode [handle handlers parent
587 ^Shape clip ^AffineTransform transform
588 bindings]
589 EventDispatcher
590 (listen! [this component]
591 (listen! parent component))
592 (create-dispatcher [this handle handlers]
593 (create-dispatcher parent handle handlers))
594 (commit [this]
595 (commit parent))
596 (handle-picked? [this handle]
597 (handle-picked? parent handle))
598 (handle-hovered? [this handle]
599 (handle-hovered? parent handle)))
601 (defn- make-node [handle handlers]
602 (let [clip (if *input-clip*
603 (clip *input-clip*)
604 *clip*)
605 bindings (-> (get-thread-bindings)
606 (dissoc (var *graphics*))
607 (assoc (var *font-context*) (font-context)))]
608 (DispatcherNode. handle handlers *event-dispatcher* clip
609 (relative-transform)
610 bindings)))
612 (defn- add-node [tree ^DispatcherNode node]
613 (assoc-cons tree (.parent node) node))
615 (defn- nodes [tree]
616 (apply concat (vals tree)))
618 (defn- under-cursor
619 "Returns a vector of child nodes under cursor."
620 [node tree ^long x ^long y]
621 (some (fn [^DispatcherNode n]
622 (if (and (.clip n) (.contains ^Shape (.clip n) x y))
623 (conj (vec (under-cursor n tree x y)) n)))
624 (get tree node)))
626 (defn- translate-mouse-event [^java.awt.event.MouseEvent event
627 ^AffineTransform tr id]
628 (let [[x y] (inverse-transform-point tr (.getX event) (.getY event))
629 rotation (if (instance? MouseWheelEvent event)
630 (.getWheelRotation ^MouseWheelEvent event)
631 nil)]
632 (->MouseEvent id (.getWhen event) x y
633 (.getXOnScreen event) (.getYOnScreen event)
634 (.getButton event)
635 rotation
636 tr
637 (.getComponent event))))
639 (defn- translate-and-dispatch
640 ([nodes first-only ^java.awt.event.MouseEvent event]
641 (translate-and-dispatch nodes first-only
642 event (awt-events (.getID event))))
643 ([nodes first-only event id]
644 (if-let [^DispatcherNode node (first nodes)]
645 (let [handlers (.handlers node)
646 handler (get handlers id)]
647 (if handler
648 (do
649 (with-bindings* (.bindings node)
650 handler
651 (translate-mouse-event event (.transform node) id))
652 (when-not first-only
653 (recur (rest nodes) false event id)))
654 (when-not (and (= id :mouse-dragged)
655 (or (contains? handlers :mouse-pressed)
656 (contains? handlers :mouse-released)))
657 (recur (rest nodes) first-only event id)))))))
659 (defn- process-mouse-event
660 [dispatcher ^java.awt.event.MouseEvent source-event]
661 (let [{active-ref :active
662 hovered-ref :hovered
663 picked-ref :picked
664 last-ref :last-motion
665 tree-ref :tree} dispatcher
666 pressed (and source-event
667 (== (.getID source-event)
668 java.awt.event.MouseEvent/MOUSE_PRESSED))
669 released (and source-event
670 (== (.getID source-event)
671 java.awt.event.MouseEvent/MOUSE_RELEASED))
672 ^java.awt.event.MouseEvent last-event @last-ref
673 ^java.awt.event.MouseEvent event (or source-event last-event)]
674 (when event
675 (let [x (.getX event)
676 y (.getY event)
677 active @active-ref
678 active (if (and active
679 source-event
680 (== (.getX last-event) x)
681 (== (.getY last-event) y))
682 active
683 (ref-set active-ref
684 (under-cursor dispatcher @tree-ref x y)))
685 acted (cond
686 pressed (ref-set picked-ref active)
687 released (let [picked @picked-ref]
688 (ref-set picked-ref nil)
689 picked)
690 :else active)
691 picked (seq @picked-ref)
692 pred #(= (.handle ^DispatcherNode %1) (.handle ^DispatcherNode %2))
693 hovered (if picked
694 (filter #(some (partial pred %) picked) active)
695 active)
696 remove-all (fn [c1 c2]
697 (filter #(not (some (partial pred %) c2)) c1))
698 old-hovered @hovered-ref
699 exited (remove-all old-hovered hovered)
700 entered (remove-all hovered old-hovered)
701 moved (or picked (remove-all hovered entered))]
702 (ref-set hovered-ref hovered)
703 (ref-set last-ref event)
704 [exited entered moved acted event]))))
706 (defn- dispatch-mouse-event
707 [dispatcher source-event button?]
708 (when-let [[exited
709 entered
710 moved
711 acted
712 event] (dosync (process-mouse-event dispatcher source-event))]
713 (when button?
714 (translate-and-dispatch acted true event))
715 (translate-and-dispatch exited false event :mouse-exited)
716 (translate-and-dispatch entered false event :mouse-entered)
717 (when-not button?
718 (translate-and-dispatch moved true source-event))))
720 (defrecord RootEventDispatcher [tree-r ;; register
721 tree ;; dispatch
722 active ;; nodes under cursor
723 hovered ;; mouse entered
724 picked ;; mouse pressed
725 last-motion]
726 EventDispatcher
727 (listen! [dispatcher component]
728 (doto ^Component component
729 (.addMouseListener dispatcher)
730 (.addMouseWheelListener dispatcher)
731 (.addMouseMotionListener dispatcher)))
732 (create-dispatcher [dispatcher handle handlers]
733 (let [node (make-node handle handlers)]
734 (dosync (alter tree-r add-node node))
735 node))
736 (commit [dispatcher]
737 (let [[exited
738 entered
739 _ _
740 event] (dosync
741 ;; TODO: retain contexts that do
742 ;; not intersect graphics
743 ;; clipping area in tree.
744 (ref-set tree @tree-r)
745 (ref-set tree-r {})
746 (process-mouse-event dispatcher nil))]
747 ;; Send mouse entered and exited events if necessary due to
748 ;; updated layout.
749 (translate-and-dispatch exited false event :mouse-exited)
750 (translate-and-dispatch entered false event :mouse-entered)))
751 (handle-picked? [dispatcher handle]
752 (some #(= handle (.handle ^DispatcherNode %)) @picked))
753 (handle-hovered? [dispatcher handle]
754 (some #(= handle (.handle ^DispatcherNode %)) @hovered))
755 MouseListener
756 (mouseEntered [dispatcher event]
757 (dispatch-mouse-event dispatcher event false))
758 (mouseExited [dispatcher event]
759 (dispatch-mouse-event dispatcher event false))
760 (mouseClicked [dispatcher event]
761 (dispatch-mouse-event dispatcher event true))
762 (mousePressed [dispatcher event]
763 (dispatch-mouse-event dispatcher event true))
764 (mouseReleased [dispatcher event]
765 (dispatch-mouse-event dispatcher event true))
766 MouseWheelListener
767 (mouseWheelMoved [dispatcher event]
768 (dispatch-mouse-event dispatcher event true))
769 MouseMotionListener
770 (mouseDragged [dispatcher event]
771 (dispatch-mouse-event dispatcher event false))
772 (mouseMoved [dispatcher event]
773 (dispatch-mouse-event dispatcher event false)))
775 (defn root-event-dispatcher []
776 (->RootEventDispatcher
777 (ref {}) (ref {}) ;; trees
778 (ref nil) (ref nil) (ref nil) ;; node states
779 (ref nil))) ;; last event
781 ;;
782 ;; Scene
783 ;;
785 (defrecord Scene [layer
786 event-dispatcher
787 component
788 rendering-hints
789 next-state])
791 ;; Define rendering hints that affect font metrics to make sure that
792 ;; Graphics and Scene FontRenderContexts are consistent.
793 (def ^:private default-rendering-hints
794 {RenderingHints/KEY_TEXT_ANTIALIASING
795 RenderingHints/VALUE_TEXT_ANTIALIAS_DEFAULT,
796 RenderingHints/KEY_FRACTIONALMETRICS
797 RenderingHints/VALUE_FRACTIONALMETRICS_DEFAULT})
799 (defn make-scene
800 ([layer]
801 (make-scene layer dummy-event-dispatcher nil))
802 ([layer event-dispatcher]
803 (make-scene layer event-dispatcher nil))
804 ([layer event-dispatcher ^Component component]
805 (make-scene layer event-dispatcher component nil))
806 ([layer event-dispatcher ^Component component hints]
807 (let [hints (merge default-rendering-hints hints)]
808 (->Scene layer
809 event-dispatcher
810 component
811 hints
812 (atom nil)))))
814 (defn- get-and-set!
815 "Atomically sets the value of atom to newval and returns the old
816 value."
817 [atom newval]
818 (loop [v @atom]
819 (if (compare-and-set! atom v newval)
820 v
821 (recur @atom))))
823 (defn draw-scene!
824 [scene ^Graphics2D graphics width height]
825 (.addRenderingHints graphics (:rendering-hints scene))
826 (binding [*states* (get-and-set! (:next-state scene) nil)
827 *scene* scene
828 *graphics* graphics
829 *initial-transform* (.getTransform graphics)
830 *inverse-initial-transform* (-> graphics
831 .getTransform
832 .createInverse)
833 *event-dispatcher* (:event-dispatcher scene)
834 *width* width
835 *height* height
836 *clip* (Rectangle2D$Double. 0.0 0.0 width height)
837 *input-clip* nil
838 *time* (System/nanoTime)]
839 (apply-theme)
840 (let [tmp-watcher (Object.)]
841 ;; Keep current context observers until the rendering is
842 ;; complete. Some observers may be invoked twice if they
843 ;; appear in both groups until tmp-watcher is removed.
844 (replace-observers-watcher scene tmp-watcher)
845 (try
846 (render! (:layer scene))
847 (finally
848 (remove-observers tmp-watcher)
849 (commit (:event-dispatcher scene)))))))
851 (defn- scene-font-context [scene]
852 (let [hints (:rendering-hints scene)
853 ^Component c (:component scene)
854 t (if c (->> c
855 .getFont
856 (.getFontMetrics c)
857 .getFontRenderContext
858 .getTransform))]
859 (FontRenderContext.
860 t
861 (get hints RenderingHints/KEY_TEXT_ANTIALIASING)
862 (get hints RenderingHints/KEY_FRACTIONALMETRICS))))
864 (defn scene-geometry [scene]
865 (binding [*scene* scene
866 *font-context* (scene-font-context scene)]
867 (geometry (:layer scene))))
869 (defn set-cursor! [^Cursor cursor]
870 (when-let [^Component component (:component *scene*)]
871 (EventQueue/invokeLater #(.setCursor component cursor))))