Mercurial > hg > indyvon
view src/indyvon/core.clj @ 168:5b80af180da0
Function to apply AffineTransform to a View.
| author | Mikhail Kryshen <mikhail@kryshen.net> |
|---|---|
| date | Sun, 30 Nov 2014 18:45:12 +0300 |
| parents | 4aa8979938ee |
| children | d9bdf08211df |
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 (defrecord TransposedGeometry [geometry]
185 Geometry
186 (width [_]
187 (height geometry))
188 (width [_ h]
189 (height geometry h))
190 (height [_]
191 (width geometry))
192 (height [_ w]
193 (width geometry w))
194 (anchor-x [_ h-align w]
195 (anchor-y geometry
196 (get {:left :top
197 :center :center
198 :right :bottom}
199 h-align)
200 w))
201 (anchor-y [_ v-align h]
202 (anchor-x geometry
203 (get {:top :left
204 :center :center
205 :bottom :right}
206 v-align)
207 h)))
209 ;; (defn ^:private to-integer
210 ;; ^long [align x]
211 ;; (if (integer? x)
212 ;; x
213 ;; (let [x (double x)]
214 ;; (Math/round
215 ;; (case align
216 ;; (:top :left) (Math/floor x)
217 ;; :center x
218 ;; (:bottom :right) (Math/ceil x))))))
220 ;; (defrecord IntegerGeometry [geometry]
221 ;; Geometry
222 ;; (width [_]
223 ;; (to-integer :right (width geometry)))
224 ;; (width [_ h]
225 ;; (to-integer :right (width geometry h)))
226 ;; (height [_]
227 ;; (to-integer :bottom (height geometry)))
228 ;; (height [_ w]
229 ;; (to-integer :bottom (height geometry w)))
230 ;; (anchor-x [_ h-align w]
231 ;; (to-integer h-align (anchor-x geometry h-align w)))
232 ;; (anchor-y [_ v-align h]
233 ;; (to-integer v-align (anchor-y geometry v-align h))))
235 ;; TODO: modifiers
236 (defrecord MouseEvent [id when x y x-on-screen y-on-screen button
237 wheel-rotation transform component])
239 ;; TODO: KeyEvent
241 (defprotocol EventDispatcher
242 (listen! [this component]
243 "Listen for events on the specified AWT Component.")
244 (create-dispatcher [this handle handlers]
245 "Returns new event dispatcher associated with the specified event
246 handlers (an event-id -> handler-fn map). Handle is used to match
247 the contexts between commits.")
248 (commit [this]
249 "Apply the registered handlers for event processing.")
250 (handle-picked? [this handle]
251 "Returns true if the specified handle received the :mouse-pressed
252 event and have not yet received :moused-released.")
253 (handle-hovered? [this handle]
254 "Returns true if the specified handle received the :mouse-entered
255 event and have not yet received :mouse-exited."))
257 (defn- assoc-cons [m key val]
258 (->> (get m key) (cons val) (assoc m key)))
260 ;;
261 ;; Observers
262 ;; The mechanism used by views to request repaints
263 ;;
265 (def ^ConcurrentMap observers
266 (-> (MapMaker.) (.weakKeys) (.makeMap)))
268 (defn- cm-replace!
269 "Wrap ConcurrentMap replace method to treat nil value as absent
270 mapping. Use with maps that does not support nil values."
271 [^ConcurrentMap cmap key old new]
272 (if (nil? old)
273 (nil? (.putIfAbsent cmap key new))
274 (.replace cmap key old new)))
276 (defn- cm-swap!
277 "Atomically swaps the value associated with key in ConcurrentMap
278 to be (apply f current-value args). Returns the new value."
279 [^ConcurrentMap cmap key f & args]
280 (loop []
281 (let [old (.get cmap key)
282 new (apply f old args)]
283 (if (cm-replace! cmap key old new)
284 new
285 (recur)))))
287 (defn add-observer
288 "Add observer fn for the target. Watcher identifies the group of
289 observers and could be used to remove the group. Watcher is weakly
290 referenced, all associated observers will be removed when the
291 wathcer is removed by gc. The observer fn will be called with
292 watcher and target arguments and any additional arguments specified
293 in update call."
294 [watcher target f]
295 (cm-swap! observers watcher assoc-cons target f)
296 nil)
298 (defn remove-observers
299 "Remove group of observers associated with the specified watcher."
300 [watcher]
301 (.remove observers watcher)
302 nil)
304 (defn- replace-observers-watcher
305 [old-watcher new-watcher]
306 (if-let [old (.remove observers old-watcher)]
307 (.put observers new-watcher old))
308 nil)
310 (defn update
311 "Notify observers."
312 [target & args]
313 (doseq [entry observers
314 f (get (val entry) target)]
315 (apply f (key entry) target args)))
317 (defn add-context-observer
318 "Observer registered with this function will be automatically
319 removed after the next repaint is complete."
320 [target f]
321 (add-observer *scene* target f))
323 (defn repaint-on-update
324 "Trigger repaint of the current scene when the target updates."
325 [target]
326 (let [scene *scene*]
327 (if-not (identical? scene target)
328 (add-observer scene target (fn [w _] (update w))))))
330 (defn repaint
331 "Requests repaint of the current scene. If handle and state are
332 specified, the handle will be associated with the state in the
333 *states* map for the next paint iteration."
334 ([]
335 (update *scene*))
336 ([handle state]
337 (let [scene *scene*]
338 (swap! (:next-state scene) assoc handle state)
339 (update scene))))
341 (defmacro binding-fast
342 "Faster alternative to core/binding. Works only with vars that are
343 already thread-bound. Uses set! instead of push-thread-bindings and
344 pop-thread-bindings."
345 [bindings & body]
346 {:pre [(vector? bindings)
347 (even? (count bindings))]}
348 (let [bindings (partition 2 bindings)
349 var-syms (map first bindings)
350 var-vals (map second bindings)
351 syms (map (comp gensym name) var-syms)]
352 `(let [~@(mapcat vector syms var-syms)]
353 (try
354 ~@(map #(list `set! %1 %2) var-syms var-vals)
355 ~@body
356 (finally
357 ~@(map #(list `set! %1 %2) var-syms syms))))))
359 ;;
360 ;; Rendering
361 ;;
363 (defn ^FontRenderContext font-context
364 "Returns FontRenderContext for the current view context."
365 []
366 (if (bound? (var *graphics*))
367 (.getFontRenderContext *graphics*)
368 *font-context*))
370 (defn ^AffineTransform relative-transform
371 "Returns AffineTransform: view context -> AWT component."
372 []
373 (let [tr (.getTransform *graphics*)]
374 (.preConcatenate tr *inverse-initial-transform*)
375 tr))
377 (defn ^AffineTransform inverse-relative-transform
378 "Returns AffineTransform: AWT component -> view context."
379 []
380 (let [tr (.getTransform *graphics*)]
381 (.invert tr) ; absolute -> view
382 (.concatenate tr *initial-transform*) ; component -> absolute
383 tr))
385 (defn transform-point [^AffineTransform tr ^double x ^double y]
386 (let [p (Point2D$Double. x y)]
387 (.transform tr p p)
388 [(.x p) (.y p)]))
390 (defn inverse-transform-point [^AffineTransform tr ^double x ^double y]
391 (let [p (Point2D$Double. x y)]
392 (.inverseTransform tr p p)
393 [(.x p) (.y p)]))
395 ;; (defn- clip
396 ;; "Intersect clipping area with the specified shape or bounds.
397 ;; Returns new clip (Shape or nil if empty)."
398 ;; ([x y w h]
399 ;; (clip (Rectangle2D$Double. x y w h)))
400 ;; ([shape]
401 ;; (let [a1 (Area. shape)
402 ;; a2 (if (instance? Area *clip*) *clip* (Area. *clip*))]
403 ;; (.transform a1 (relative-transform))
404 ;; (.intersect a1 a2)
405 ;; (if (.isEmpty a1)
406 ;; nil
407 ;; a1))))
409 ;; Use faster clipping calculation provided by Graphics2D.
410 (defn- clip
411 "Intersect clipping area with the specified Shape in current
412 transform coordinates. Returns new clip in the AWT component
413 coordinates (Shape or nil if empty)."
414 [^Shape shape]
415 (let [^Graphics2D clip-g (.create *graphics*)]
416 (try
417 (doto clip-g
418 (.setClip shape)
419 (.setTransform *initial-transform*)
420 (.clip *clip*))
421 (if (.isEmpty (.getClipBounds clip-g))
422 nil
423 (.getClip clip-g))
424 (finally
425 (.dispose clip-g)))))
427 (defn- theme-get*
428 ([theme key]
429 (theme-get* theme key nil))
430 ([theme key not-found]
431 (if-let [e (find theme key)]
432 (loop [k (val e)]
433 (if-let [e1 (and (keyword? k)
434 (find theme k))]
435 (recur (val e1))
436 k))
437 not-found)))
439 (defn theme-get
440 ([key]
441 (theme-get* *theme* key))
442 ([key not-found]
443 (theme-get* *theme* key not-found)))
445 (defn ^Graphics2D apply-theme
446 "Set graphics' color and font to match theme.
447 Modifies and returns the first argument."
448 ([]
449 (apply-theme *graphics* *theme*))
450 ([^Graphics2D graphics theme]
451 (doto graphics
452 (.setColor (theme-get :fore-color))
453 (.setBackground (theme-get :back-color))
454 (.setFont (theme-get :font)))))
456 (defn- ^Graphics2D create-graphics
457 ([]
458 (apply-theme (.create *graphics*) *theme*))
459 ([^long x ^long y ^long w ^long h]
460 (apply-theme (.create *graphics* x y w h) *theme*)))
462 (defn- with-bounds-noclip*
463 [x y w h f & args]
464 (let [graphics (create-graphics)]
465 (try
466 (.translate graphics (double x) (double y))
467 (binding-fast [*width* w
468 *height* h
469 *input-clip* (Rectangle2D$Double. 0.0 0.0 w h)
470 *graphics* graphics]
471 (apply f args))
472 (finally
473 (.dispose graphics)))))
475 (defn with-bounds*
476 [x y w h f & args]
477 (let [x (double x)
478 y (double y)
479 bounds (Rectangle2D$Double. x y w h)]
480 (when-let [clip (clip bounds)]
481 (let [^Graphics2D graphics (create-graphics)]
482 (try
483 (.clip graphics bounds)
484 (.translate graphics x y)
485 (binding-fast [*width* w
486 *height* h
487 *clip* clip
488 *input-clip* nil
489 *graphics* graphics]
490 (apply f args))
491 (finally
492 (.dispose graphics)))))))
494 (defmacro with-bounds
495 [x y w h & body]
496 `(with-bounds* ~x ~y ~w ~h (fn [] ~@body)))
498 (defmacro with-theme
499 [theme & body]
500 `(binding [*theme* (merge *theme* ~theme)]
501 ~@body))
503 (defn with-theme* [theme f & args]
504 (with-theme theme
505 (apply f args)))
507 (defmacro with-color [color-or-key & body]
508 `(let [color# ~color-or-key
509 color# (theme-get color# color#)
510 g# *graphics*
511 old-color# (.getColor g#)]
512 (try
513 (.setColor g# color#)
514 ~@body
515 (finally
516 (.setColor g# old-color#)))))
518 (defmacro with-font [font-or-key & body]
519 `(let [font# ~font-or-key
520 font# (theme-get font# font#)
521 g# *graphics*
522 old-font# (.getFont g#)]
523 (try
524 (.setFont g# font#)
525 ~@body
526 (finally
527 (.setColor g# old-font#)))))
529 (defmacro with-stroke [stroke & body]
530 `(let [g# *graphics*
531 old-stroke# (.getStroke g#)]
532 (try
533 (.setStroke g# ~stroke)
534 ~@body
535 (finally
536 (.setStroke g# old-stroke#)))))
538 (defmacro with-hints
539 [hints & body]
540 `(let [h# ~hints
541 g# *graphics*
542 old# (.getRenderingHints g#)]
543 (try
544 (.addRenderingHints g# h#)
545 ~@body
546 (finally
547 (.setRenderingHints g# old#)))))
549 (defn with-hints* [hints f & args]
550 (with-hints hints
551 (apply f args)))
553 ;; TODO: Composable transformations:
554 ;; (with-transform (-> (scale 0.3 0.5)
555 ;; (rotate-deg 30)
556 ;; (translate 5 10))
557 ;; ...)
559 (defmacro with-transform [transform & body]
560 `(let [g# *graphics*
561 old-t# (.getTransform g#)]
562 (try
563 (.transform g# ~transform)
564 ~@body
565 (finally
566 (.setTransform g# old-t#)))))
568 (defn with-transform* [transform f & args]
569 (with-transform transform
570 (apply f args)))
572 (defmacro with-rotate [theta ax ay & body]
573 `(let [transform# (AffineTransform/getRotateInstance ~theta ~ax ~ay)]
574 (with-transform transform# ~@body)))
576 (defmacro with-translate [x y & body]
577 `(let [x# ~x
578 y# ~y
579 g# *graphics*]
580 (try
581 (.translate g# x# y#)
582 ~@body
583 (finally
584 (.translate g# (- x#) (- y#))))))
586 (defn draw!
587 "Draws the View."
588 ([view]
589 (let [graphics (create-graphics)]
590 (try
591 (binding-fast [*graphics* graphics]
592 (render! view))
593 (finally
594 (.dispose graphics)))))
595 ([view x y]
596 (draw! view x y true))
597 ([view x y clip?]
598 (let [geom (geometry view)]
599 (draw! view x y (width geom) (height geom) clip?)))
600 ([view x y width height]
601 (draw! view x y width height true))
602 ([view x y width height clip?]
603 (if clip?
604 (with-bounds* x y width height render! view)
605 (with-bounds-noclip* x y width height render! view))))
607 (defn draw-aligned!
608 "Draws the View. Location is relative to the view's anchor point
609 for the specified alignment."
610 ([view h-align v-align x y]
611 (draw-aligned! view (geometry view) h-align v-align x y))
612 ([view geom h-align v-align x y]
613 (draw-aligned! view geom h-align v-align x y (width geom) (height geom)))
614 ([view h-align v-align x y w h]
615 (draw-aligned! view (geometry view) h-align v-align x y w h))
616 ([view geom h-align v-align x y w h]
617 (draw! view
618 (- x (anchor-x geom h-align w))
619 (- y (anchor-y geom v-align h))
620 w h)))
622 ;;
623 ;; Event handling.
624 ;;
626 (defn with-handlers*
627 [handle handlers f & args]
628 (binding-fast [*event-dispatcher* (create-dispatcher
629 *event-dispatcher* handle handlers)]
630 (apply f args)))
632 (defmacro with-handlers
633 "specs => (:event-id name & handler-body)*
635 Execute form with the specified event handlers."
636 [handle form & specs]
637 `(with-handlers* ~handle
638 ~(reduce (fn [m spec]
639 (assoc m (first spec)
640 `(fn [~(second spec)]
641 ~@(nnext spec)))) {}
642 specs)
643 (fn [] ~form)))
645 (defn picked? [handle]
646 (handle-picked? *event-dispatcher* handle))
648 (defn hovered? [handle]
649 (handle-hovered? *event-dispatcher* handle))
651 ;;
652 ;; EventDispatcher implementation
653 ;;
655 (def awt-events
656 {java.awt.event.MouseEvent/MOUSE_CLICKED :mouse-clicked
657 java.awt.event.MouseEvent/MOUSE_DRAGGED :mouse-dragged
658 java.awt.event.MouseEvent/MOUSE_ENTERED :mouse-entered
659 java.awt.event.MouseEvent/MOUSE_EXITED :mouse-exited
660 java.awt.event.MouseEvent/MOUSE_MOVED :mouse-moved
661 java.awt.event.MouseEvent/MOUSE_PRESSED :mouse-pressed
662 java.awt.event.MouseEvent/MOUSE_RELEASED :mouse-released
663 java.awt.event.MouseEvent/MOUSE_WHEEL :mouse-wheel})
665 (def dummy-event-dispatcher
666 (reify EventDispatcher
667 (listen! [_ _])
668 (create-dispatcher [this _ _] this)
669 (commit [_])
670 (handle-picked? [_ _])
671 (handle-hovered? [_ _])))
673 ;; Not using defrecord to avoid unacceptable overhead of recursive
674 ;; hash code calculation.
675 (deftype DispatcherNode [handle handlers parent
676 ^Shape clip ^AffineTransform transform
677 bindings]
678 EventDispatcher
679 (listen! [this component]
680 (listen! parent component))
681 (create-dispatcher [this handle handlers]
682 (create-dispatcher parent handle handlers))
683 (commit [this]
684 (commit parent))
685 (handle-picked? [this handle]
686 (handle-picked? parent handle))
687 (handle-hovered? [this handle]
688 (handle-hovered? parent handle)))
690 (defn- make-node [handle handlers]
691 (let [clip (if *input-clip*
692 (clip *input-clip*)
693 *clip*)
694 bindings (-> (get-thread-bindings)
695 (dissoc (var *graphics*))
696 (assoc (var *font-context*) (font-context)))]
697 (DispatcherNode. handle handlers *event-dispatcher* clip
698 (relative-transform)
699 bindings)))
701 (defn- add-node [tree ^DispatcherNode node]
702 (assoc-cons tree (.parent node) node))
704 (defn- nodes [tree]
705 (apply concat (vals tree)))
707 (defn- under-cursor
708 "Returns a vector of child nodes under cursor."
709 [node tree ^long x ^long y]
710 (some (fn [^DispatcherNode n]
711 (if (and (.clip n) (.contains ^Shape (.clip n) x y))
712 (conj (vec (under-cursor n tree x y)) n)))
713 (get tree node)))
715 (defn- translate-mouse-event [^java.awt.event.MouseEvent event
716 ^AffineTransform tr id]
717 (let [[x y] (inverse-transform-point tr (.getX event) (.getY event))
718 rotation (if (instance? MouseWheelEvent event)
719 (.getWheelRotation ^MouseWheelEvent event)
720 nil)]
721 (->MouseEvent id (.getWhen event) x y
722 (.getXOnScreen event) (.getYOnScreen event)
723 (.getButton event)
724 rotation
725 tr
726 (.getComponent event))))
728 (defn- translate-and-dispatch
729 ([nodes first-only ^java.awt.event.MouseEvent event]
730 (translate-and-dispatch nodes first-only
731 event (awt-events (.getID event))))
732 ([nodes first-only event id]
733 (if-let [^DispatcherNode node (first nodes)]
734 (let [handlers (.handlers node)
735 handler (get handlers id)]
736 (if handler
737 (do
738 (with-bindings* (.bindings node)
739 handler
740 (translate-mouse-event event (.transform node) id))
741 (when-not first-only
742 (recur (rest nodes) false event id)))
743 (when-not (and (= id :mouse-dragged)
744 (or (contains? handlers :mouse-pressed)
745 (contains? handlers :mouse-released)))
746 (recur (rest nodes) first-only event id)))))))
748 (defn- process-mouse-event
749 [dispatcher ^java.awt.event.MouseEvent source-event]
750 (let [{active-ref :active
751 hovered-ref :hovered
752 picked-ref :picked
753 last-ref :last-motion
754 tree-ref :tree} dispatcher
755 pressed (and source-event
756 (== (.getID source-event)
757 java.awt.event.MouseEvent/MOUSE_PRESSED))
758 released (and source-event
759 (== (.getID source-event)
760 java.awt.event.MouseEvent/MOUSE_RELEASED))
761 ^java.awt.event.MouseEvent last-event @last-ref
762 ^java.awt.event.MouseEvent event (or source-event last-event)]
763 (when event
764 (let [x (.getX event)
765 y (.getY event)
766 active @active-ref
767 active (if (and active
768 source-event
769 (== (.getX last-event) x)
770 (== (.getY last-event) y))
771 active
772 (ref-set active-ref
773 (under-cursor dispatcher @tree-ref x y)))
774 acted (cond
775 pressed (ref-set picked-ref active)
776 released (let [picked @picked-ref]
777 (ref-set picked-ref nil)
778 picked)
779 :else active)
780 picked (seq @picked-ref)
781 pred #(= (.handle ^DispatcherNode %1) (.handle ^DispatcherNode %2))
782 hovered (if picked
783 (filter #(some (partial pred %) picked) active)
784 active)
785 remove-all (fn [c1 c2]
786 (filter #(not (some (partial pred %) c2)) c1))
787 old-hovered @hovered-ref
788 exited (remove-all old-hovered hovered)
789 entered (remove-all hovered old-hovered)
790 moved (or picked (remove-all hovered entered))]
791 (ref-set hovered-ref hovered)
792 (ref-set last-ref event)
793 [exited entered moved acted event]))))
795 (defn- dispatch-mouse-event
796 [dispatcher source-event button?]
797 (when-let [[exited
798 entered
799 moved
800 acted
801 event] (dosync (process-mouse-event dispatcher source-event))]
802 (when button?
803 (translate-and-dispatch acted true event))
804 (translate-and-dispatch exited false event :mouse-exited)
805 (translate-and-dispatch entered false event :mouse-entered)
806 (when-not button?
807 (translate-and-dispatch moved true source-event))))
809 (defrecord RootEventDispatcher [tree-r ;; register
810 tree ;; dispatch
811 active ;; nodes under cursor
812 hovered ;; mouse entered
813 picked ;; mouse pressed
814 last-motion]
815 EventDispatcher
816 (listen! [dispatcher component]
817 (doto ^Component component
818 (.addMouseListener dispatcher)
819 (.addMouseWheelListener dispatcher)
820 (.addMouseMotionListener dispatcher)))
821 (create-dispatcher [dispatcher handle handlers]
822 (let [node (make-node handle handlers)]
823 (dosync (alter tree-r add-node node))
824 node))
825 (commit [dispatcher]
826 (let [[exited
827 entered
828 _ _
829 event] (dosync
830 ;; TODO: retain contexts that do
831 ;; not intersect graphics
832 ;; clipping area in tree.
833 (ref-set tree @tree-r)
834 (ref-set tree-r {})
835 (process-mouse-event dispatcher nil))]
836 ;; Send mouse entered and exited events if necessary due to
837 ;; updated layout.
838 (translate-and-dispatch exited false event :mouse-exited)
839 (translate-and-dispatch entered false event :mouse-entered)))
840 (handle-picked? [dispatcher handle]
841 (some #(= handle (.handle ^DispatcherNode %)) @picked))
842 (handle-hovered? [dispatcher handle]
843 (some #(= handle (.handle ^DispatcherNode %)) @hovered))
844 MouseListener
845 (mouseEntered [dispatcher event]
846 (dispatch-mouse-event dispatcher event false))
847 (mouseExited [dispatcher event]
848 (dispatch-mouse-event dispatcher event false))
849 (mouseClicked [dispatcher event]
850 (dispatch-mouse-event dispatcher event true))
851 (mousePressed [dispatcher event]
852 (dispatch-mouse-event dispatcher event true))
853 (mouseReleased [dispatcher event]
854 (dispatch-mouse-event dispatcher event true))
855 MouseWheelListener
856 (mouseWheelMoved [dispatcher event]
857 (dispatch-mouse-event dispatcher event true))
858 MouseMotionListener
859 (mouseDragged [dispatcher event]
860 (dispatch-mouse-event dispatcher event false))
861 (mouseMoved [dispatcher event]
862 (dispatch-mouse-event dispatcher event false)))
864 (defn root-event-dispatcher []
865 (->RootEventDispatcher
866 (ref {}) (ref {}) ;; trees
867 (ref nil) (ref nil) (ref nil) ;; node states
868 (ref nil))) ;; last event
870 ;;
871 ;; Scene
872 ;;
874 (defrecord Scene [view
875 event-dispatcher
876 component
877 rendering-hints
878 next-state])
880 ;; Define rendering hints that affect font metrics to make sure that
881 ;; Graphics and Scene FontRenderContexts are consistent.
882 (def ^:private default-rendering-hints
883 {RenderingHints/KEY_TEXT_ANTIALIASING
884 RenderingHints/VALUE_TEXT_ANTIALIAS_DEFAULT,
885 RenderingHints/KEY_FRACTIONALMETRICS
886 RenderingHints/VALUE_FRACTIONALMETRICS_DEFAULT})
888 (defn make-scene
889 ([view]
890 (make-scene view dummy-event-dispatcher nil))
891 ([view event-dispatcher]
892 (make-scene view event-dispatcher nil))
893 ([view event-dispatcher ^Component component]
894 (make-scene view event-dispatcher component nil))
895 ([view event-dispatcher ^Component component hints]
896 (let [hints (merge default-rendering-hints hints)]
897 (->Scene view
898 event-dispatcher
899 component
900 hints
901 (atom nil)))))
903 (defn- get-and-set!
904 "Atomically sets the value of atom to newval and returns the old
905 value."
906 [atom newval]
907 (loop [v @atom]
908 (if (compare-and-set! atom v newval)
909 v
910 (recur @atom))))
912 (defn draw-scene!
913 [scene ^Graphics2D graphics width height]
914 (.addRenderingHints graphics (:rendering-hints scene))
915 (binding [*states* (get-and-set! (:next-state scene) nil)
916 *scene* scene
917 *graphics* graphics
918 *initial-transform* (.getTransform graphics)
919 *inverse-initial-transform* (-> graphics
920 .getTransform
921 .createInverse)
922 *event-dispatcher* (:event-dispatcher scene)
923 *width* width
924 *height* height
925 *clip* (Rectangle2D$Double. 0.0 0.0 width height)
926 *input-clip* nil
927 *time* (System/nanoTime)]
928 (apply-theme)
929 (let [tmp-watcher (Object.)]
930 ;; Keep current context observers until the rendering is
931 ;; complete. Some observers may be invoked twice if they
932 ;; appear in both groups until tmp-watcher is removed.
933 (replace-observers-watcher scene tmp-watcher)
934 (try
935 (render! (:view scene))
936 (finally
937 (remove-observers tmp-watcher)
938 (commit (:event-dispatcher scene)))))))
940 (defn- scene-font-context [scene]
941 (let [hints (:rendering-hints scene)
942 ^Component c (:component scene)
943 t (if c (->> c
944 .getFont
945 (.getFontMetrics c)
946 .getFontRenderContext
947 .getTransform))]
948 (FontRenderContext.
949 t
950 (get hints RenderingHints/KEY_TEXT_ANTIALIASING)
951 (get hints RenderingHints/KEY_FRACTIONALMETRICS))))
953 (defn scene-geometry [scene]
954 (binding [*scene* scene
955 *font-context* (scene-font-context scene)]
956 (geometry (:view scene))))
958 (defn set-cursor! [^Cursor cursor]
959 (when-let [^Component component (:component *scene*)]
960 (EventQueue/invokeLater #(.setCursor component cursor))))