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