Mercurial > hg > indyvon
view src/indyvon/core.clj @ 172:0394465ce1e2
Correctly specify docstrings for dynamic vars without root bindings.
| author | Mikhail Kryshen <mikhail@kryshen.net> |
|---|---|
| date | Wed, 10 Dec 2014 18:59:20 +0300 |
| parents | d9bdf08211df |
| children | eb1bedf22731 |
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
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 ^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 target. 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 target arguments and any additional arguments specified
306 in update call."
307 [watcher target f]
308 (cm-swap! observers watcher assoc-cons target 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 update
324 "Notify observers."
325 [target & args]
326 (doseq [entry observers
327 f (get (val entry) target)]
328 (apply f (key entry) target args)))
330 (defn add-context-observer
331 "Observer registered with this function will be automatically
332 removed after the next repaint is complete."
333 [target f]
334 (add-observer *scene* target f))
336 (defn repaint-on-update
337 "Trigger repaint of the current scene when the target updates."
338 [target]
339 (let [scene *scene*]
340 (if-not (identical? scene target)
341 (add-observer scene target (fn [w _] (update w))))))
343 (defn repaint
344 "Requests repaint of the current scene. If handle and state are
345 specified, the handle will be associated with the state in the
346 *states* map for the next paint iteration."
347 ([]
348 (update *scene*))
349 ([handle state]
350 (let [scene *scene*]
351 (swap! (:next-state scene) assoc handle state)
352 (update scene))))
354 (defmacro binding-fast
355 "Faster alternative to core/binding. Works only with vars that are
356 already thread-bound. Uses set! instead of push-thread-bindings and
357 pop-thread-bindings."
358 [bindings & body]
359 {:pre [(vector? bindings)
360 (even? (count bindings))]}
361 (let [bindings (partition 2 bindings)
362 var-syms (map first bindings)
363 var-vals (map second bindings)
364 syms (map (comp gensym name) var-syms)]
365 `(let [~@(mapcat vector syms var-syms)]
366 (try
367 ~@(map #(list `set! %1 %2) var-syms var-vals)
368 ~@body
369 (finally
370 ~@(map #(list `set! %1 %2) var-syms syms))))))
372 ;;
373 ;; Rendering
374 ;;
376 (defn ^FontRenderContext font-context
377 "Returns FontRenderContext for the current view context."
378 []
379 (if (bound? (var *graphics*))
380 (.getFontRenderContext *graphics*)
381 *font-context*))
383 (defn ^AffineTransform relative-transform
384 "Returns AffineTransform: view context -> AWT component."
385 []
386 (let [tr (.getTransform *graphics*)]
387 (.preConcatenate tr *inverse-initial-transform*)
388 tr))
390 (defn ^AffineTransform inverse-relative-transform
391 "Returns AffineTransform: AWT component -> view context."
392 []
393 (let [tr (.getTransform *graphics*)]
394 (.invert tr) ; absolute -> view
395 (.concatenate tr *initial-transform*) ; component -> absolute
396 tr))
398 (defn transform-point [^AffineTransform tr ^double x ^double y]
399 (let [p (Point2D$Double. x y)]
400 (.transform tr p p)
401 [(.x p) (.y p)]))
403 (defn inverse-transform-point [^AffineTransform tr ^double x ^double y]
404 (let [p (Point2D$Double. x y)]
405 (.inverseTransform tr p p)
406 [(.x p) (.y p)]))
408 ;; (defn- clip
409 ;; "Intersect clipping area with the specified shape or bounds.
410 ;; Returns new clip (Shape or nil if empty)."
411 ;; ([x y w h]
412 ;; (clip (Rectangle2D$Double. x y w h)))
413 ;; ([shape]
414 ;; (let [a1 (Area. shape)
415 ;; a2 (if (instance? Area *clip*) *clip* (Area. *clip*))]
416 ;; (.transform a1 (relative-transform))
417 ;; (.intersect a1 a2)
418 ;; (if (.isEmpty a1)
419 ;; nil
420 ;; a1))))
422 ;; Use faster clipping calculation provided by Graphics2D.
423 (defn- clip
424 "Intersect clipping area with the specified Shape in current
425 transform coordinates. Returns new clip in the AWT component
426 coordinates (Shape or nil if empty)."
427 [^Shape shape]
428 (let [^Graphics2D clip-g (.create *graphics*)]
429 (try
430 (doto clip-g
431 (.setClip shape)
432 (.setTransform *initial-transform*)
433 (.clip *clip*))
434 (if (.isEmpty (.getClipBounds clip-g))
435 nil
436 (.getClip clip-g))
437 (finally
438 (.dispose clip-g)))))
440 (defn- theme-get*
441 ([theme key]
442 (theme-get* theme key nil))
443 ([theme key not-found]
444 (if-let [e (find theme key)]
445 (loop [k (val e)]
446 (if-let [e1 (and (keyword? k)
447 (find theme k))]
448 (recur (val e1))
449 k))
450 not-found)))
452 (defn theme-get
453 ([key]
454 (theme-get* *theme* key))
455 ([key not-found]
456 (theme-get* *theme* key not-found)))
458 (defn ^Graphics2D apply-theme
459 "Set graphics' color and font to match theme.
460 Modifies and returns the first argument."
461 ([]
462 (apply-theme *graphics* *theme*))
463 ([^Graphics2D graphics theme]
464 (doto graphics
465 (.setColor (theme-get :fore-color))
466 (.setBackground (theme-get :back-color))
467 (.setFont (theme-get :font)))))
469 (defn- ^Graphics2D create-graphics
470 ([]
471 (apply-theme (.create *graphics*) *theme*))
472 ([^long x ^long y ^long w ^long h]
473 (apply-theme (.create *graphics* x y w h) *theme*)))
475 (defn- with-bounds-noclip*
476 [x y w h f & args]
477 (let [graphics (create-graphics)]
478 (try
479 (.translate graphics (double x) (double y))
480 (binding-fast [*width* w
481 *height* h
482 *input-clip* (Rectangle2D$Double. 0.0 0.0 w h)
483 *graphics* graphics]
484 (apply f args))
485 (finally
486 (.dispose graphics)))))
488 (defn with-bounds*
489 [x y w h f & args]
490 (let [x (double x)
491 y (double y)
492 bounds (Rectangle2D$Double. x y w h)]
493 (when-let [clip (clip bounds)]
494 (let [^Graphics2D graphics (create-graphics)]
495 (try
496 (.clip graphics bounds)
497 (.translate graphics x y)
498 (binding-fast [*width* w
499 *height* h
500 *clip* clip
501 *input-clip* nil
502 *graphics* graphics]
503 (apply f args))
504 (finally
505 (.dispose graphics)))))))
507 (defmacro with-bounds
508 [x y w h & body]
509 `(with-bounds* ~x ~y ~w ~h (fn [] ~@body)))
511 (defmacro with-theme
512 [theme & body]
513 `(binding [*theme* (merge *theme* ~theme)]
514 ~@body))
516 (defn with-theme* [theme f & args]
517 (with-theme theme
518 (apply f args)))
520 (defmacro with-color [color-or-key & body]
521 `(let [color# ~color-or-key
522 color# (theme-get color# color#)
523 g# *graphics*
524 old-color# (.getColor g#)]
525 (try
526 (.setColor g# color#)
527 ~@body
528 (finally
529 (.setColor g# old-color#)))))
531 (defmacro with-font [font-or-key & body]
532 `(let [font# ~font-or-key
533 font# (theme-get font# font#)
534 g# *graphics*
535 old-font# (.getFont g#)]
536 (try
537 (.setFont g# font#)
538 ~@body
539 (finally
540 (.setColor g# old-font#)))))
542 (defmacro with-stroke [stroke & body]
543 `(let [g# *graphics*
544 old-stroke# (.getStroke g#)]
545 (try
546 (.setStroke g# ~stroke)
547 ~@body
548 (finally
549 (.setStroke g# old-stroke#)))))
551 (defmacro with-hints
552 [hints & body]
553 `(let [h# ~hints
554 g# *graphics*
555 old# (.getRenderingHints g#)]
556 (try
557 (.addRenderingHints g# h#)
558 ~@body
559 (finally
560 (.setRenderingHints g# old#)))))
562 (defn with-hints* [hints f & args]
563 (with-hints hints
564 (apply f args)))
566 ;; TODO: Composable transformations:
567 ;; (with-transform (-> (scale 0.3 0.5)
568 ;; (rotate-deg 30)
569 ;; (translate 5 10))
570 ;; ...)
572 (defmacro with-transform [transform & body]
573 `(let [g# *graphics*
574 old-t# (.getTransform g#)]
575 (try
576 (.transform g# ~transform)
577 ~@body
578 (finally
579 (.setTransform g# old-t#)))))
581 (defn with-transform* [transform f & args]
582 (with-transform transform
583 (apply f args)))
585 (defmacro with-rotate [theta ax ay & body]
586 `(let [transform# (AffineTransform/getRotateInstance ~theta ~ax ~ay)]
587 (with-transform transform# ~@body)))
589 (defmacro with-translate [x y & body]
590 `(let [x# ~x
591 y# ~y
592 g# *graphics*]
593 (try
594 (.translate g# x# y#)
595 ~@body
596 (finally
597 (.translate g# (- x#) (- y#))))))
599 (defn draw!
600 "Draws the View."
601 ([view]
602 (let [graphics (create-graphics)]
603 (try
604 (binding-fast [*graphics* graphics]
605 (render! view))
606 (finally
607 (.dispose graphics)))))
608 ([view x y]
609 (draw! view x y true))
610 ([view x y clip?]
611 (let [geom (geometry view)]
612 (draw! view x y (width geom) (height geom) clip?)))
613 ([view x y width height]
614 (draw! view x y width height true))
615 ([view x y width height clip?]
616 (if clip?
617 (with-bounds* x y width height render! view)
618 (with-bounds-noclip* x y width height render! view))))
620 (defn draw-aligned!
621 "Draws the View. Location is relative to the view's anchor point
622 for the specified alignment."
623 ([view h-align v-align x y]
624 (draw-aligned! view (geometry view) h-align v-align x y))
625 ([view geom h-align v-align x y]
626 (draw-aligned! view geom h-align v-align x y (width geom) (height geom)))
627 ([view h-align v-align x y w h]
628 (draw-aligned! view (geometry view) h-align v-align x y w h))
629 ([view geom h-align v-align x y w h]
630 (draw! view
631 (- x (anchor-x geom h-align w))
632 (- y (anchor-y geom v-align h))
633 w h)))
635 ;;
636 ;; Event handling.
637 ;;
639 (defn with-handlers*
640 [handle handlers f & args]
641 (binding-fast [*event-dispatcher* (create-dispatcher
642 *event-dispatcher* handle handlers)]
643 (apply f args)))
645 (defmacro with-handlers
646 "specs => (:event-id name & handler-body)*
648 Execute form with the specified event handlers."
649 [handle form & specs]
650 `(with-handlers* ~handle
651 ~(reduce (fn [m spec]
652 (assoc m (first spec)
653 `(fn [~(second spec)]
654 ~@(nnext spec)))) {}
655 specs)
656 (fn [] ~form)))
658 (defn picked? [handle]
659 (handle-picked? *event-dispatcher* handle))
661 (defn hovered? [handle]
662 (handle-hovered? *event-dispatcher* handle))
664 ;;
665 ;; EventDispatcher implementation
666 ;;
668 (def awt-events
669 {java.awt.event.MouseEvent/MOUSE_CLICKED :mouse-clicked
670 java.awt.event.MouseEvent/MOUSE_DRAGGED :mouse-dragged
671 java.awt.event.MouseEvent/MOUSE_ENTERED :mouse-entered
672 java.awt.event.MouseEvent/MOUSE_EXITED :mouse-exited
673 java.awt.event.MouseEvent/MOUSE_MOVED :mouse-moved
674 java.awt.event.MouseEvent/MOUSE_PRESSED :mouse-pressed
675 java.awt.event.MouseEvent/MOUSE_RELEASED :mouse-released
676 java.awt.event.MouseEvent/MOUSE_WHEEL :mouse-wheel})
678 (def dummy-event-dispatcher
679 (reify EventDispatcher
680 (listen! [_ _])
681 (create-dispatcher [this _ _] this)
682 (commit [_])
683 (handle-picked? [_ _])
684 (handle-hovered? [_ _])))
686 ;; Not using defrecord to avoid unacceptable overhead of recursive
687 ;; hash code calculation.
688 (deftype DispatcherNode [handle handlers parent
689 ^Shape clip ^AffineTransform transform
690 bindings]
691 EventDispatcher
692 (listen! [this component]
693 (listen! parent component))
694 (create-dispatcher [this handle handlers]
695 (create-dispatcher parent handle handlers))
696 (commit [this]
697 (commit parent))
698 (handle-picked? [this handle]
699 (handle-picked? parent handle))
700 (handle-hovered? [this handle]
701 (handle-hovered? parent handle)))
703 (defn- make-node [handle handlers]
704 (let [clip (if *input-clip*
705 (clip *input-clip*)
706 *clip*)
707 bindings (-> (get-thread-bindings)
708 (dissoc (var *graphics*))
709 (assoc (var *font-context*) (font-context)))]
710 (DispatcherNode. handle handlers *event-dispatcher* clip
711 (relative-transform)
712 bindings)))
714 (defn- add-node [tree ^DispatcherNode node]
715 (assoc-cons tree (.parent node) node))
717 (defn- nodes [tree]
718 (apply concat (vals tree)))
720 (defn- under-cursor
721 "Returns a vector of child nodes under cursor."
722 [node tree ^long x ^long y]
723 (some (fn [^DispatcherNode n]
724 (if (and (.clip n) (.contains ^Shape (.clip n) x y))
725 (conj (vec (under-cursor n tree x y)) n)))
726 (get tree node)))
728 (defn- translate-mouse-event [^java.awt.event.MouseEvent event
729 ^AffineTransform tr id]
730 (let [[x y] (inverse-transform-point tr (.getX event) (.getY event))
731 rotation (if (instance? MouseWheelEvent event)
732 (.getWheelRotation ^MouseWheelEvent event)
733 nil)]
734 (->MouseEvent id (.getWhen event) x y
735 (.getXOnScreen event) (.getYOnScreen event)
736 (.getButton event)
737 rotation
738 tr
739 (.getComponent event))))
741 (defn- translate-and-dispatch
742 ([nodes first-only ^java.awt.event.MouseEvent event]
743 (translate-and-dispatch nodes first-only
744 event (awt-events (.getID event))))
745 ([nodes first-only event id]
746 (if-let [^DispatcherNode node (first nodes)]
747 (let [handlers (.handlers node)
748 handler (get handlers id)]
749 (if handler
750 (do
751 (with-bindings* (.bindings node)
752 handler
753 (translate-mouse-event event (.transform node) id))
754 (when-not first-only
755 (recur (rest nodes) false event id)))
756 (when-not (and (= id :mouse-dragged)
757 (or (contains? handlers :mouse-pressed)
758 (contains? handlers :mouse-released)))
759 (recur (rest nodes) first-only event id)))))))
761 (defn- process-mouse-event
762 [dispatcher ^java.awt.event.MouseEvent source-event]
763 (let [{active-ref :active
764 hovered-ref :hovered
765 picked-ref :picked
766 last-ref :last-motion
767 tree-ref :tree} dispatcher
768 pressed (and source-event
769 (== (.getID source-event)
770 java.awt.event.MouseEvent/MOUSE_PRESSED))
771 released (and source-event
772 (== (.getID source-event)
773 java.awt.event.MouseEvent/MOUSE_RELEASED))
774 ^java.awt.event.MouseEvent last-event @last-ref
775 ^java.awt.event.MouseEvent event (or source-event last-event)]
776 (when event
777 (let [x (.getX event)
778 y (.getY event)
779 active @active-ref
780 active (if (and active
781 source-event
782 (== (.getX last-event) x)
783 (== (.getY last-event) y))
784 active
785 (ref-set active-ref
786 (under-cursor dispatcher @tree-ref x y)))
787 acted (cond
788 pressed (ref-set picked-ref active)
789 released (let [picked @picked-ref]
790 (ref-set picked-ref nil)
791 picked)
792 :else active)
793 picked (seq @picked-ref)
794 pred #(= (.handle ^DispatcherNode %1) (.handle ^DispatcherNode %2))
795 hovered (if picked
796 (filter #(some (partial pred %) picked) active)
797 active)
798 remove-all (fn [c1 c2]
799 (filter #(not (some (partial pred %) c2)) c1))
800 old-hovered @hovered-ref
801 exited (remove-all old-hovered hovered)
802 entered (remove-all hovered old-hovered)
803 moved (or picked (remove-all hovered entered))]
804 (ref-set hovered-ref hovered)
805 (ref-set last-ref event)
806 [exited entered moved acted event]))))
808 (defn- dispatch-mouse-event
809 [dispatcher source-event button?]
810 (when-let [[exited
811 entered
812 moved
813 acted
814 event] (dosync (process-mouse-event dispatcher source-event))]
815 (when button?
816 (translate-and-dispatch acted true event))
817 (translate-and-dispatch exited false event :mouse-exited)
818 (translate-and-dispatch entered false event :mouse-entered)
819 (when-not button?
820 (translate-and-dispatch moved true source-event))))
822 (defrecord RootEventDispatcher [tree-r ;; register
823 tree ;; dispatch
824 active ;; nodes under cursor
825 hovered ;; mouse entered
826 picked ;; mouse pressed
827 last-motion]
828 EventDispatcher
829 (listen! [dispatcher component]
830 (doto ^Component component
831 (.addMouseListener dispatcher)
832 (.addMouseWheelListener dispatcher)
833 (.addMouseMotionListener dispatcher)))
834 (create-dispatcher [dispatcher handle handlers]
835 (let [node (make-node handle handlers)]
836 (dosync (alter tree-r add-node node))
837 node))
838 (commit [dispatcher]
839 (let [[exited
840 entered
841 _ _
842 event] (dosync
843 ;; TODO: retain contexts that do
844 ;; not intersect graphics
845 ;; clipping area in tree.
846 (ref-set tree @tree-r)
847 (ref-set tree-r {})
848 (process-mouse-event dispatcher nil))]
849 ;; Send mouse entered and exited events if necessary due to
850 ;; updated layout.
851 (translate-and-dispatch exited false event :mouse-exited)
852 (translate-and-dispatch entered false event :mouse-entered)))
853 (handle-picked? [dispatcher handle]
854 (some #(= handle (.handle ^DispatcherNode %)) @picked))
855 (handle-hovered? [dispatcher handle]
856 (some #(= handle (.handle ^DispatcherNode %)) @hovered))
857 MouseListener
858 (mouseEntered [dispatcher event]
859 (dispatch-mouse-event dispatcher event false))
860 (mouseExited [dispatcher event]
861 (dispatch-mouse-event dispatcher event false))
862 (mouseClicked [dispatcher event]
863 (dispatch-mouse-event dispatcher event true))
864 (mousePressed [dispatcher event]
865 (dispatch-mouse-event dispatcher event true))
866 (mouseReleased [dispatcher event]
867 (dispatch-mouse-event dispatcher event true))
868 MouseWheelListener
869 (mouseWheelMoved [dispatcher event]
870 (dispatch-mouse-event dispatcher event true))
871 MouseMotionListener
872 (mouseDragged [dispatcher event]
873 (dispatch-mouse-event dispatcher event false))
874 (mouseMoved [dispatcher event]
875 (dispatch-mouse-event dispatcher event false)))
877 (defn root-event-dispatcher []
878 (->RootEventDispatcher
879 (ref {}) (ref {}) ;; trees
880 (ref nil) (ref nil) (ref nil) ;; node states
881 (ref nil))) ;; last event
883 ;;
884 ;; Scene
885 ;;
887 (defrecord Scene [view
888 event-dispatcher
889 component
890 rendering-hints
891 next-state])
893 ;; Define rendering hints that affect font metrics to make sure that
894 ;; Graphics and Scene FontRenderContexts are consistent.
895 (def ^:private default-rendering-hints
896 {RenderingHints/KEY_TEXT_ANTIALIASING
897 RenderingHints/VALUE_TEXT_ANTIALIAS_DEFAULT,
898 RenderingHints/KEY_FRACTIONALMETRICS
899 RenderingHints/VALUE_FRACTIONALMETRICS_DEFAULT})
901 (defn make-scene
902 ([view]
903 (make-scene view dummy-event-dispatcher nil))
904 ([view event-dispatcher]
905 (make-scene view event-dispatcher nil))
906 ([view event-dispatcher ^Component component]
907 (make-scene view event-dispatcher component nil))
908 ([view event-dispatcher ^Component component hints]
909 (let [hints (merge default-rendering-hints hints)]
910 (->Scene view
911 event-dispatcher
912 component
913 hints
914 (atom nil)))))
916 (defn- get-and-set!
917 "Atomically sets the value of atom to newval and returns the old
918 value."
919 [atom newval]
920 (loop [v @atom]
921 (if (compare-and-set! atom v newval)
922 v
923 (recur @atom))))
925 (defn draw-scene!
926 [scene ^Graphics2D graphics width height]
927 (.addRenderingHints graphics (:rendering-hints scene))
928 (binding [*states* (get-and-set! (:next-state scene) nil)
929 *scene* scene
930 *graphics* graphics
931 *initial-transform* (.getTransform graphics)
932 *inverse-initial-transform* (-> graphics
933 .getTransform
934 .createInverse)
935 *event-dispatcher* (:event-dispatcher scene)
936 *width* width
937 *height* height
938 *clip* (Rectangle2D$Double. 0.0 0.0 width height)
939 *input-clip* nil
940 *time* (System/nanoTime)]
941 (apply-theme)
942 (let [tmp-watcher (Object.)]
943 ;; Keep current context observers until the rendering is
944 ;; complete. Some observers may be invoked twice if they
945 ;; appear in both groups until tmp-watcher is removed.
946 (replace-observers-watcher scene tmp-watcher)
947 (try
948 (render! (:view scene))
949 (finally
950 (remove-observers tmp-watcher)
951 (commit (:event-dispatcher scene)))))))
953 (defn- scene-font-context [scene]
954 (let [hints (:rendering-hints scene)
955 ^Component c (:component scene)
956 t (if c (->> c
957 .getFont
958 (.getFontMetrics c)
959 .getFontRenderContext
960 .getTransform))]
961 (FontRenderContext.
962 t
963 (get hints RenderingHints/KEY_TEXT_ANTIALIASING)
964 (get hints RenderingHints/KEY_FRACTIONALMETRICS))))
966 (defn scene-geometry [scene]
967 (binding [*scene* scene
968 *font-context* (scene-font-context scene)]
969 (geometry (:view scene))))
971 (defn set-cursor! [^Cursor cursor]
972 (when-let [^Component component (:component *scene*)]
973 (EventQueue/invokeLater #(.setCursor component cursor))))