view src/indyvon/core.clj @ 186:bf1f63968d85

Updated dependencies.
author Mikhail Kryshen <mikhail@kryshen.net>
date Wed, 25 Apr 2018 10:26:01 +0300
parents e73174356504
children
line source
1 ;;
2 ;; Copyright 2010-2017 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
36 ^{:doc "The graphics context, an instance of java.awt.Graphics2D."}
37 *graphics*)
39 (def ^:dynamic ^FontRenderContext *font-context*
40 "FontRenderContext to use when Graphics2D is not available."
41 (FontRenderContext.
42 nil
43 RenderingHints/VALUE_TEXT_ANTIALIAS_DEFAULT
44 RenderingHints/VALUE_FRACTIONALMETRICS_DEFAULT))
46 (def ^:dynamic
47 ^{:doc "Width of the rendering area."}
48 *width*)
50 (def ^:dynamic
51 ^{:doc "Height of the rendering area."}
52 *height*)
54 (def ^:dynamic ^Shape
55 ^{:doc "The View context's clipping area. Does not account for
56 partial repaints, may differ from (.getClip *graphics*)."}
57 *clip*)
59 (def ^:dynamic ^Shape
60 ^{:doc "Clipping area used for dispatching pointer events (after
61 intersecting with *clip*). If nil, *clip* is used."}
62 *input-clip*)
64 (def ^:dynamic
65 ^{:doc "Timestamp of the current frame (in nanoseconds)."}
66 *time*)
68 (def ^:dynamic
69 ^{:doc "Encloses state that should be retained between repaints."}
70 *scene*)
72 (def ^:dynamic
73 ^{:doc "Transient scene states, a map."}
74 *states*)
76 (def ^:dynamic *event-dispatcher*)
78 (def ^:dynamic ^AffineTransform
79 ^{:doc "Initial transform associated with the graphics context."}
80 *initial-transform*)
82 (def ^:dynamic ^AffineTransform
83 ^{:doc "Inversion of the initial transform associated with the
84 graphics context."}
85 *inverse-initial-transform*)
87 (defrecord Theme [fore-color back-color alt-back-color border-color
88 shadow-color font])
90 ;; REMIND: use system colors, see java.awt.SystemColor.
91 (defn default-theme []
92 (Theme. Color/BLACK
93 Color/WHITE
94 (Color. 0xDD 0xDD 0xDD)
95 (Color. 0 0 0xCC)
96 (Color. 0x44 0x44 0x44)
97 (Font. "Sans" Font/PLAIN 12)))
99 (def ^:dynamic *theme* (default-theme))
101 ;;
102 ;; Core protocols and types
103 ;;
105 (defprotocol View
106 "Basic UI element."
107 (render! [view]
108 "Draws the view in the current *graphics* context.")
109 (geometry [view]
110 "Returns the preferred Geometry for the view."))
112 (defprotocol Geometry
113 "Describes geometry of a View. Prefer using the available
114 implementations (Size, FixedGeometry and NestedGeometry) over
115 extending this protocol directly as it is likely to be changed in
116 the future versions."
117 (width [geom] [geom height])
118 (height [geom] [geom width])
119 (anchor-x [geom h-align width]
120 "Returns the x coordinate of the anchor point for the specified
121 horizontal alignment and width, h-align could be :left, :center
122 or :right.")
123 (anchor-y [geom v-align height]
124 "Returns the y coordinate of the anchor point for the specified
125 vertical alignment and height, v-align could be :top, :center
126 or :bottom."))
128 (defn- emit-align-xy [align size first center last]
129 `(case ~align
130 ~first 0
131 ~center (/ ~size 2)
132 ~last ~size))
134 ;; Define as macro to avoid unnecessary calculation of width or height.
135 (defmacro align-x
136 ([align inner outer]
137 `(align-x ~align (- ~outer ~inner)))
138 ([align width]
139 (emit-align-xy align width :left :center :right)))
141 (defmacro align-y
142 ([align inner outer]
143 `(align-y ~align (- ~outer ~inner)))
144 ([align height]
145 (emit-align-xy align height :top :center :bottom)))
147 (defrecord Size [width height]
148 Geometry
149 (width [_] width)
150 (width [_ _] width)
151 (height [_] height)
152 (height [_ _] height)
153 (anchor-x [_ h-align width]
154 (align-x h-align width))
155 (anchor-y [_ v-align height]
156 (align-y v-align height)))
158 (defrecord FixedGeometry [ax ay width height]
159 Geometry
160 (width [_] width)
161 (width [_ _] width)
162 (height [_] height)
163 (height [_ _] height)
164 (anchor-x [_ _ _] ax)
165 (anchor-y [_ _ _] ay))
167 (defrecord NestedGeometry [geometry top left bottom right]
168 Geometry
169 (width [_]
170 (+ left right (width geometry)))
171 (width [_ h]
172 (+ left right (width geometry (- h top bottom))))
173 (height [_]
174 (+ top bottom (height geometry)))
175 (height [_ w]
176 (+ top bottom (height geometry (- w left right))))
177 (anchor-x [_ h-align w]
178 (+ left (anchor-x geometry h-align (- w left right))))
179 (anchor-y [_ v-align h]
180 (+ top (anchor-y geometry v-align (- h top bottom)))))
182 (defrecord ScaledGeometry [geometry sx sy]
183 Geometry
184 (width [_]
185 (* sx (width geometry)))
186 (width [_ h]
187 (* sx (width geometry (/ h sy))))
188 (height [_]
189 (* sy (height geometry)))
190 (height [_ w]
191 (* sy (height geometry (/ w sx))))
192 (anchor-x [_ h-align w]
193 (* sx (anchor-x geometry h-align (/ w sx))))
194 (anchor-y [_ v-align h]
195 (* sy (anchor-y geometry v-align (/ h sy)))))
197 (defrecord TransposedGeometry [geometry]
198 Geometry
199 (width [_]
200 (height geometry))
201 (width [_ h]
202 (height geometry h))
203 (height [_]
204 (width geometry))
205 (height [_ w]
206 (width geometry w))
207 (anchor-x [_ h-align w]
208 (anchor-y geometry
209 (get {:left :top
210 :center :center
211 :right :bottom}
212 h-align)
213 w))
214 (anchor-y [_ v-align h]
215 (anchor-x geometry
216 (get {:top :left
217 :center :center
218 :bottom :right}
219 v-align)
220 h)))
222 ;; (defn ^:private to-integer
223 ;; ^long [align x]
224 ;; (if (integer? x)
225 ;; x
226 ;; (let [x (double x)]
227 ;; (Math/round
228 ;; (case align
229 ;; (:top :left) (Math/floor x)
230 ;; :center x
231 ;; (:bottom :right) (Math/ceil x))))))
233 ;; (defrecord IntegerGeometry [geometry]
234 ;; Geometry
235 ;; (width [_]
236 ;; (to-integer :right (width geometry)))
237 ;; (width [_ h]
238 ;; (to-integer :right (width geometry h)))
239 ;; (height [_]
240 ;; (to-integer :bottom (height geometry)))
241 ;; (height [_ w]
242 ;; (to-integer :bottom (height geometry w)))
243 ;; (anchor-x [_ h-align w]
244 ;; (to-integer h-align (anchor-x geometry h-align w)))
245 ;; (anchor-y [_ v-align h]
246 ;; (to-integer v-align (anchor-y geometry v-align h))))
248 ;; TODO: modifiers
249 (defrecord MouseEvent [id when x y x-on-screen y-on-screen button
250 wheel-rotation transform component])
252 ;; TODO: KeyEvent
254 (defprotocol EventDispatcher
255 (listen! [this component]
256 "Listen for events on the specified AWT Component.")
257 (create-dispatcher [this handle handlers]
258 "Returns new event dispatcher associated with the specified event
259 handlers (an event-id -> handler-fn map). Handle is used to match
260 the contexts between commits.")
261 (commit [this]
262 "Apply the registered handlers for event processing.")
263 (handle-picked? [this handle]
264 "Returns true if the specified handle received the :mouse-pressed
265 event and have not yet received :moused-released.")
266 (handle-hovered? [this handle]
267 "Returns true if the specified handle received the :mouse-entered
268 event and have not yet received :mouse-exited."))
270 (defn- assoc-cons [m key val]
271 (->> (get m key) (cons val) (assoc m key)))
273 ;;
274 ;; Observers
275 ;; The mechanism used by views to request repaints
276 ;;
278 (def ^:private ^ConcurrentMap observers
279 (-> (MapMaker.) (.weakKeys) (.makeMap)))
281 (defn- cm-replace!
282 "Wrap ConcurrentMap replace method to treat nil value as absent
283 mapping. Use with maps that does not support nil values."
284 [^ConcurrentMap cmap key old new]
285 (if (nil? old)
286 (nil? (.putIfAbsent cmap key new))
287 (.replace cmap key old new)))
289 (defn- cm-swap!
290 "Atomically swaps the value associated with key in ConcurrentMap
291 to be (apply f current-value args). Returns the new value."
292 [^ConcurrentMap cmap key f & args]
293 (loop []
294 (let [old (.get cmap key)
295 new (apply f old args)]
296 (if (cm-replace! cmap key old new)
297 new
298 (recur)))))
300 (defn add-observer!
301 "Add observer fn for the subject. Watcher identifies the group of
302 observers and could be used to remove the group. Watcher is weakly
303 referenced, all associated observers will be removed when the
304 wathcer is removed by gc. The observer fn will be called with
305 watcher and subject arguments and any additional arguments that was
306 passed to the notify! function."
307 [watcher subject f]
308 (cm-swap! observers watcher assoc-cons subject f)
309 nil)
311 (defn remove-observers!
312 "Remove group of observers associated with the specified watcher."
313 [watcher]
314 (.remove observers watcher)
315 nil)
317 (defn- replace-observers-watcher!
318 [old-watcher new-watcher]
319 (if-let [old (.remove observers old-watcher)]
320 (.put observers new-watcher old))
321 nil)
323 (defn notify!
324 "Notify the observers."
325 [subject & args]
326 (doseq [entry observers
327 f (get (val entry) subject)]
328 (apply f (key entry) subject args)))
330 (defn add-context-observer!
331 "Observer registered with this function will be automatically
332 removed after the next repaint is complete."
333 [subject f]
334 (add-observer! *scene* subject f))
336 (defn repaint-on-update!
337 "Trigger repaint of the current scene when notify! is
338 called with the subject."
339 [subject]
340 (let [scene *scene*]
341 (if-not (identical? scene subject)
342 (add-observer! scene subject (fn [w _] (notify! w))))))
344 (defn repaint!
345 "Requests repaint of the current scene. If handle and state are
346 specified, the handle will be associated with the state in the
347 *states* map for the next paint iteration."
348 ([]
349 (notify! *scene*))
350 ([handle state]
351 (let [scene *scene*]
352 (swap! (:next-state scene) assoc handle state)
353 (notify! scene))))
355 (defmacro binding-fast
356 "Faster alternative to core/binding. Works only with vars that are
357 already thread-bound. Uses set! instead of push-thread-bindings and
358 pop-thread-bindings."
359 [bindings & body]
360 {:pre [(vector? bindings)
361 (even? (count bindings))]}
362 (let [bindings (partition 2 bindings)
363 var-syms (map first bindings)
364 var-vals (map second bindings)
365 syms (map (comp gensym name) var-syms)]
366 `(let [~@(mapcat vector syms var-syms)]
367 (try
368 ~@(map #(list `set! %1 %2) var-syms var-vals)
369 ~@body
370 (finally
371 ~@(map #(list `set! %1 %2) var-syms syms))))))
373 ;;
374 ;; Rendering
375 ;;
377 (defn ^FontRenderContext font-context
378 "Returns FontRenderContext for the current view context."
379 []
380 (if (bound? (var *graphics*))
381 (.getFontRenderContext *graphics*)
382 *font-context*))
384 (defn ^AffineTransform relative-transform
385 "Returns AffineTransform: view context -> AWT component."
386 []
387 (let [tr (.getTransform *graphics*)]
388 (.preConcatenate tr *inverse-initial-transform*)
389 tr))
391 (defn ^AffineTransform inverse-relative-transform
392 "Returns AffineTransform: AWT component -> view context."
393 []
394 (let [tr (.getTransform *graphics*)]
395 (.invert tr) ; absolute -> view
396 (.concatenate tr *initial-transform*) ; component -> absolute
397 tr))
399 (defn transform-point [^AffineTransform tr ^double x ^double y]
400 (let [p (Point2D$Double. x y)]
401 (.transform tr p p)
402 [(.x p) (.y p)]))
404 (defn inverse-transform-point [^AffineTransform tr ^double x ^double y]
405 (let [p (Point2D$Double. x y)]
406 (.inverseTransform tr p p)
407 [(.x p) (.y p)]))
409 ;; (defn- clip
410 ;; "Intersect clipping area with the specified shape or bounds.
411 ;; Returns new clip (Shape or nil if empty)."
412 ;; ([x y w h]
413 ;; (clip (Rectangle2D$Double. x y w h)))
414 ;; ([shape]
415 ;; (let [a1 (Area. shape)
416 ;; a2 (if (instance? Area *clip*) *clip* (Area. *clip*))]
417 ;; (.transform a1 (relative-transform))
418 ;; (.intersect a1 a2)
419 ;; (if (.isEmpty a1)
420 ;; nil
421 ;; a1))))
423 ;; Use faster clipping calculation provided by Graphics2D.
424 (defn- clip
425 "Intersect clipping area with the specified Shape in current
426 transform coordinates. Returns new clip in the AWT component
427 coordinates (Shape or nil if empty)."
428 [^Shape shape]
429 (let [^Graphics2D clip-g (.create *graphics*)]
430 (try
431 (doto clip-g
432 (.setClip shape)
433 (.setTransform *initial-transform*)
434 (.clip *clip*))
435 (if (.isEmpty (.getClipBounds clip-g))
436 nil
437 (.getClip clip-g))
438 (finally
439 (.dispose clip-g)))))
441 (defn- theme-get*
442 ([theme key]
443 (theme-get* theme key nil))
444 ([theme key not-found]
445 (if-let [e (find theme key)]
446 (loop [k (val e)]
447 (if-let [e1 (and (keyword? k)
448 (find theme k))]
449 (recur (val e1))
450 k))
451 not-found)))
453 (defn theme-get
454 ([key]
455 (theme-get* *theme* key))
456 ([key not-found]
457 (theme-get* *theme* key not-found)))
459 (defn ^Graphics2D apply-theme
460 "Set graphics' color and font to match theme.
461 Modifies and returns the first argument."
462 ([]
463 (apply-theme *graphics* *theme*))
464 ([^Graphics2D graphics theme]
465 (doto graphics
466 (.setColor (theme-get :fore-color))
467 (.setBackground (theme-get :back-color))
468 (.setFont (theme-get :font)))))
470 (defn- ^Graphics2D create-graphics
471 ([]
472 (apply-theme (.create *graphics*) *theme*))
473 ([^long x ^long y ^long w ^long h]
474 (apply-theme (.create *graphics* x y w h) *theme*)))
476 (defn- with-bounds-noclip*
477 [x y w h f & args]
478 (let [graphics (create-graphics)]
479 (try
480 (.translate graphics (double x) (double y))
481 (binding-fast [*width* w
482 *height* h
483 *input-clip* (Rectangle2D$Double. 0.0 0.0 w h)
484 *graphics* graphics]
485 (apply f args))
486 (finally
487 (.dispose graphics)))))
489 (defn with-bounds*
490 [x y w h f & args]
491 (let [x (double x)
492 y (double y)
493 bounds (Rectangle2D$Double. x y w h)]
494 (when-let [clip (clip bounds)]
495 (let [^Graphics2D graphics (create-graphics)]
496 (try
497 (.clip graphics bounds)
498 (.translate graphics x y)
499 (binding-fast [*width* w
500 *height* h
501 *clip* clip
502 *input-clip* nil
503 *graphics* graphics]
504 (apply f args))
505 (finally
506 (.dispose graphics)))))))
508 (defmacro with-bounds
509 [x y w h & body]
510 `(with-bounds* ~x ~y ~w ~h (fn [] ~@body)))
512 (defmacro with-theme
513 [theme & body]
514 `(binding [*theme* (merge *theme* ~theme)]
515 ~@body))
517 (defn with-theme* [theme f & args]
518 (with-theme theme
519 (apply f args)))
521 (defmacro with-color [color-or-key & body]
522 `(let [color# ~color-or-key
523 color# (theme-get color# color#)
524 g# *graphics*
525 old-color# (.getColor g#)]
526 (try
527 (.setColor g# color#)
528 ~@body
529 (finally
530 (.setColor g# old-color#)))))
532 (defmacro with-font [font-or-key & body]
533 `(let [font# ~font-or-key
534 font# (theme-get font# font#)
535 g# *graphics*
536 old-font# (.getFont g#)]
537 (try
538 (.setFont g# font#)
539 ~@body
540 (finally
541 (.setColor g# old-font#)))))
543 (defmacro with-stroke [stroke & body]
544 `(let [g# *graphics*
545 old-stroke# (.getStroke g#)]
546 (try
547 (.setStroke g# ~stroke)
548 ~@body
549 (finally
550 (.setStroke g# old-stroke#)))))
552 (defmacro with-hints
553 [hints & body]
554 `(let [h# ~hints
555 g# *graphics*
556 old# (.getRenderingHints g#)]
557 (try
558 (.addRenderingHints g# h#)
559 ~@body
560 (finally
561 (.setRenderingHints g# old#)))))
563 (defn with-hints* [hints f & args]
564 (with-hints hints
565 (apply f args)))
567 ;; TODO: Composable transformations:
568 ;; (with-transform (-> (scale 0.3 0.5)
569 ;; (rotate-deg 30)
570 ;; (translate 5 10))
571 ;; ...)
573 (defmacro with-transform [transform & body]
574 `(let [g# *graphics*
575 old-t# (.getTransform g#)]
576 (try
577 (.transform g# ~transform)
578 ~@body
579 (finally
580 (.setTransform g# old-t#)))))
582 (defn with-transform* [transform f & args]
583 (with-transform transform
584 (apply f args)))
586 (defmacro with-rotate [theta ax ay & body]
587 `(let [transform# (AffineTransform/getRotateInstance ~theta ~ax ~ay)]
588 (with-transform transform# ~@body)))
590 (defmacro with-translate [x y & body]
591 `(let [x# ~x
592 y# ~y
593 g# *graphics*]
594 (try
595 (.translate g# x# y#)
596 ~@body
597 (finally
598 (.translate g# (- x#) (- y#))))))
600 (defn draw!
601 "Draws the View."
602 ([view]
603 (let [graphics (create-graphics)]
604 (try
605 (binding-fast [*graphics* graphics]
606 (render! view))
607 (finally
608 (.dispose graphics)))))
609 ([view x y]
610 (draw! view x y true))
611 ([view x y clip?]
612 (let [geom (geometry view)]
613 (draw! view x y (width geom) (height geom) clip?)))
614 ([view x y width height]
615 (draw! view x y width height true))
616 ([view x y width height clip?]
617 (if clip?
618 (with-bounds* x y width height render! view)
619 (with-bounds-noclip* x y width height render! view))))
621 (defn draw-aligned!
622 "Draws the View. Location is relative to the view's anchor point
623 for the specified alignment."
624 ([view h-align v-align x y]
625 (draw-aligned! view (geometry view) h-align v-align x y))
626 ([view geom h-align v-align x y]
627 (draw-aligned! view geom h-align v-align x y (width geom) (height geom)))
628 ([view h-align v-align x y w h]
629 (draw-aligned! view (geometry view) h-align v-align x y w h))
630 ([view geom h-align v-align x y w h]
631 (draw! view
632 (- x (anchor-x geom h-align w))
633 (- y (anchor-y geom v-align h))
634 w h)))
636 ;;
637 ;; Event handling.
638 ;;
640 (defn with-handlers*
641 [handle handlers f & args]
642 (binding-fast [*event-dispatcher* (create-dispatcher
643 *event-dispatcher* handle handlers)]
644 (apply f args)))
646 (defmacro handlers [& specs]
647 (reduce (fn [m spec]
648 (assoc m (first spec)
649 `(fn [~(second spec)]
650 ~@(nnext spec)))) {}
651 specs))
653 (defmacro with-handlers
654 "specs => (:event-id name & handler-body)*
656 Execute form with the specified event handlers."
657 [handle form & specs]
658 `(with-handlers* ~handle
659 (handlers ~@specs)
660 (fn [] ~form)))
662 (defn picked? [handle]
663 (handle-picked? *event-dispatcher* handle))
665 (defn hovered? [handle]
666 (handle-hovered? *event-dispatcher* handle))
668 ;;
669 ;; EventDispatcher implementation
670 ;;
672 (def awt-events
673 {java.awt.event.MouseEvent/MOUSE_CLICKED :mouse-clicked
674 java.awt.event.MouseEvent/MOUSE_DRAGGED :mouse-dragged
675 java.awt.event.MouseEvent/MOUSE_ENTERED :mouse-entered
676 java.awt.event.MouseEvent/MOUSE_EXITED :mouse-exited
677 java.awt.event.MouseEvent/MOUSE_MOVED :mouse-moved
678 java.awt.event.MouseEvent/MOUSE_PRESSED :mouse-pressed
679 java.awt.event.MouseEvent/MOUSE_RELEASED :mouse-released
680 java.awt.event.MouseEvent/MOUSE_WHEEL :mouse-wheel})
682 (def dummy-event-dispatcher
683 (reify EventDispatcher
684 (listen! [_ _])
685 (create-dispatcher [this _ _] this)
686 (commit [_])
687 (handle-picked? [_ _])
688 (handle-hovered? [_ _])))
690 ;; Not using defrecord to avoid unacceptable overhead of recursive
691 ;; hash code calculation.
692 (deftype DispatcherNode [handle handlers parent
693 ^Shape clip ^AffineTransform transform
694 bindings]
695 EventDispatcher
696 (listen! [this component]
697 (listen! parent component))
698 (create-dispatcher [this handle handlers]
699 (create-dispatcher parent handle handlers))
700 (commit [this]
701 (commit parent))
702 (handle-picked? [this handle]
703 (handle-picked? parent handle))
704 (handle-hovered? [this handle]
705 (handle-hovered? parent handle)))
707 (defn- make-node [handle handlers]
708 (let [clip (if *input-clip*
709 (clip *input-clip*)
710 *clip*)
711 bindings (-> (get-thread-bindings)
712 (dissoc (var *graphics*))
713 (assoc (var *font-context*) (font-context)))]
714 (DispatcherNode. handle handlers *event-dispatcher* clip
715 (relative-transform)
716 bindings)))
718 (defn- add-node [tree ^DispatcherNode node]
719 (assoc-cons tree (.parent node) node))
721 (defn- nodes [tree]
722 (apply concat (vals tree)))
724 (defn- under-cursor
725 "Returns a vector of child nodes under cursor."
726 [node tree ^long x ^long y]
727 (some (fn [^DispatcherNode n]
728 (if (and (.clip n) (.contains ^Shape (.clip n) x y))
729 (conj (vec (under-cursor n tree x y)) n)))
730 (get tree node)))
732 (defn- translate-mouse-event [^java.awt.event.MouseEvent event
733 ^AffineTransform tr id]
734 (let [[x y] (inverse-transform-point tr (.getX event) (.getY event))
735 rotation (if (instance? MouseWheelEvent event)
736 (.getWheelRotation ^MouseWheelEvent event)
737 nil)]
738 (->MouseEvent id (.getWhen event) x y
739 (.getXOnScreen event) (.getYOnScreen event)
740 (.getButton event)
741 rotation
742 tr
743 (.getComponent event))))
745 (defn- translate-and-dispatch
746 ([nodes first-only ^java.awt.event.MouseEvent event]
747 (translate-and-dispatch nodes first-only
748 event (awt-events (.getID event))))
749 ([nodes first-only event id]
750 (if-let [^DispatcherNode node (first nodes)]
751 (let [handlers (.handlers node)
752 handler (get handlers id)]
753 (if handler
754 (do
755 (with-bindings* (.bindings node)
756 handler
757 (translate-mouse-event event (.transform node) id))
758 (when-not first-only
759 (recur (rest nodes) false event id)))
760 (when-not (and (= id :mouse-dragged)
761 (or (contains? handlers :mouse-pressed)
762 (contains? handlers :mouse-released)))
763 (recur (rest nodes) first-only event id)))))))
765 (defn- process-mouse-event
766 [dispatcher ^java.awt.event.MouseEvent source-event]
767 (let [{active-ref :active
768 hovered-ref :hovered
769 picked-ref :picked
770 last-ref :last-motion
771 tree-ref :tree} dispatcher
772 pressed (and source-event
773 (== (.getID source-event)
774 java.awt.event.MouseEvent/MOUSE_PRESSED))
775 released (and source-event
776 (== (.getID source-event)
777 java.awt.event.MouseEvent/MOUSE_RELEASED))
778 ^java.awt.event.MouseEvent last-event @last-ref
779 ^java.awt.event.MouseEvent event (or source-event last-event)]
780 (when event
781 (let [x (.getX event)
782 y (.getY event)
783 active @active-ref
784 active (if (and active
785 source-event
786 (== (.getX last-event) x)
787 (== (.getY last-event) y))
788 active
789 (ref-set active-ref
790 (under-cursor dispatcher @tree-ref x y)))
791 acted (cond
792 pressed (ref-set picked-ref active)
793 released (let [picked @picked-ref]
794 (ref-set picked-ref nil)
795 picked)
796 :else active)
797 picked (seq @picked-ref)
798 pred #(= (.handle ^DispatcherNode %1) (.handle ^DispatcherNode %2))
799 hovered (if picked
800 (filter #(some (partial pred %) picked) active)
801 active)
802 remove-all (fn [c1 c2]
803 (filter #(not (some (partial pred %) c2)) c1))
804 old-hovered @hovered-ref
805 exited (remove-all old-hovered hovered)
806 entered (remove-all hovered old-hovered)
807 moved (or picked (remove-all hovered entered))]
808 (ref-set hovered-ref hovered)
809 (ref-set last-ref event)
810 [exited entered moved acted event]))))
812 (defn- dispatch-mouse-event
813 [dispatcher source-event button?]
814 (when-let [[exited
815 entered
816 moved
817 acted
818 event] (dosync (process-mouse-event dispatcher source-event))]
819 (when button?
820 (translate-and-dispatch acted true event))
821 (translate-and-dispatch exited false event :mouse-exited)
822 (translate-and-dispatch entered false event :mouse-entered)
823 (when-not button?
824 (translate-and-dispatch moved true source-event))))
826 (defrecord RootEventDispatcher [tree-r ;; register
827 tree ;; dispatch
828 active ;; nodes under cursor
829 hovered ;; mouse entered
830 picked ;; mouse pressed
831 last-motion]
832 EventDispatcher
833 (listen! [dispatcher component]
834 (doto ^Component component
835 (.addMouseListener dispatcher)
836 (.addMouseWheelListener dispatcher)
837 (.addMouseMotionListener dispatcher)))
838 (create-dispatcher [dispatcher handle handlers]
839 (let [node (make-node handle handlers)]
840 (dosync (alter tree-r add-node node))
841 node))
842 (commit [dispatcher]
843 (let [[exited
844 entered
845 _ _
846 event] (dosync
847 ;; TODO: retain contexts that do
848 ;; not intersect graphics
849 ;; clipping area in tree.
850 (ref-set tree @tree-r)
851 (ref-set tree-r {})
852 (process-mouse-event dispatcher nil))]
853 ;; Send mouse entered and exited events if necessary due to
854 ;; updated layout.
855 (translate-and-dispatch exited false event :mouse-exited)
856 (translate-and-dispatch entered false event :mouse-entered)))
857 (handle-picked? [dispatcher handle]
858 (some #(= handle (.handle ^DispatcherNode %)) @picked))
859 (handle-hovered? [dispatcher handle]
860 (some #(= handle (.handle ^DispatcherNode %)) @hovered))
861 MouseListener
862 (mouseEntered [dispatcher event]
863 (dispatch-mouse-event dispatcher event false))
864 (mouseExited [dispatcher event]
865 (dispatch-mouse-event dispatcher event false))
866 (mouseClicked [dispatcher event]
867 (dispatch-mouse-event dispatcher event true))
868 (mousePressed [dispatcher event]
869 (dispatch-mouse-event dispatcher event true))
870 (mouseReleased [dispatcher event]
871 (dispatch-mouse-event dispatcher event true))
872 MouseWheelListener
873 (mouseWheelMoved [dispatcher event]
874 (dispatch-mouse-event dispatcher event true))
875 MouseMotionListener
876 (mouseDragged [dispatcher event]
877 (dispatch-mouse-event dispatcher event false))
878 (mouseMoved [dispatcher event]
879 (dispatch-mouse-event dispatcher event false)))
881 (defn root-event-dispatcher []
882 (->RootEventDispatcher
883 (ref {}) (ref {}) ;; trees
884 (ref nil) (ref nil) (ref nil) ;; node states
885 (ref nil))) ;; last event
887 ;;
888 ;; Scene
889 ;;
891 (defrecord Scene [view
892 event-dispatcher
893 component
894 rendering-hints
895 next-state])
897 ;; Define rendering hints that affect font metrics to make sure that
898 ;; Graphics and Scene FontRenderContexts are consistent.
899 (def ^:private default-rendering-hints
900 {RenderingHints/KEY_TEXT_ANTIALIASING
901 RenderingHints/VALUE_TEXT_ANTIALIAS_DEFAULT,
902 RenderingHints/KEY_ANTIALIASING
903 RenderingHints/VALUE_ANTIALIAS_ON,
904 RenderingHints/KEY_FRACTIONALMETRICS
905 RenderingHints/VALUE_FRACTIONALMETRICS_DEFAULT})
907 (defn make-scene
908 ([view]
909 (make-scene view dummy-event-dispatcher nil))
910 ([view event-dispatcher]
911 (make-scene view event-dispatcher nil))
912 ([view event-dispatcher ^Component component]
913 (make-scene view event-dispatcher component nil))
914 ([view event-dispatcher ^Component component hints]
915 (let [hints (merge default-rendering-hints hints)]
916 (->Scene view
917 event-dispatcher
918 component
919 hints
920 (atom nil)))))
922 (defn- get-and-set!
923 "Atomically sets the value of atom to newval and returns the old
924 value."
925 [atom newval]
926 (loop [v @atom]
927 (if (compare-and-set! atom v newval)
928 v
929 (recur @atom))))
931 (defn draw-scene!
932 [scene ^Graphics2D graphics width height]
933 (.addRenderingHints graphics (:rendering-hints scene))
934 (binding [*states* (get-and-set! (:next-state scene) nil)
935 *scene* scene
936 *graphics* graphics
937 *initial-transform* (.getTransform graphics)
938 *inverse-initial-transform* (-> graphics
939 .getTransform
940 .createInverse)
941 *event-dispatcher* (:event-dispatcher scene)
942 *width* width
943 *height* height
944 *clip* (Rectangle2D$Double. 0.0 0.0 width height)
945 *input-clip* nil
946 *time* (System/nanoTime)]
947 (apply-theme)
948 (let [tmp-watcher (Object.)]
949 ;; Keep current context observers until the rendering is
950 ;; complete. Some observers may be invoked twice if they
951 ;; appear in both groups until tmp-watcher is removed.
952 (replace-observers-watcher! scene tmp-watcher)
953 (try
954 (render! (:view scene))
955 (finally
956 (remove-observers! tmp-watcher)
957 (commit (:event-dispatcher scene)))))))
959 (defn- scene-font-context [scene]
960 (let [hints (:rendering-hints scene)
961 ^Component c (:component scene)
962 t (if c (->> c
963 .getFont
964 (.getFontMetrics c)
965 .getFontRenderContext
966 .getTransform))]
967 (FontRenderContext.
968 t
969 (get hints RenderingHints/KEY_TEXT_ANTIALIASING)
970 (get hints RenderingHints/KEY_FRACTIONALMETRICS))))
972 (defn scene-geometry [scene]
973 (binding [*scene* scene
974 *font-context* (scene-font-context scene)]
975 (geometry (:view scene))))
977 (defn set-cursor! [^Cursor cursor]
978 (when-let [^Component component (:component *scene*)]
979 (EventQueue/invokeLater #(.setCursor component cursor))))