Mercurial > hg > indyvon
view src/indyvon/core.clj @ 158:e0063c1d0f7f
Allow theme entries to reference other theme keys.
| author | Mikhail Kryshen <mikhail@kryshen.net> |
|---|---|
| date | Mon, 17 Nov 2014 10:42:09 +0300 |
| parents | 4fea68ec12f4 |
| children | d149f03d1feb |
line source
1 ;;
2 ;; Copyright 2010-2014 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 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 ;; View 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. 0xDD 0xDD 0xDD)
82 (Color. 0 0 0xCC)
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 View
93 "Basic UI element."
94 (render! [view]
95 "Draws the view in the current *graphics* context.")
96 (geometry [view]
97 "Returns the preferred Geometry for the view."))
99 (defprotocol Geometry
100 "Describes geometry of a View. 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 (defn- emit-align-xy [align size first center last]
116 `(case ~align
117 ~first 0
118 ~center (/ ~size 2)
119 ~last ~size))
121 ;; Define as macro to avoid unnecessary calculation of width or height.
122 (defmacro align-x
123 ([align inner outer]
124 `(align-x ~align (- ~outer ~inner)))
125 ([align width]
126 (emit-align-xy align width :left :center :right)))
128 (defmacro align-y
129 ([align inner outer]
130 `(align-y ~align (- ~outer ~inner)))
131 ([align height]
132 (emit-align-xy align height :top :center :bottom)))
134 (defrecord Size [width height]
135 Geometry
136 (width [_] width)
137 (width [_ _] width)
138 (height [_] height)
139 (height [_ _] height)
140 (anchor-x [_ h-align width]
141 (align-x h-align width))
142 (anchor-y [_ v-align height]
143 (align-y v-align height)))
145 (defrecord FixedGeometry [ax ay width height]
146 Geometry
147 (width [_] width)
148 (width [_ _] width)
149 (height [_] height)
150 (height [_ _] height)
151 (anchor-x [_ _ _] ax)
152 (anchor-y [_ _ _] ay))
154 (defrecord NestedGeometry [geometry top left bottom right]
155 Geometry
156 (width [_]
157 (+ left right (width geometry)))
158 (width [_ h]
159 (+ left right (width geometry (- h top bottom))))
160 (height [_]
161 (+ top bottom (height geometry)))
162 (height [_ w]
163 (+ top bottom (height geometry (- w left right))))
164 (anchor-x [_ h-align w]
165 (+ left (anchor-x geometry h-align (- w left right))))
166 (anchor-y [_ v-align h]
167 (+ top (anchor-y geometry v-align (- h top bottom)))))
169 (defrecord ScaledGeometry [geometry sx sy]
170 Geometry
171 (width [_]
172 (* sx (width geometry)))
173 (width [_ h]
174 (* sx (width geometry (/ h sy))))
175 (height [_]
176 (* sy (height geometry)))
177 (height [_ w]
178 (* sy (height geometry (/ w sx))))
179 (anchor-x [_ h-align w]
180 (* sx (anchor-x geometry h-align (/ w sx))))
181 (anchor-y [_ v-align h]
182 (* sy (anchor-y geometry v-align (/ h sy)))))
184 ;; (defn ^:private to-integer
185 ;; ^long [align x]
186 ;; (if (integer? x)
187 ;; x
188 ;; (let [x (double x)]
189 ;; (Math/round
190 ;; (case align
191 ;; (:top :left) (Math/floor x)
192 ;; :center x
193 ;; (:bottom :right) (Math/ceil x))))))
195 ;; (defrecord IntegerGeometry [geometry]
196 ;; Geometry
197 ;; (width [_]
198 ;; (to-integer :right (width geometry)))
199 ;; (width [_ h]
200 ;; (to-integer :right (width geometry h)))
201 ;; (height [_]
202 ;; (to-integer :bottom (height geometry)))
203 ;; (height [_ w]
204 ;; (to-integer :bottom (height geometry w)))
205 ;; (anchor-x [_ h-align w]
206 ;; (to-integer h-align (anchor-x geometry h-align w)))
207 ;; (anchor-y [_ v-align h]
208 ;; (to-integer v-align (anchor-y geometry v-align h))))
210 ;; TODO: modifiers
211 (defrecord MouseEvent [id when x y x-on-screen y-on-screen button
212 wheel-rotation transform component])
214 ;; TODO: KeyEvent
216 (defprotocol EventDispatcher
217 (listen! [this component]
218 "Listen for events on the specified AWT Component.")
219 (create-dispatcher [this handle handlers]
220 "Returns new event dispatcher associated with the specified event
221 handlers (an event-id -> handler-fn map). Handle is used to match
222 the contexts between commits.")
223 (commit [this]
224 "Apply the registered handlers for event processing.")
225 (handle-picked? [this handle]
226 "Returns true if the specified handle received the :mouse-pressed
227 event and have not yet received :moused-released.")
228 (handle-hovered? [this handle]
229 "Returns true if the specified handle received the :mouse-entered
230 event and have not yet received :mouse-exited."))
232 (defn- assoc-cons [m key val]
233 (->> (get m key) (cons val) (assoc m key)))
235 ;;
236 ;; Observers
237 ;; The mechanism used by views to request repaints
238 ;;
240 (def ^ConcurrentMap observers
241 (-> (MapMaker.) (.weakKeys) (.makeMap)))
243 (defn- cm-replace!
244 "Wrap ConcurrentMap replace method to treat nil value as absent
245 mapping. Use with maps that does not support nil values."
246 [^ConcurrentMap cmap key old new]
247 (if (nil? old)
248 (nil? (.putIfAbsent cmap key new))
249 (.replace cmap key old new)))
251 (defn- cm-swap!
252 "Atomically swaps the value associated with key in ConcurrentMap
253 to be (apply f current-value args). Returns the new value."
254 [^ConcurrentMap cmap key f & args]
255 (loop []
256 (let [old (.get cmap key)
257 new (apply f old args)]
258 (if (cm-replace! cmap key old new)
259 new
260 (recur)))))
262 (defn add-observer
263 "Add observer fn for the target. Watcher identifies the group of
264 observers and could be used to remove the group. Watcher is weakly
265 referenced, all associated observers will be removed when the
266 wathcer is removed by gc. The observer fn will be called with
267 watcher and target arguments and any additional arguments specified
268 in update call."
269 [watcher target f]
270 (cm-swap! observers watcher assoc-cons target f)
271 nil)
273 (defn remove-observers
274 "Remove group of observers associated with the specified watcher."
275 [watcher]
276 (.remove observers watcher)
277 nil)
279 (defn- replace-observers-watcher
280 [old-watcher new-watcher]
281 (if-let [old (.remove observers old-watcher)]
282 (.put observers new-watcher old))
283 nil)
285 (defn update
286 "Notify observers."
287 [target & args]
288 (doseq [entry observers
289 f (get (val entry) target)]
290 (apply f (key entry) target args)))
292 (defn add-context-observer
293 "Observer registered with this function will be automatically
294 removed after the next repaint is complete."
295 [target f]
296 (add-observer *scene* target f))
298 (defn repaint-on-update
299 "Trigger repaint of the current scene when the target updates."
300 [target]
301 (let [scene *scene*]
302 (if-not (identical? scene target)
303 (add-observer scene target (fn [w _] (update w))))))
305 (defn repaint
306 "Requests repaint of the current scene. If handle and state are
307 specified, the handle will be associated with the state in the
308 *states* map for the next paint iteration."
309 ([]
310 (update *scene*))
311 ([handle state]
312 (let [scene *scene*]
313 (swap! (:next-state scene) assoc handle state)
314 (update scene))))
316 ;;
317 ;; Rendering
318 ;;
320 (defn ^FontRenderContext font-context
321 "Returns FontRenderContext for the current view context."
322 []
323 (if (bound? (var *graphics*))
324 (.getFontRenderContext *graphics*)
325 *font-context*))
327 (defn ^AffineTransform relative-transform
328 "Returns AffineTransform: view context -> AWT component."
329 []
330 (let [tr (.getTransform *graphics*)]
331 (.preConcatenate tr *inverse-initial-transform*)
332 tr))
334 (defn ^AffineTransform inverse-relative-transform
335 "Returns AffineTransform: AWT component -> view context."
336 []
337 (let [tr (.getTransform *graphics*)]
338 (.invert tr) ; absolute -> view
339 (.concatenate tr *initial-transform*) ; component -> absolute
340 tr))
342 (defn transform-point [^AffineTransform tr ^double x ^double y]
343 (let [p (Point2D$Double. x y)]
344 (.transform tr p p)
345 [(.x p) (.y p)]))
347 (defn inverse-transform-point [^AffineTransform tr ^double x ^double y]
348 (let [p (Point2D$Double. x y)]
349 (.inverseTransform tr p p)
350 [(.x p) (.y p)]))
352 ;; (defn- clip
353 ;; "Intersect clipping area with the specified shape or bounds.
354 ;; Returns new clip (Shape or nil if empty)."
355 ;; ([x y w h]
356 ;; (clip (Rectangle2D$Double. x y w h)))
357 ;; ([shape]
358 ;; (let [a1 (Area. shape)
359 ;; a2 (if (instance? Area *clip*) *clip* (Area. *clip*))]
360 ;; (.transform a1 (relative-transform))
361 ;; (.intersect a1 a2)
362 ;; (if (.isEmpty a1)
363 ;; nil
364 ;; a1))))
366 ;; Use faster clipping calculation provided by Graphics2D.
367 (defn- clip
368 "Intersect clipping area with the specified Shape in current
369 transform coordinates. Returns new clip in the AWT component
370 coordinates (Shape or nil if empty)."
371 [^Shape shape]
372 (let [^Graphics2D clip-g (.create *graphics*)]
373 (try
374 (doto clip-g
375 (.setClip shape)
376 (.setTransform *initial-transform*)
377 (.clip *clip*))
378 (if (.isEmpty (.getClipBounds clip-g))
379 nil
380 (.getClip clip-g))
381 (finally
382 (.dispose clip-g)))))
384 (defn- theme-get*
385 ([theme key]
386 (theme-get* theme key nil))
387 ([theme key not-found]
388 (if-let [e (find theme key)]
389 (loop [k (val e)]
390 (if-let [e1 (and (keyword? k)
391 (find theme k))]
392 (recur (val e1))
393 k))
394 not-found)))
396 (defn theme-get
397 ([key]
398 (theme-get* *theme* key))
399 ([key not-found]
400 (theme-get* *theme* key not-found)))
402 (defn ^Graphics2D apply-theme
403 "Set graphics' color and font to match theme.
404 Modifies and returns the first argument."
405 ([]
406 (apply-theme *graphics* *theme*))
407 ([^Graphics2D graphics theme]
408 (doto graphics
409 (.setColor (theme-get :fore-color))
410 (.setBackground (theme-get :back-color))
411 (.setFont (theme-get :font)))))
413 (defn- ^Graphics2D create-graphics
414 ([]
415 (apply-theme (.create *graphics*) *theme*))
416 ([^long x ^long y ^long w ^long h]
417 (apply-theme (.create *graphics* x y w h) *theme*)))
419 (defn- with-bounds-noclip*
420 [x y w h f & args]
421 (let [graphics (create-graphics)]
422 (try
423 (.translate graphics (double x) (double y))
424 (binding [*width* w
425 *height* h
426 *input-clip* (Rectangle2D$Double. 0.0 0.0 w h)
427 *graphics* graphics]
428 (apply f args))
429 (finally
430 (.dispose graphics)))))
432 (defn with-bounds*
433 [x y w h f & args]
434 (let [x (double x)
435 y (double y)
436 bounds (Rectangle2D$Double. x y w h)]
437 (when-let [clip (clip bounds)]
438 (let [^Graphics2D graphics (create-graphics)]
439 (try
440 (.clip graphics bounds)
441 (.translate graphics x y)
442 (binding [*width* w
443 *height* h
444 *clip* clip
445 *input-clip* nil
446 *graphics* graphics]
447 (apply f args))
448 (finally
449 (.dispose graphics)))))))
451 (defmacro with-bounds
452 [x y w h & body]
453 `(with-bounds* ~x ~y ~w ~h (fn [] ~@body)))
455 (defmacro with-theme
456 [theme & body]
457 `(binding [*theme* (merge *theme* ~theme)]
458 ~@body))
460 (defn with-theme* [theme f & args]
461 (with-theme theme
462 (apply f args)))
464 (defmacro with-color [color-or-key & body]
465 `(let [color# ~color-or-key
466 color# (theme-get color# color#)
467 g# *graphics*
468 old-color# (.getColor g#)]
469 (try
470 (.setColor g# color#)
471 ~@body
472 (finally
473 (.setColor g# old-color#)))))
475 (defmacro with-font [font-or-key & body]
476 `(let [font# ~font-or-key
477 font# (theme-get font# font#)
478 g# *graphics*
479 old-font# (.getFont g#)]
480 (try
481 (.setFont g# font#)
482 ~@body
483 (finally
484 (.setColor g# old-font#)))))
486 (defmacro with-stroke [stroke & body]
487 `(let [g# *graphics*
488 old-stroke# (.getStroke g#)]
489 (try
490 (.setStroke g# ~stroke)
491 ~@body
492 (finally
493 (.setStroke g# old-stroke#)))))
495 (defmacro with-hints
496 [hints & body]
497 `(let [h# ~hints
498 g# *graphics*
499 old# (.getRenderingHints g#)]
500 (try
501 (.addRenderingHints g# h#)
502 ~@body
503 (finally
504 (.setRenderingHints g# old#)))))
506 (defn with-hints* [hints f & args]
507 (with-hints hints
508 (apply f args)))
510 ;; TODO: constructor for AffineTransform.
511 ;; (transform :scale 0.3 0.5
512 ;; :translate 5 10
513 ;; :rotate (/ Math/PI 2))
515 (defmacro with-transform [transform & body]
516 `(let [g# *graphics*
517 old-t# (.getTransform g#)]
518 (try
519 (.transform g# ~transform)
520 ~@body
521 (finally
522 (.setTransform g# old-t#)))))
524 (defmacro with-rotate [theta ax ay & body]
525 `(let [transform# (AffineTransform/getRotateInstance ~theta ~ax ~ay)]
526 (with-transform transform# ~@body)))
528 (defmacro with-translate [x y & body]
529 `(let [x# ~x
530 y# ~y
531 g# *graphics*]
532 (try
533 (.translate g# x# y#)
534 ~@body
535 (finally
536 (.translate g# (- x#) (- y#))))))
538 (defn draw!
539 "Draws the View."
540 ([view]
541 (let [graphics (create-graphics)]
542 (try
543 (binding [*graphics* graphics]
544 (render! view))
545 (finally
546 (.dispose graphics)))))
547 ([view x y]
548 (draw! view x y true))
549 ([view x y clip?]
550 (let [geom (geometry view)]
551 (draw! view x y (width geom) (height geom) clip?)))
552 ([view x y width height]
553 (draw! view x y width height true))
554 ([view x y width height clip?]
555 (if clip?
556 (with-bounds* x y width height render! view)
557 (with-bounds-noclip* x y width height render! view))))
559 (defn draw-aligned!
560 "Draws the View. Location is relative to the view's anchor point
561 for the specified alignment."
562 ([view h-align v-align x y]
563 (let [geom (geometry view)
564 w (width geom)
565 h (height geom)]
566 (draw! view
567 (- x (anchor-x geom h-align w))
568 (- y (anchor-y geom v-align h))
569 w h)))
570 ([view h-align v-align x y w h]
571 (let [geom (geometry view)]
572 (draw! view
573 (- x (anchor-x geom h-align w))
574 (- y (anchor-y geom v-align h))
575 w h))))
577 ;;
578 ;; Event handling.
579 ;;
581 (defn with-handlers*
582 [handle handlers f & args]
583 (binding [*event-dispatcher* (create-dispatcher
584 *event-dispatcher* handle handlers)]
585 (apply f args)))
587 (defmacro with-handlers
588 "specs => (:event-id name & handler-body)*
590 Execute form with the specified event handlers."
591 [handle form & specs]
592 `(with-handlers* ~handle
593 ~(reduce (fn [m spec]
594 (assoc m (first spec)
595 `(fn [~(second spec)]
596 ~@(nnext spec)))) {}
597 specs)
598 (fn [] ~form)))
600 (defn picked? [handle]
601 (handle-picked? *event-dispatcher* handle))
603 (defn hovered? [handle]
604 (handle-hovered? *event-dispatcher* handle))
606 ;;
607 ;; EventDispatcher implementation
608 ;;
610 (def awt-events
611 {java.awt.event.MouseEvent/MOUSE_CLICKED :mouse-clicked
612 java.awt.event.MouseEvent/MOUSE_DRAGGED :mouse-dragged
613 java.awt.event.MouseEvent/MOUSE_ENTERED :mouse-entered
614 java.awt.event.MouseEvent/MOUSE_EXITED :mouse-exited
615 java.awt.event.MouseEvent/MOUSE_MOVED :mouse-moved
616 java.awt.event.MouseEvent/MOUSE_PRESSED :mouse-pressed
617 java.awt.event.MouseEvent/MOUSE_RELEASED :mouse-released
618 java.awt.event.MouseEvent/MOUSE_WHEEL :mouse-wheel})
620 (def dummy-event-dispatcher
621 (reify EventDispatcher
622 (listen! [_ _])
623 (create-dispatcher [this _ _] this)
624 (commit [_])
625 (handle-picked? [_ _])
626 (handle-hovered? [_ _])))
628 ;; Not using defrecord to avoid unacceptable overhead of recursive
629 ;; hash code calculation.
630 (deftype DispatcherNode [handle handlers parent
631 ^Shape clip ^AffineTransform transform
632 bindings]
633 EventDispatcher
634 (listen! [this component]
635 (listen! parent component))
636 (create-dispatcher [this handle handlers]
637 (create-dispatcher parent handle handlers))
638 (commit [this]
639 (commit parent))
640 (handle-picked? [this handle]
641 (handle-picked? parent handle))
642 (handle-hovered? [this handle]
643 (handle-hovered? parent handle)))
645 (defn- make-node [handle handlers]
646 (let [clip (if *input-clip*
647 (clip *input-clip*)
648 *clip*)
649 bindings (-> (get-thread-bindings)
650 (dissoc (var *graphics*))
651 (assoc (var *font-context*) (font-context)))]
652 (DispatcherNode. handle handlers *event-dispatcher* clip
653 (relative-transform)
654 bindings)))
656 (defn- add-node [tree ^DispatcherNode node]
657 (assoc-cons tree (.parent node) node))
659 (defn- nodes [tree]
660 (apply concat (vals tree)))
662 (defn- under-cursor
663 "Returns a vector of child nodes under cursor."
664 [node tree ^long x ^long y]
665 (some (fn [^DispatcherNode n]
666 (if (and (.clip n) (.contains ^Shape (.clip n) x y))
667 (conj (vec (under-cursor n tree x y)) n)))
668 (get tree node)))
670 (defn- translate-mouse-event [^java.awt.event.MouseEvent event
671 ^AffineTransform tr id]
672 (let [[x y] (inverse-transform-point tr (.getX event) (.getY event))
673 rotation (if (instance? MouseWheelEvent event)
674 (.getWheelRotation ^MouseWheelEvent event)
675 nil)]
676 (->MouseEvent id (.getWhen event) x y
677 (.getXOnScreen event) (.getYOnScreen event)
678 (.getButton event)
679 rotation
680 tr
681 (.getComponent event))))
683 (defn- translate-and-dispatch
684 ([nodes first-only ^java.awt.event.MouseEvent event]
685 (translate-and-dispatch nodes first-only
686 event (awt-events (.getID event))))
687 ([nodes first-only event id]
688 (if-let [^DispatcherNode node (first nodes)]
689 (let [handlers (.handlers node)
690 handler (get handlers id)]
691 (if handler
692 (do
693 (with-bindings* (.bindings node)
694 handler
695 (translate-mouse-event event (.transform node) id))
696 (when-not first-only
697 (recur (rest nodes) false event id)))
698 (when-not (and (= id :mouse-dragged)
699 (or (contains? handlers :mouse-pressed)
700 (contains? handlers :mouse-released)))
701 (recur (rest nodes) first-only event id)))))))
703 (defn- process-mouse-event
704 [dispatcher ^java.awt.event.MouseEvent source-event]
705 (let [{active-ref :active
706 hovered-ref :hovered
707 picked-ref :picked
708 last-ref :last-motion
709 tree-ref :tree} dispatcher
710 pressed (and source-event
711 (== (.getID source-event)
712 java.awt.event.MouseEvent/MOUSE_PRESSED))
713 released (and source-event
714 (== (.getID source-event)
715 java.awt.event.MouseEvent/MOUSE_RELEASED))
716 ^java.awt.event.MouseEvent last-event @last-ref
717 ^java.awt.event.MouseEvent event (or source-event last-event)]
718 (when event
719 (let [x (.getX event)
720 y (.getY event)
721 active @active-ref
722 active (if (and active
723 source-event
724 (== (.getX last-event) x)
725 (== (.getY last-event) y))
726 active
727 (ref-set active-ref
728 (under-cursor dispatcher @tree-ref x y)))
729 acted (cond
730 pressed (ref-set picked-ref active)
731 released (let [picked @picked-ref]
732 (ref-set picked-ref nil)
733 picked)
734 :else active)
735 picked (seq @picked-ref)
736 pred #(= (.handle ^DispatcherNode %1) (.handle ^DispatcherNode %2))
737 hovered (if picked
738 (filter #(some (partial pred %) picked) active)
739 active)
740 remove-all (fn [c1 c2]
741 (filter #(not (some (partial pred %) c2)) c1))
742 old-hovered @hovered-ref
743 exited (remove-all old-hovered hovered)
744 entered (remove-all hovered old-hovered)
745 moved (or picked (remove-all hovered entered))]
746 (ref-set hovered-ref hovered)
747 (ref-set last-ref event)
748 [exited entered moved acted event]))))
750 (defn- dispatch-mouse-event
751 [dispatcher source-event button?]
752 (when-let [[exited
753 entered
754 moved
755 acted
756 event] (dosync (process-mouse-event dispatcher source-event))]
757 (when button?
758 (translate-and-dispatch acted true event))
759 (translate-and-dispatch exited false event :mouse-exited)
760 (translate-and-dispatch entered false event :mouse-entered)
761 (when-not button?
762 (translate-and-dispatch moved true source-event))))
764 (defrecord RootEventDispatcher [tree-r ;; register
765 tree ;; dispatch
766 active ;; nodes under cursor
767 hovered ;; mouse entered
768 picked ;; mouse pressed
769 last-motion]
770 EventDispatcher
771 (listen! [dispatcher component]
772 (doto ^Component component
773 (.addMouseListener dispatcher)
774 (.addMouseWheelListener dispatcher)
775 (.addMouseMotionListener dispatcher)))
776 (create-dispatcher [dispatcher handle handlers]
777 (let [node (make-node handle handlers)]
778 (dosync (alter tree-r add-node node))
779 node))
780 (commit [dispatcher]
781 (let [[exited
782 entered
783 _ _
784 event] (dosync
785 ;; TODO: retain contexts that do
786 ;; not intersect graphics
787 ;; clipping area in tree.
788 (ref-set tree @tree-r)
789 (ref-set tree-r {})
790 (process-mouse-event dispatcher nil))]
791 ;; Send mouse entered and exited events if necessary due to
792 ;; updated layout.
793 (translate-and-dispatch exited false event :mouse-exited)
794 (translate-and-dispatch entered false event :mouse-entered)))
795 (handle-picked? [dispatcher handle]
796 (some #(= handle (.handle ^DispatcherNode %)) @picked))
797 (handle-hovered? [dispatcher handle]
798 (some #(= handle (.handle ^DispatcherNode %)) @hovered))
799 MouseListener
800 (mouseEntered [dispatcher event]
801 (dispatch-mouse-event dispatcher event false))
802 (mouseExited [dispatcher event]
803 (dispatch-mouse-event dispatcher event false))
804 (mouseClicked [dispatcher event]
805 (dispatch-mouse-event dispatcher event true))
806 (mousePressed [dispatcher event]
807 (dispatch-mouse-event dispatcher event true))
808 (mouseReleased [dispatcher event]
809 (dispatch-mouse-event dispatcher event true))
810 MouseWheelListener
811 (mouseWheelMoved [dispatcher event]
812 (dispatch-mouse-event dispatcher event true))
813 MouseMotionListener
814 (mouseDragged [dispatcher event]
815 (dispatch-mouse-event dispatcher event false))
816 (mouseMoved [dispatcher event]
817 (dispatch-mouse-event dispatcher event false)))
819 (defn root-event-dispatcher []
820 (->RootEventDispatcher
821 (ref {}) (ref {}) ;; trees
822 (ref nil) (ref nil) (ref nil) ;; node states
823 (ref nil))) ;; last event
825 ;;
826 ;; Scene
827 ;;
829 (defrecord Scene [view
830 event-dispatcher
831 component
832 rendering-hints
833 next-state])
835 ;; Define rendering hints that affect font metrics to make sure that
836 ;; Graphics and Scene FontRenderContexts are consistent.
837 (def ^:private default-rendering-hints
838 {RenderingHints/KEY_TEXT_ANTIALIASING
839 RenderingHints/VALUE_TEXT_ANTIALIAS_DEFAULT,
840 RenderingHints/KEY_FRACTIONALMETRICS
841 RenderingHints/VALUE_FRACTIONALMETRICS_DEFAULT})
843 (defn make-scene
844 ([view]
845 (make-scene view dummy-event-dispatcher nil))
846 ([view event-dispatcher]
847 (make-scene view event-dispatcher nil))
848 ([view event-dispatcher ^Component component]
849 (make-scene view event-dispatcher component nil))
850 ([view event-dispatcher ^Component component hints]
851 (let [hints (merge default-rendering-hints hints)]
852 (->Scene view
853 event-dispatcher
854 component
855 hints
856 (atom nil)))))
858 (defn- get-and-set!
859 "Atomically sets the value of atom to newval and returns the old
860 value."
861 [atom newval]
862 (loop [v @atom]
863 (if (compare-and-set! atom v newval)
864 v
865 (recur @atom))))
867 (defn draw-scene!
868 [scene ^Graphics2D graphics width height]
869 (.addRenderingHints graphics (:rendering-hints scene))
870 (binding [*states* (get-and-set! (:next-state scene) nil)
871 *scene* scene
872 *graphics* graphics
873 *initial-transform* (.getTransform graphics)
874 *inverse-initial-transform* (-> graphics
875 .getTransform
876 .createInverse)
877 *event-dispatcher* (:event-dispatcher scene)
878 *width* width
879 *height* height
880 *clip* (Rectangle2D$Double. 0.0 0.0 width height)
881 *input-clip* nil
882 *time* (System/nanoTime)]
883 (apply-theme)
884 (let [tmp-watcher (Object.)]
885 ;; Keep current context observers until the rendering is
886 ;; complete. Some observers may be invoked twice if they
887 ;; appear in both groups until tmp-watcher is removed.
888 (replace-observers-watcher scene tmp-watcher)
889 (try
890 (render! (:view scene))
891 (finally
892 (remove-observers tmp-watcher)
893 (commit (:event-dispatcher scene)))))))
895 (defn- scene-font-context [scene]
896 (let [hints (:rendering-hints scene)
897 ^Component c (:component scene)
898 t (if c (->> c
899 .getFont
900 (.getFontMetrics c)
901 .getFontRenderContext
902 .getTransform))]
903 (FontRenderContext.
904 t
905 (get hints RenderingHints/KEY_TEXT_ANTIALIASING)
906 (get hints RenderingHints/KEY_FRACTIONALMETRICS))))
908 (defn scene-geometry [scene]
909 (binding [*scene* scene
910 *font-context* (scene-font-context scene)]
911 (geometry (:view scene))))
913 (defn set-cursor! [^Cursor cursor]
914 (when-let [^Component component (:component *scene*)]
915 (EventQueue/invokeLater #(.setCursor component cursor))))