Mercurial > hg > indyvon
view src/indyvon/core.clj @ 177:f0f11db714f8
Renamed update! to notify!
| author | Mikhail Kryshen <mikhail@kryshen.net> |
|---|---|
| date | Fri, 18 Sep 2015 17:40:25 +0300 |
| parents | eb1bedf22731 |
| children | e73174356504 |
line source
1 ;;
2 ;; Copyright 2010-2015 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 with-handlers
647 "specs => (:event-id name & handler-body)*
649 Execute form with the specified event handlers."
650 [handle form & specs]
651 `(with-handlers* ~handle
652 ~(reduce (fn [m spec]
653 (assoc m (first spec)
654 `(fn [~(second spec)]
655 ~@(nnext spec)))) {}
656 specs)
657 (fn [] ~form)))
659 (defn picked? [handle]
660 (handle-picked? *event-dispatcher* handle))
662 (defn hovered? [handle]
663 (handle-hovered? *event-dispatcher* handle))
665 ;;
666 ;; EventDispatcher implementation
667 ;;
669 (def awt-events
670 {java.awt.event.MouseEvent/MOUSE_CLICKED :mouse-clicked
671 java.awt.event.MouseEvent/MOUSE_DRAGGED :mouse-dragged
672 java.awt.event.MouseEvent/MOUSE_ENTERED :mouse-entered
673 java.awt.event.MouseEvent/MOUSE_EXITED :mouse-exited
674 java.awt.event.MouseEvent/MOUSE_MOVED :mouse-moved
675 java.awt.event.MouseEvent/MOUSE_PRESSED :mouse-pressed
676 java.awt.event.MouseEvent/MOUSE_RELEASED :mouse-released
677 java.awt.event.MouseEvent/MOUSE_WHEEL :mouse-wheel})
679 (def dummy-event-dispatcher
680 (reify EventDispatcher
681 (listen! [_ _])
682 (create-dispatcher [this _ _] this)
683 (commit [_])
684 (handle-picked? [_ _])
685 (handle-hovered? [_ _])))
687 ;; Not using defrecord to avoid unacceptable overhead of recursive
688 ;; hash code calculation.
689 (deftype DispatcherNode [handle handlers parent
690 ^Shape clip ^AffineTransform transform
691 bindings]
692 EventDispatcher
693 (listen! [this component]
694 (listen! parent component))
695 (create-dispatcher [this handle handlers]
696 (create-dispatcher parent handle handlers))
697 (commit [this]
698 (commit parent))
699 (handle-picked? [this handle]
700 (handle-picked? parent handle))
701 (handle-hovered? [this handle]
702 (handle-hovered? parent handle)))
704 (defn- make-node [handle handlers]
705 (let [clip (if *input-clip*
706 (clip *input-clip*)
707 *clip*)
708 bindings (-> (get-thread-bindings)
709 (dissoc (var *graphics*))
710 (assoc (var *font-context*) (font-context)))]
711 (DispatcherNode. handle handlers *event-dispatcher* clip
712 (relative-transform)
713 bindings)))
715 (defn- add-node [tree ^DispatcherNode node]
716 (assoc-cons tree (.parent node) node))
718 (defn- nodes [tree]
719 (apply concat (vals tree)))
721 (defn- under-cursor
722 "Returns a vector of child nodes under cursor."
723 [node tree ^long x ^long y]
724 (some (fn [^DispatcherNode n]
725 (if (and (.clip n) (.contains ^Shape (.clip n) x y))
726 (conj (vec (under-cursor n tree x y)) n)))
727 (get tree node)))
729 (defn- translate-mouse-event [^java.awt.event.MouseEvent event
730 ^AffineTransform tr id]
731 (let [[x y] (inverse-transform-point tr (.getX event) (.getY event))
732 rotation (if (instance? MouseWheelEvent event)
733 (.getWheelRotation ^MouseWheelEvent event)
734 nil)]
735 (->MouseEvent id (.getWhen event) x y
736 (.getXOnScreen event) (.getYOnScreen event)
737 (.getButton event)
738 rotation
739 tr
740 (.getComponent event))))
742 (defn- translate-and-dispatch
743 ([nodes first-only ^java.awt.event.MouseEvent event]
744 (translate-and-dispatch nodes first-only
745 event (awt-events (.getID event))))
746 ([nodes first-only event id]
747 (if-let [^DispatcherNode node (first nodes)]
748 (let [handlers (.handlers node)
749 handler (get handlers id)]
750 (if handler
751 (do
752 (with-bindings* (.bindings node)
753 handler
754 (translate-mouse-event event (.transform node) id))
755 (when-not first-only
756 (recur (rest nodes) false event id)))
757 (when-not (and (= id :mouse-dragged)
758 (or (contains? handlers :mouse-pressed)
759 (contains? handlers :mouse-released)))
760 (recur (rest nodes) first-only event id)))))))
762 (defn- process-mouse-event
763 [dispatcher ^java.awt.event.MouseEvent source-event]
764 (let [{active-ref :active
765 hovered-ref :hovered
766 picked-ref :picked
767 last-ref :last-motion
768 tree-ref :tree} dispatcher
769 pressed (and source-event
770 (== (.getID source-event)
771 java.awt.event.MouseEvent/MOUSE_PRESSED))
772 released (and source-event
773 (== (.getID source-event)
774 java.awt.event.MouseEvent/MOUSE_RELEASED))
775 ^java.awt.event.MouseEvent last-event @last-ref
776 ^java.awt.event.MouseEvent event (or source-event last-event)]
777 (when event
778 (let [x (.getX event)
779 y (.getY event)
780 active @active-ref
781 active (if (and active
782 source-event
783 (== (.getX last-event) x)
784 (== (.getY last-event) y))
785 active
786 (ref-set active-ref
787 (under-cursor dispatcher @tree-ref x y)))
788 acted (cond
789 pressed (ref-set picked-ref active)
790 released (let [picked @picked-ref]
791 (ref-set picked-ref nil)
792 picked)
793 :else active)
794 picked (seq @picked-ref)
795 pred #(= (.handle ^DispatcherNode %1) (.handle ^DispatcherNode %2))
796 hovered (if picked
797 (filter #(some (partial pred %) picked) active)
798 active)
799 remove-all (fn [c1 c2]
800 (filter #(not (some (partial pred %) c2)) c1))
801 old-hovered @hovered-ref
802 exited (remove-all old-hovered hovered)
803 entered (remove-all hovered old-hovered)
804 moved (or picked (remove-all hovered entered))]
805 (ref-set hovered-ref hovered)
806 (ref-set last-ref event)
807 [exited entered moved acted event]))))
809 (defn- dispatch-mouse-event
810 [dispatcher source-event button?]
811 (when-let [[exited
812 entered
813 moved
814 acted
815 event] (dosync (process-mouse-event dispatcher source-event))]
816 (when button?
817 (translate-and-dispatch acted true event))
818 (translate-and-dispatch exited false event :mouse-exited)
819 (translate-and-dispatch entered false event :mouse-entered)
820 (when-not button?
821 (translate-and-dispatch moved true source-event))))
823 (defrecord RootEventDispatcher [tree-r ;; register
824 tree ;; dispatch
825 active ;; nodes under cursor
826 hovered ;; mouse entered
827 picked ;; mouse pressed
828 last-motion]
829 EventDispatcher
830 (listen! [dispatcher component]
831 (doto ^Component component
832 (.addMouseListener dispatcher)
833 (.addMouseWheelListener dispatcher)
834 (.addMouseMotionListener dispatcher)))
835 (create-dispatcher [dispatcher handle handlers]
836 (let [node (make-node handle handlers)]
837 (dosync (alter tree-r add-node node))
838 node))
839 (commit [dispatcher]
840 (let [[exited
841 entered
842 _ _
843 event] (dosync
844 ;; TODO: retain contexts that do
845 ;; not intersect graphics
846 ;; clipping area in tree.
847 (ref-set tree @tree-r)
848 (ref-set tree-r {})
849 (process-mouse-event dispatcher nil))]
850 ;; Send mouse entered and exited events if necessary due to
851 ;; updated layout.
852 (translate-and-dispatch exited false event :mouse-exited)
853 (translate-and-dispatch entered false event :mouse-entered)))
854 (handle-picked? [dispatcher handle]
855 (some #(= handle (.handle ^DispatcherNode %)) @picked))
856 (handle-hovered? [dispatcher handle]
857 (some #(= handle (.handle ^DispatcherNode %)) @hovered))
858 MouseListener
859 (mouseEntered [dispatcher event]
860 (dispatch-mouse-event dispatcher event false))
861 (mouseExited [dispatcher event]
862 (dispatch-mouse-event dispatcher event false))
863 (mouseClicked [dispatcher event]
864 (dispatch-mouse-event dispatcher event true))
865 (mousePressed [dispatcher event]
866 (dispatch-mouse-event dispatcher event true))
867 (mouseReleased [dispatcher event]
868 (dispatch-mouse-event dispatcher event true))
869 MouseWheelListener
870 (mouseWheelMoved [dispatcher event]
871 (dispatch-mouse-event dispatcher event true))
872 MouseMotionListener
873 (mouseDragged [dispatcher event]
874 (dispatch-mouse-event dispatcher event false))
875 (mouseMoved [dispatcher event]
876 (dispatch-mouse-event dispatcher event false)))
878 (defn root-event-dispatcher []
879 (->RootEventDispatcher
880 (ref {}) (ref {}) ;; trees
881 (ref nil) (ref nil) (ref nil) ;; node states
882 (ref nil))) ;; last event
884 ;;
885 ;; Scene
886 ;;
888 (defrecord Scene [view
889 event-dispatcher
890 component
891 rendering-hints
892 next-state])
894 ;; Define rendering hints that affect font metrics to make sure that
895 ;; Graphics and Scene FontRenderContexts are consistent.
896 (def ^:private default-rendering-hints
897 {RenderingHints/KEY_TEXT_ANTIALIASING
898 RenderingHints/VALUE_TEXT_ANTIALIAS_DEFAULT,
899 RenderingHints/KEY_FRACTIONALMETRICS
900 RenderingHints/VALUE_FRACTIONALMETRICS_DEFAULT})
902 (defn make-scene
903 ([view]
904 (make-scene view dummy-event-dispatcher nil))
905 ([view event-dispatcher]
906 (make-scene view event-dispatcher nil))
907 ([view event-dispatcher ^Component component]
908 (make-scene view event-dispatcher component nil))
909 ([view event-dispatcher ^Component component hints]
910 (let [hints (merge default-rendering-hints hints)]
911 (->Scene view
912 event-dispatcher
913 component
914 hints
915 (atom nil)))))
917 (defn- get-and-set!
918 "Atomically sets the value of atom to newval and returns the old
919 value."
920 [atom newval]
921 (loop [v @atom]
922 (if (compare-and-set! atom v newval)
923 v
924 (recur @atom))))
926 (defn draw-scene!
927 [scene ^Graphics2D graphics width height]
928 (.addRenderingHints graphics (:rendering-hints scene))
929 (binding [*states* (get-and-set! (:next-state scene) nil)
930 *scene* scene
931 *graphics* graphics
932 *initial-transform* (.getTransform graphics)
933 *inverse-initial-transform* (-> graphics
934 .getTransform
935 .createInverse)
936 *event-dispatcher* (:event-dispatcher scene)
937 *width* width
938 *height* height
939 *clip* (Rectangle2D$Double. 0.0 0.0 width height)
940 *input-clip* nil
941 *time* (System/nanoTime)]
942 (apply-theme)
943 (let [tmp-watcher (Object.)]
944 ;; Keep current context observers until the rendering is
945 ;; complete. Some observers may be invoked twice if they
946 ;; appear in both groups until tmp-watcher is removed.
947 (replace-observers-watcher! scene tmp-watcher)
948 (try
949 (render! (:view scene))
950 (finally
951 (remove-observers! tmp-watcher)
952 (commit (:event-dispatcher scene)))))))
954 (defn- scene-font-context [scene]
955 (let [hints (:rendering-hints scene)
956 ^Component c (:component scene)
957 t (if c (->> c
958 .getFont
959 (.getFontMetrics c)
960 .getFontRenderContext
961 .getTransform))]
962 (FontRenderContext.
963 t
964 (get hints RenderingHints/KEY_TEXT_ANTIALIASING)
965 (get hints RenderingHints/KEY_FRACTIONALMETRICS))))
967 (defn scene-geometry [scene]
968 (binding [*scene* scene
969 *font-context* (scene-font-context scene)]
970 (geometry (:view scene))))
972 (defn set-cursor! [^Cursor cursor]
973 (when-let [^Component component (:component *scene*)]
974 (EventQueue/invokeLater #(.setCursor component cursor))))