view src/net/kryshen/indyvon/core.clj @ 134:16643a84b9e4

Refactored the event dispatcher. Update hover states at every commit.
author Mikhail Kryshen <mikhail@kryshen.net>
date Tue, 24 Apr 2012 18:51:37 +0400
parents 24d4c9f3be90
children 7eddb035d9c4
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 (long x)
403 y (long y)
404 w (long w)
405 h (long h)]
406 (when-let [clip (clip (Rectangle. x y w h))]
407 (let [^Graphics2D graphics (create-graphics x y w h)]
408 (try
409 (binding [*width* w
410 *height* h
411 *clip* clip
412 *input-clip* nil
413 *graphics* graphics]
414 (apply f args))
415 (finally
416 (.dispose graphics)))))))
418 (defmacro with-bounds
419 [x y w h & body]
420 `(with-bounds* ~x ~y ~w ~h (fn [] ~@body)))
422 (defmacro with-theme
423 [theme & body]
424 `(binding [*theme* (merge *theme* ~theme)]
425 ~@body))
427 (defmacro with-color
428 [color-or-keyword & body]
429 (let [color-form (if (keyword? color-or-keyword)
430 `(~color-or-keyword *theme*)
431 color-or-keyword)]
432 `(let [color# ~color-form
433 g# *graphics*
434 old-color# (.getColor g#)]
435 (try
436 (.setColor g# color#)
437 ~@body
438 (finally
439 (.setColor g# old-color#))))))
441 (defmacro with-stroke [stroke & body]
442 `(let [g# *graphics*
443 old-stroke# (.getStroke g#)]
444 (try
445 (.setStroke g# ~stroke)
446 ~@body
447 (finally
448 (.setStroke g# old-stroke#)))))
450 (defn with-hints*
451 [hints f & args]
452 (if hints
453 (let [g *graphics*
454 old (.getRenderingHints g)]
455 (try
456 (.addRenderingHints g hints)
457 (apply f args)
458 (finally
459 (.setRenderingHints g old))))
460 (apply f args)))
462 (defmacro with-hints
463 [hints & body]
464 `(with-hints ~hints (fn [] ~@body)))
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 (defrecord DispatcherNode [handle handlers parent
585 ^Shape clip ^AffineTransform transform
586 bindings]
587 EventDispatcher
588 (listen! [this component]
589 (listen! parent component))
590 (create-dispatcher [this handle handlers]
591 (create-dispatcher parent handle handlers))
592 (commit [this]
593 (commit parent))
594 (handle-picked? [this handle]
595 (handle-picked? parent handle))
596 (handle-hovered? [this handle]
597 (handle-hovered? parent handle)))
599 (defn- make-node [handle handlers]
600 (let [clip (if *input-clip*
601 (clip *input-clip*)
602 *clip*)
603 bindings (-> (get-thread-bindings)
604 (dissoc (var *graphics*))
605 (assoc (var *font-context*) (font-context)))]
606 (DispatcherNode. handle handlers *event-dispatcher* clip
607 (relative-transform)
608 bindings)))
610 (defn- add-node [tree node]
611 (assoc-cons tree (:parent node) node))
613 (defn- nodes [tree]
614 (apply concat (vals tree)))
616 (defn- under-cursor
617 "Returns a vector of child nodes under cursor."
618 [^long x ^long y tree node]
619 (some #(if (and (:clip %)
620 (.contains ^Shape (:clip %) x y))
621 (conj (vec (under-cursor x y tree %)) %))
622 (get tree node)))
624 (defn- remove-all [coll1 coll2 pred]
625 (filter #(not (some (partial pred %) coll2)) coll1))
627 (defn- translate-mouse-event [^java.awt.event.MouseEvent event
628 ^AffineTransform tr id]
629 (let [[x y] (inverse-transform-point tr (.getX event) (.getY event))
630 rotation (if (instance? MouseWheelEvent event)
631 (.getWheelRotation ^MouseWheelEvent event)
632 nil)]
633 (->MouseEvent id (.getWhen event) x y
634 (.getXOnScreen event) (.getYOnScreen event)
635 (.getButton event)
636 rotation
637 tr
638 (.getComponent event))))
640 (defn- translate-and-dispatch
641 ([nodes first-only ^java.awt.event.MouseEvent event]
642 (translate-and-dispatch nodes first-only
643 event (awt-events (.getID event))))
644 ([nodes first-only event id]
645 (if-let [node (first nodes)]
646 (if-let [handler (get (:handlers node) id)]
647 (do
648 (let [translated (translate-mouse-event event (:transform node) id)]
649 (with-bindings* (:bindings node)
650 handler translated))
651 (if-not first-only
652 (recur (rest nodes) false event id)))
653 (recur (rest nodes) first-only event id)))))
655 (defn- process-mouse-position
656 [dispatcher event]
657 (dosync
658 (let [{hovered-ref :hovered
659 last-ref :last-motion
660 tree-ref :tree} dispatcher
661 ^java.awt.event.MouseEvent event (or event @last-ref)]
662 (when event
663 (let [x (.getX event)
664 y (.getY event)
665 old-hovered @hovered-ref
666 hovered (under-cursor x y @tree-ref dispatcher)
667 pred #(= (:handle %1) (:handle %2))
668 exited (remove-all old-hovered hovered pred)
669 entered (remove-all hovered old-hovered pred)
670 moved (remove-all hovered entered pred)]
671 (ref-set hovered-ref hovered)
672 (ref-set last-ref event)
673 [exited entered moved event])))))
675 (defn- dispatch-mouse-motion
676 [dispatcher source-event]
677 (when-let [[exited entered moved event] (process-mouse-position
678 dispatcher source-event)]
679 (translate-and-dispatch exited false event :mouse-exited)
680 (translate-and-dispatch entered false event :mouse-entered)
681 (when source-event
682 (translate-and-dispatch moved true event :mouse-moved))))
684 (defn- dispatch-mouse-button
685 [dispatcher ^java.awt.event.MouseEvent event]
686 (let [{picked-ref :picked
687 hovered-ref :hovered} dispatcher
688 id (awt-events (.getID event))
689 nodes (case id
690 :mouse-pressed
691 (dosync
692 (ref-set picked-ref @hovered-ref))
693 :mouse-released
694 (dosync
695 (let [picked @picked-ref]
696 (ref-set picked-ref nil)
697 picked))
698 @hovered-ref)]
699 (translate-and-dispatch nodes true event id)))
701 (defrecord RootEventDispatcher [tree-r ; register
702 tree ; dispatch
703 hovered
704 picked
705 last-motion]
706 EventDispatcher
707 (listen! [dispatcher component]
708 (doto ^Component component
709 (.addMouseListener dispatcher)
710 (.addMouseWheelListener dispatcher)
711 (.addMouseMotionListener dispatcher)))
712 (create-dispatcher [dispatcher handle handlers]
713 (let [node (make-node handle handlers)]
714 (dosync (alter tree-r add-node node))
715 node))
716 (commit [dispatcher]
717 ;; TODO: retain contexts that do not intersect graphics
718 ;; clipping area in tree.
719 (dosync (ref-set tree @tree-r)
720 (ref-set tree-r {}))
721 ;; Send mouse entered and exited events if necessary due to
722 ;; updated layout.
723 (dispatch-mouse-motion dispatcher nil))
724 (handle-picked? [dispatcher handle]
725 (some #(= handle (:handle %)) @picked))
726 (handle-hovered? [dispatcher handle]
727 (some #(= handle (:handle %)) @hovered))
728 MouseListener
729 (mouseEntered [dispatcher event]
730 (dispatch-mouse-motion dispatcher event))
731 (mouseExited [dispatcher event]
732 (dispatch-mouse-motion dispatcher event))
733 (mouseClicked [dispatcher event]
734 (dispatch-mouse-button dispatcher event))
735 (mousePressed [dispatcher event]
736 (dispatch-mouse-button dispatcher event))
737 (mouseReleased [dispatcher event]
738 (dispatch-mouse-button dispatcher event))
739 MouseWheelListener
740 (mouseWheelMoved [dispatcher event]
741 (dispatch-mouse-button dispatcher event))
742 MouseMotionListener
743 (mouseDragged [dispatcher event]
744 (translate-and-dispatch @picked true event))
745 (mouseMoved [dispatcher event]
746 (dispatch-mouse-motion dispatcher event)))
748 (defn root-event-dispatcher []
749 (->RootEventDispatcher (ref {}) (ref {}) (ref '()) (ref '()) (ref nil)))
751 ;;
752 ;; Scene
753 ;;
755 (defrecord Scene [layer
756 event-dispatcher
757 component
758 rendering-hints
759 next-state])
761 ;; Define rendering hints that affect font metrics to make sure that
762 ;; Graphics and Scene FontRenderContexts are consistent.
763 (def ^:private default-rendering-hints
764 {RenderingHints/KEY_TEXT_ANTIALIASING
765 RenderingHints/VALUE_TEXT_ANTIALIAS_DEFAULT,
766 RenderingHints/KEY_FRACTIONALMETRICS
767 RenderingHints/VALUE_FRACTIONALMETRICS_DEFAULT})
769 (defn make-scene
770 ([layer]
771 (make-scene layer dummy-event-dispatcher nil))
772 ([layer event-dispatcher]
773 (make-scene layer event-dispatcher nil))
774 ([layer event-dispatcher ^Component component]
775 (make-scene layer event-dispatcher component nil))
776 ([layer event-dispatcher ^Component component hints]
777 (let [hints (merge default-rendering-hints hints)]
778 (->Scene layer
779 event-dispatcher
780 component
781 hints
782 (atom nil)))))
784 (defn- get-and-set!
785 "Atomically sets the value of atom to newval and returns the old
786 value."
787 [atom newval]
788 (loop [v @atom]
789 (if (compare-and-set! atom v newval)
790 v
791 (recur @atom))))
793 (defn draw-scene!
794 [scene ^Graphics2D graphics width height]
795 (.addRenderingHints graphics (:rendering-hints scene))
796 (binding [*states* (get-and-set! (:next-state scene) nil)
797 *scene* scene
798 *graphics* graphics
799 *initial-transform* (.getTransform graphics)
800 *inverse-initial-transform* (-> graphics
801 .getTransform
802 .createInverse)
803 *event-dispatcher* (:event-dispatcher scene)
804 *width* width
805 *height* height
806 *clip* (Rectangle2D$Double. 0.0 0.0 width height)
807 *input-clip* nil
808 *time* (System/nanoTime)]
809 (apply-theme)
810 (let [tmp-watcher (Object.)]
811 ;; Keep current context observers until the rendering is
812 ;; complete. Some observers may be invoked twice if they
813 ;; appear in both groups until tmp-watcher is removed.
814 (replace-observers-watcher scene tmp-watcher)
815 (try
816 (render! (:layer scene))
817 (finally
818 (remove-observers tmp-watcher)
819 (commit (:event-dispatcher scene)))))))
821 (defn- scene-font-context [scene]
822 (let [hints (:rendering-hints scene)
823 ^Component c (:component scene)
824 t (if c (->> c
825 .getFont
826 (.getFontMetrics c)
827 .getFontRenderContext
828 .getTransform))]
829 (FontRenderContext.
830 t
831 (get hints RenderingHints/KEY_TEXT_ANTIALIASING)
832 (get hints RenderingHints/KEY_FRACTIONALMETRICS))))
834 (defn scene-geometry [scene]
835 (binding [*scene* scene
836 *font-context* (scene-font-context scene)]
837 (geometry (:layer scene))))
839 (defn set-cursor! [^Cursor cursor]
840 (when-let [^Component component (:component *scene*)]
841 (EventQueue/invokeLater #(.setCursor component cursor))))