Mercurial > hg > indyvon
view src/net/kryshen/indyvon/core.clj @ 108:520aa5fa9286
Added a couple of type hints.
| author | Mikhail Kryshen <mikhail@kryshen.net> |
|---|---|
| date | Thu, 06 Oct 2011 16:50:42 +0300 |
| parents | f42e2b9e1ad9 |
| children | f3dedece38f3 |
line source
1 ;;
2 ;; Copyright 2010, 2011 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 net.kryshen.indyvon.core
21 (:import
22 (java.awt Graphics2D RenderingHints Component Color Font Shape)
23 (java.awt.geom AffineTransform Point2D$Double Rectangle2D$Double Area)
24 (java.awt.event MouseListener MouseMotionListener
25 MouseWheelListener MouseWheelEvent)
26 (java.awt.font FontRenderContext)
27 java.util.concurrent.ConcurrentMap
28 com.google.common.collect.MapMaker))
30 ;;
31 ;; Layer context
32 ;;
34 (def ^{:dynamic true
35 :tag Graphics2D}
36 *graphics*)
38 (def ^{:dynamic true
39 :tag FontRenderContext}
40 *font-context*)
42 (def ^{:dynamic true
43 :tag Component
44 :doc "Target AWT component, may be nil if drawing off-screen."}
45 *target*)
47 (def ^{:dynamic true
48 :doc "Width of the rendering area."}
49 *width*)
51 (def ^{:dynamic true
52 :doc "Height of the rendering area."}
53 *height*)
55 (def ^{:dynamic true
56 :tag Shape}
57 *clip*)
59 (def ^{:dynamic true
60 :doc "The root (background) layer of the scene."}
61 *root*)
63 (def ^{:dynamic true
64 :doc "Time in nanoseconds when the rendering of the current
65 frame starts."}
66 *time*)
68 (def ^{:dynamic true}
69 *event-dispatcher*)
71 (def ^{:dynamic true
72 :tag AffineTransform
73 :doc "Initial transform associated with the graphics context."}
74 *initial-transform*)
76 (def ^{:dynamic true
77 :tag AffineTransform
78 :doc "Inversion of the initial transform associated with
79 the graphics context."}
80 *inverse-initial-transform*)
82 (defrecord Theme [fore-color back-color alt-back-color border-color
83 shadow-color font])
85 ;; REMIND: use system colors, see java.awt.SystemColor.
86 (defn default-theme []
87 (Theme. Color/BLACK
88 Color/WHITE
89 (Color. 0xC8 0xD2 0xD8)
90 (Color. 0 0 0xC8)
91 (Color. 0x44 0x44 0x44)
92 (Font. "Sans" Font/PLAIN 12)))
94 (def ^{:dynamic true} *theme* (default-theme))
96 ;;
97 ;; Core protocols and types
98 ;;
100 (defprotocol Layer
101 "Basic UI element."
102 (render! [layer]
103 "Draws layer in the current *graphics* context.")
104 (geometry [layer]
105 "Returns the preferred layer Geometry."))
107 (defprotocol Geometry
108 "Describes geometry of a Layer. Prefer using the available
109 implementations (Size, FixedGeometry and NestedGeometry) over
110 extending this protocol directly as it is likely to be changed in
111 the future versions."
112 (width [geom] [geom height])
113 (height [geom] [geom width])
114 (anchor-x [geom h-align width]
115 "Returns the x coordinate of the anchor point for the specified
116 horizontal alignment and width, h-align could be :left, :center
117 or :right.")
118 (anchor-y [geom v-align height]
119 "Returns the y coordinate of the anchor point for the specified
120 vertical alignment and height, v-align could be :top, :center
121 or :bottom."))
123 (defrecord Size [width height]
124 Geometry
125 (width [_] width)
126 (width [_ _] width)
127 (height [_] height)
128 (height [_ _] height)
129 (anchor-x [_ h-align width]
130 (case h-align
131 :left 0
132 :center (/ width 2)
133 :right width))
134 (anchor-y [_ v-align height]
135 (case v-align
136 :top 0
137 :center (/ height 2)
138 :bottom height)))
140 (defrecord FixedGeometry [ax ay width height]
141 Geometry
142 (width [_] width)
143 (width [_ _] width)
144 (height [_] height)
145 (height [_ _] height)
146 (anchor-x [_ _ _] ax)
147 (anchor-y [_ _ _] ay))
149 (defrecord NestedGeometry [geometry top left bottom right]
150 Geometry
151 (width [_]
152 (+ left right (width geometry)))
153 (width [_ h]
154 (+ left right (width geometry (- h top bottom))))
155 (height [_]
156 (+ top bottom (height geometry)))
157 (height [_ w]
158 (+ top bottom (height geometry (- w left right))))
159 (anchor-x [_ h-align w]
160 (+ left (anchor-x geometry h-align (- w left right))))
161 (anchor-y [_ v-align h]
162 (+ top (anchor-y geometry v-align (- h top bottom)))))
164 (defrecord ScaledGeometry [geometry sx sy]
165 Geometry
166 (width [_]
167 (* sx (width geometry)))
168 (width [_ h]
169 (* sx (width geometry (/ h sy))))
170 (height [_]
171 (* sy (height geometry)))
172 (height [_ w]
173 (* sy (height geometry (/ w sx))))
174 (anchor-x [_ h-align w]
175 (* sx (anchor-x geometry h-align (/ w sx))))
176 (anchor-y [_ v-align h]
177 (* sy (anchor-y geometry v-align (/ h sy)))))
179 ;; TODO: modifiers
180 (defrecord MouseEvent [id when x y x-on-screen y-on-screen button
181 wheel-rotation])
183 ;; TODO: KeyEvent
185 (defprotocol EventDispatcher
186 (listen! [this component]
187 "Listen for events on the specified AWT Component.")
188 (create-dispatcher [this handle handlers]
189 "Returns new event dispatcher associated with the specified event
190 handlers (an event-id -> handler-fn map). Handle is used to
191 match the contexts between commits.")
192 (commit [this]
193 "Apply the registered handlers for event processing.")
194 (handle-picked? [this handle]
195 "Returns true if the specified handle received the :mouse-pressed
196 event and have not yet received :moused-released.")
197 (handle-hovered? [this handle]
198 "Returns true if the specified handle received the :mouse-entered
199 event and have not yet received :mouse-exited."))
201 (defn- assoc-cons [m key val]
202 (->> (get m key) (cons val) (assoc m key)))
204 ;;
205 ;; Observers
206 ;; The mechanism used by layers to request repaints
207 ;;
209 (def ^ConcurrentMap observers
210 (-> (MapMaker.) (.weakKeys) (.makeMap)))
212 (defn- cm-replace!
213 "Wrap ConcurrentMap replace method to treat nil value as absent
214 mapping. Use with maps that does not support nil values."
215 [^ConcurrentMap cmap key old new]
216 (if (nil? old)
217 (nil? (.putIfAbsent cmap key new))
218 (.replace cmap key old new)))
220 (defn- cm-swap!
221 "Atomically swaps the value associated with key in ConcurrentMap
222 to be (apply f current-value args). Returns the new value."
223 [^ConcurrentMap cmap key f & args]
224 (loop []
225 (let [old (.get cmap key)
226 new (apply f old args)]
227 (if (cm-replace! cmap key old new)
228 new
229 (recur)))))
231 (defn add-observer
232 "Add observer fn for the target. Watcher identifies the group of
233 observers and could be used to remove the group. Watcher is weakly
234 referenced, all associated observers will be removed when the
235 wathcer is removed by gc. The observer fn will be called with
236 watcher and target arguments and any additional arguments specified
237 in update call."
238 [watcher target f]
239 (cm-swap! observers watcher assoc-cons target f)
240 nil)
242 (defn remove-observers
243 "Remove group of observers associated with the specified watcher."
244 [watcher]
245 (.remove observers watcher)
246 nil)
248 (defn- replace-observers-watcher
249 [old-watcher new-watcher]
250 (if-let [old (.remove observers old-watcher)]
251 (.put observers new-watcher old))
252 nil)
254 (defn update
255 "Notify observers."
256 [target & args]
257 (doseq [entry observers
258 f (get (val entry) target)]
259 (apply f (key entry) target args)))
261 (defn add-context-observer
262 "Observer registered with this function will be automatically
263 removed after the next frame rendering is complete."
264 [target f]
265 (let [root *root*]
266 (add-observer root target f)))
268 (defn repaint-on-update
269 "Trigger repaint of the current scene when the target updates."
270 [target]
271 (let [root *root*]
272 (if (not= root target)
273 (add-observer root target (fn [w _] (update w))))))
275 (defn repaint
276 "Repaint the current scene."
277 []
278 (update *root*))
280 ;;
281 ;; Rendering
282 ;;
284 (defn ^AffineTransform relative-transform
285 "Returns AffineTransform: layer context -> AWT component."
286 []
287 (let [tr (.getTransform *graphics*)]
288 (.preConcatenate tr *inverse-initial-transform*)
289 tr))
291 (defn ^AffineTransform inverse-relative-transform
292 "Returns AffineTransform: AWT component -> layer context."
293 []
294 (let [tr (.getTransform *graphics*)]
295 (.invert tr) ; absolute -> layer
296 (.concatenate tr *initial-transform*) ; component -> absolute
297 tr))
299 (defn transform-point [^AffineTransform tr x y]
300 (let [p (Point2D$Double. x y)]
301 (.transform tr p p)
302 [(.x p) (.y p)]))
304 ;; (defn- clip
305 ;; "Intersect clipping area with the specified shape or bounds.
306 ;; Returns new clip (Shape or nil if empty)."
307 ;; ([x y w h]
308 ;; (clip (Rectangle2D$Double. x y w h)))
309 ;; ([shape]
310 ;; (let [a1 (Area. shape)
311 ;; a2 (if (instance? Area *clip*) *clip* (Area. *clip*))]
312 ;; (.transform a1 (relative-transform))
313 ;; (.intersect a1 a2)
314 ;; (if (.isEmpty a1)
315 ;; nil
316 ;; a1))))
318 ;; Use faster clipping calculation provided by Graphics2D.
319 (defn- clip
320 "Intersect clipping area with the specified bounds in current
321 transform coordinates. Returns new clip in the AWT component
322 coordinates (Shape or nil if empty)."
323 [x y w h]
324 (let [^Graphics2D clip-g (.create *graphics*)]
325 (doto clip-g
326 (.setClip x y w h)
327 (.setTransform *initial-transform*)
328 (.clip *clip*))
329 (try
330 (if (.isEmpty (.getClipBounds clip-g))
331 nil
332 (.getClip clip-g))
333 (finally
334 (.dispose clip-g)))))
336 (defn- ^Graphics2D apply-theme
337 "Set graphics' color and font to match theme.
338 Modifies and returns the first argument."
339 ([]
340 (apply-theme *graphics* *theme*))
341 ([^Graphics2D graphics theme]
342 (doto graphics
343 (.setColor (:fore-color theme))
344 (.setFont (:font theme)))))
346 (defn- ^Graphics2D create-graphics
347 ([]
348 (apply-theme (.create *graphics*) *theme*))
349 ([x y w h]
350 (apply-theme (.create *graphics* x y w h) *theme*)))
352 (defn- with-bounds-noclip*
353 [x y w h f & args]
354 (let [graphics (create-graphics)]
355 (try
356 (.translate graphics (int x) (int y))
357 (binding [*width* w
358 *height* h
359 *graphics* graphics]
360 (apply f args))
361 (finally
362 (.dispose graphics)))))
364 (defn with-bounds*
365 [x y w h f & args]
366 (when-let [clip (clip x y w h)]
367 (let [graphics (create-graphics x y w h)]
368 (try
369 (binding [*width* w
370 *height* h
371 *clip* clip
372 *graphics* graphics]
373 (apply f args))
374 (finally
375 (.dispose graphics))))))
377 (defmacro with-bounds
378 [x y w h & body]
379 `(with-bounds* ~x ~y ~w ~h (fn [] ~@body)))
381 (defmacro with-theme
382 [theme & body]
383 `(binding [*theme* (merge *theme* ~theme)]
384 ~@body))
386 (defmacro with-color
387 [color-or-keyword & body]
388 (let [color-form (if (keyword? color-or-keyword)
389 `(~color-or-keyword *theme*)
390 color-or-keyword)]
391 `(let [color# ~color-form
392 old-color# (.getColor *graphics*)]
393 (try
394 (.setColor *graphics* color#)
395 ~@body
396 (finally
397 (.setColor *graphics* old-color#))))))
399 (defn with-hints*
400 [hints f & args]
401 (if hints
402 (let [g *graphics*
403 old (.getRenderingHints g)]
404 (try
405 (.addRenderingHints g hints)
406 (binding [*font-context* (.getFontRenderContext g)]
407 (apply f args))
408 (finally
409 (.setRenderingHints g old))))
410 (apply f args)))
412 (defmacro with-hints
413 [hints & body]
414 `(with-hints ~hints (fn [] ~@body)))
416 ;; TODO: constructor for AffineTransform.
417 ;; (transform :scale 0.3 0.5
418 ;; :translate 5 10
419 ;; :rotate (/ Math/PI 2))
421 (defmacro with-transform [transform & body]
422 `(let [old-t# (.getTransform *graphics*)]
423 (try
424 (.transform *graphics* ~transform)
425 ~@body
426 (finally
427 (.setTransform *graphics* old-t#)))))
429 (defmacro with-rotate [theta ax ay & body]
430 `(let [transform# (AffineTransform/getRotateInstance ~theta ~ax ~ay)]
431 (with-transform transform# ~@body)))
433 (defmacro with-translate [x y & body]
434 `(let [x# ~x
435 y# ~y]
436 (try
437 (.translate *graphics* x# y#)
438 ~@body
439 (finally
440 (.translate *graphics* (- x#) (- y#))))))
442 (defn draw!
443 "Draws layer."
444 ([layer]
445 (let [graphics (create-graphics)]
446 (try
447 (binding [*graphics* graphics]
448 (render! layer))
449 (finally
450 (.dispose graphics)))))
451 ([layer x y]
452 (draw! layer x y true))
453 ([layer x y clip?]
454 (let [geom (geometry layer)]
455 (draw! layer x y (width geom) (height geom) clip?)))
456 ([layer x y width height]
457 (draw! layer x y width height true))
458 ([layer x y width height clip?]
459 (if clip?
460 (with-bounds* x y width height render! layer)
461 (with-bounds-noclip* x y width height render! layer))))
463 (defn draw-aligned!
464 "Draws layer. Location is relative to the layer's anchor point for
465 the specified alignment."
466 ([layer h-align v-align x y]
467 (let [geom (geometry layer)
468 w (width geom)
469 h (height geom)]
470 (draw! layer
471 (- x (anchor-x geom h-align w))
472 (- y (anchor-y geom v-align h))
473 w h)))
474 ([layer h-align v-align x y w h]
475 (let [geom (geometry layer)]
476 (draw! layer
477 (- x (anchor-x geom h-align w))
478 (- y (anchor-y geom v-align h))
479 w h))))
481 (defn draw-root!
482 "Draws the root layer."
483 ([layer graphics width height event-dispatcher]
484 (draw-root! layer graphics width height event-dispatcher nil))
485 ([layer ^Graphics2D graphics width height event-dispatcher target]
486 ;; (.setRenderingHint graphics
487 ;; RenderingHints/KEY_INTERPOLATION
488 ;; RenderingHints/VALUE_INTERPOLATION_BILINEAR)
489 ;; (.setRenderingHint graphics
490 ;; RenderingHints/KEY_ALPHA_INTERPOLATION
491 ;; RenderingHints/VALUE_ALPHA_INTERPOLATION_QUALITY)
492 ;; (.setRenderingHint graphics
493 ;; RenderingHints/KEY_ANTIALIASING
494 ;; RenderingHints/VALUE_ANTIALIAS_ON)
495 ;; (.setRenderingHint graphics
496 ;; RenderingHints/KEY_TEXT_ANTIALIASING
497 ;; RenderingHints/VALUE_TEXT_ANTIALIAS_ON)
498 (binding [*root* layer
499 *target* target
500 *graphics* graphics
501 *font-context* (.getFontRenderContext graphics)
502 *initial-transform* (.getTransform graphics)
503 *inverse-initial-transform*
504 (-> graphics .getTransform .createInverse)
505 *event-dispatcher* event-dispatcher
506 *width* width
507 *height* height
508 *clip* (Rectangle2D$Double. 0 0 width height)
509 *time* (System/nanoTime)]
510 (apply-theme)
511 (let [tmp-watcher (Object.)]
512 ;; Keep current context observers until the rendering is
513 ;; complete. Some observers may be invoked twice if they
514 ;; appear in both groups until tmp-watcher is removed.
515 (replace-observers-watcher layer tmp-watcher)
516 (try
517 (render! layer)
518 (finally
519 (remove-observers tmp-watcher)
520 (commit event-dispatcher)))))))
522 (defn root-geometry
523 ([layer font-context]
524 (root-geometry layer font-context nil))
525 ([layer font-context target]
526 (binding [*root* layer
527 *target* target
528 *font-context* font-context]
529 (geometry layer))))
531 ;;
532 ;; Event handling.
533 ;;
535 (defn with-handlers*
536 [handle handlers f & args]
537 (binding [*event-dispatcher* (create-dispatcher
538 *event-dispatcher* handle handlers)]
539 (apply f args)))
541 (defmacro with-handlers
542 "specs => (:event-id name & handler-body)*
544 Execute form with the specified event handlers."
545 [handle form & specs]
546 `(with-handlers* ~handle
547 ~(reduce (fn [m spec]
548 (assoc m (first spec)
549 `(fn [~(second spec)]
550 ~@(nnext spec)))) {}
551 specs)
552 (fn [] ~form)))
554 (defn picked? [handle]
555 (handle-picked? *event-dispatcher* handle))
557 (defn hovered? [handle]
558 (handle-hovered? *event-dispatcher* handle))
560 ;;
561 ;; EventDispatcher implementation
562 ;;
564 (def awt-events
565 {java.awt.event.MouseEvent/MOUSE_CLICKED :mouse-clicked
566 java.awt.event.MouseEvent/MOUSE_DRAGGED :mouse-dragged
567 java.awt.event.MouseEvent/MOUSE_ENTERED :mouse-entered
568 java.awt.event.MouseEvent/MOUSE_EXITED :mouse-exited
569 java.awt.event.MouseEvent/MOUSE_MOVED :mouse-moved
570 java.awt.event.MouseEvent/MOUSE_PRESSED :mouse-pressed
571 java.awt.event.MouseEvent/MOUSE_RELEASED :mouse-released
572 java.awt.event.MouseEvent/MOUSE_WHEEL :mouse-wheel})
574 (def dummy-event-dispatcher
575 (reify
576 EventDispatcher
577 (listen! [this component])
578 (create-dispatcher [this handle handlers] this)
579 (commit [this])
580 (handle-picked? [this handle])
581 (handle-hovered? [this handle])))
583 (defrecord DispatcherNode [handle handlers parent
584 ^Shape clip ^AffineTransform transform
585 bindings]
586 EventDispatcher
587 (listen! [this component]
588 (listen! parent component))
589 (create-dispatcher [this handle handlers]
590 (create-dispatcher parent handle handlers))
591 (commit [this]
592 (commit parent))
593 (handle-picked? [this handle]
594 (handle-picked? parent handle))
595 (handle-hovered? [this handle]
596 (handle-hovered? parent handle)))
598 (defn- make-node [handle handlers]
599 (DispatcherNode. handle handlers *event-dispatcher* *clip*
600 (inverse-relative-transform)
601 (get-thread-bindings)))
603 (defn- add-node [tree node]
604 (assoc-cons tree (:parent node) node))
606 (defn- nodes [tree]
607 (apply concat (vals tree)))
609 (defn- under-cursor
610 "Returns a vector of child nodes under cursor."
611 [x y tree node]
612 (some #(if (.contains ^Shape (:clip %) x y)
613 (conj (vec (under-cursor x y tree %)) %))
614 (get tree node)))
616 (defn- remove-all [coll1 coll2 pred]
617 (filter #(not (some (partial pred %) coll2)) coll1))
619 (defn- translate-mouse-event [^java.awt.event.MouseEvent event
620 ^AffineTransform tr id]
621 (let [[x y] (transform-point tr (.getX event) (.getY event))
622 rotation (if (instance? MouseWheelEvent event)
623 (.getWheelRotation ^MouseWheelEvent event)
624 nil)]
625 (MouseEvent. id (.getWhen event) x y
626 (.getXOnScreen event) (.getYOnScreen event)
627 (.getButton event)
628 rotation)))
630 (defn- translate-and-dispatch
631 ([nodes first-only ^java.awt.event.MouseEvent event]
632 (translate-and-dispatch nodes first-only
633 event (awt-events (.getID event))))
634 ([nodes first-only event id]
635 (if-let [node (first nodes)]
636 (if-let [handler (get (:handlers node) id)]
637 (do
638 (let [translated (translate-mouse-event event (:transform node) id)]
639 (with-bindings* (:bindings node)
640 handler translated))
641 (if-not first-only
642 (recur (rest nodes) false event id)))
643 (recur (rest nodes) first-only event id)))))
645 (defn- dispatch-mouse-motion
646 "Dispatches mouse motion events."
647 [hovered-ref tree root ^java.awt.event.MouseEvent event]
648 (let [x (.getX event)
649 y (.getY event)
650 [hovered hovered2] (dosync
651 [@hovered-ref
652 (ref-set hovered-ref
653 (under-cursor x y tree root))])
654 pred #(= (:handle %1) (:handle %2))
655 exited (remove-all hovered hovered2 pred)
656 entered (remove-all hovered2 hovered pred)
657 moved (remove-all hovered2 entered pred)]
658 (translate-and-dispatch exited false event :mouse-exited)
659 (translate-and-dispatch entered false event :mouse-entered)
660 (translate-and-dispatch moved true event :mouse-moved)))
662 (defn- dispatch-mouse-button
663 [picked-ref hovered-ref ^java.awt.event.MouseEvent event]
664 (let [id (awt-events (.getID event))
665 nodes (case id
666 :mouse-pressed
667 (dosync
668 (ref-set picked-ref @hovered-ref))
669 :mouse-released
670 (dosync
671 (let [picked @picked-ref]
672 (ref-set picked-ref nil)
673 picked))
674 @hovered-ref)]
675 (translate-and-dispatch nodes true event id)))
677 (defn root-event-dispatcher []
678 (let [tree-r (ref {}) ; register
679 tree (ref {}) ; dispatch
680 hovered (ref '())
681 picked (ref '())]
682 (reify
683 EventDispatcher
684 (listen! [this component]
685 (doto ^Component component
686 (.addMouseListener this)
687 (.addMouseWheelListener this)
688 (.addMouseMotionListener this)))
689 (create-dispatcher [this handle handlers]
690 (let [node (make-node handle handlers)]
691 (dosync (alter tree-r add-node node))
692 node))
693 (commit [this]
694 ;; TODO: retain contexts that do not intersect graphics
695 ;; clipping area in tree.
696 (dosync (ref-set tree @tree-r)
697 (ref-set tree-r {})))
698 (handle-picked? [this handle]
699 (some #(= handle (:handle %)) @picked))
700 (handle-hovered? [this handle]
701 (some #(= handle (:handle %)) @hovered))
702 MouseListener
703 (mouseEntered [this event]
704 (dispatch-mouse-motion hovered @tree this event))
705 (mouseExited [this event]
706 (dispatch-mouse-motion hovered @tree this event))
707 (mouseClicked [this event]
708 (dispatch-mouse-button picked hovered event))
709 (mousePressed [this event]
710 (dispatch-mouse-button picked hovered event))
711 (mouseReleased [this event]
712 (dispatch-mouse-button picked hovered event))
713 MouseWheelListener
714 (mouseWheelMoved [this event]
715 (dispatch-mouse-button picked hovered event))
716 MouseMotionListener
717 (mouseDragged [this event]
718 (translate-and-dispatch @picked true event))
719 (mouseMoved [this event]
720 (dispatch-mouse-motion hovered @tree this event)))))