view src/net/kryshen/indyvon/core.clj @ 102:fd8fb8a3ff5a

Fixed anchor point calculation, changes in demo/test scene.
author Mikhail Kryshen <mikhail@kryshen.net>
date Wed, 18 May 2011 21:28:24 +0400
parents 9874107e3e96
children 491152048c89 f42e2b9e1ad9
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 (defrecord Location [x y])
97 (defrecord Size [width height])
98 (defrecord Bounds [x y width height])
100 ;;
101 ;; Core protocols and types
102 ;;
104 (defprotocol Layer
105 "Basic UI element."
106 (render! [this])
107 (layer-size [this]))
109 ;; TODO: modifiers
110 (defrecord MouseEvent [id when x y x-on-screen y-on-screen button
111 wheel-rotation])
113 ;; TODO: KeyEvent
115 (defprotocol EventDispatcher
116 (listen! [this component]
117 "Listen for events on the specified AWT Component.")
118 (create-dispatcher [this handle handlers]
119 "Returns new event dispatcher associated with the specified event
120 handlers (an event-id -> handler-fn map). Handle is used to
121 match the contexts between commits.")
122 (commit [this]
123 "Apply the registered handlers for event processing.")
124 (handle-picked? [this handle]
125 "Returns true if the specified handle received the :mouse-pressed
126 event and have not yet received :moused-released.")
127 (handle-hovered? [this handle]
128 "Returns true if the specified handle received the :mouse-entered
129 event and have not yet received :mouse-exited."))
131 (defprotocol Anchored
132 "Provide anchor point for Layers. Used by viewport."
133 (anchor [this h-align v-align]
134 "Anchor point: [x y], h-align could be :left, :center or :right,
135 v-align is :top, :center or :bottom"))
137 (defn default-anchor [layer h-align v-align]
138 (if (and (= h-align :left)
139 (= v-align :top))
140 (Location. 0 0)
141 (let [size (layer-size layer)]
142 (Location.
143 (case h-align
144 :left 0
145 :center (/ (:width size) 2)
146 :right (:width size))
147 (case v-align
148 :top 0
149 :center (/ (:height size) 2)
150 :bottom (:height size))))))
152 ;; Default implementation of Anchored for any Layer.
153 (extend-protocol Anchored
154 net.kryshen.indyvon.core.Layer
155 (anchor [this h-align v-align]
156 (default-anchor this h-align v-align)))
158 (defn- assoc-cons [m key val]
159 (->> (get m key) (cons val) (assoc m key)))
161 ;;
162 ;; Observers
163 ;; The mechanism used by layers to request repaints
164 ;;
166 (def ^ConcurrentMap observers
167 (-> (MapMaker.) (.weakKeys) (.makeMap)))
169 (defn- cm-replace!
170 "Wrap ConcurrentMap replace method to treat nil value as absent
171 mapping. Use with maps that does not support nil values."
172 [^ConcurrentMap cmap key old new]
173 (if (nil? old)
174 (nil? (.putIfAbsent cmap key new))
175 (.replace cmap key old new)))
177 (defn- cm-swap!
178 "Atomically swaps the value associated with key in ConcurrentMap
179 to be (apply f current-value args). Returns the new value."
180 [^ConcurrentMap cmap key f & args]
181 (loop []
182 (let [old (.get cmap key)
183 new (apply f old args)]
184 (if (cm-replace! cmap key old new)
185 new
186 (recur)))))
188 (defn add-observer
189 "Add observer fn for the target. Watcher identifies the group of
190 observers and could be used to remove the group. Watcher is weakly
191 referenced, all associated observers will be removed when the
192 wathcer is removed by gc. The observer fn will be called with
193 watcher and target arguments and any additional arguments specified
194 in update call."
195 [watcher target f]
196 (cm-swap! observers watcher assoc-cons target f)
197 nil)
199 (defn remove-observers
200 "Remove group of observers associated with the specified watcher."
201 [watcher]
202 (.remove observers watcher)
203 nil)
205 (defn- replace-observers-watcher
206 [old-watcher new-watcher]
207 (if-let [old (.remove observers old-watcher)]
208 (.put observers new-watcher old))
209 nil)
211 (defn update
212 "Notify observers."
213 [target & args]
214 (doseq [entry observers
215 f (get (val entry) target)]
216 (apply f (key entry) target args)))
218 (defn add-context-observer
219 "Observer registered with this function will be automatically
220 removed after the next frame rendering is complete."
221 [target f]
222 (let [root *root*]
223 (add-observer root target f)))
225 (defn repaint-on-update
226 "Trigger repaint of the current scene when the target updates."
227 [target]
228 (let [root *root*]
229 (if (not= root target)
230 (add-observer root target (fn [w _] (update w))))))
232 (defn repaint
233 "Repaint the current scene."
234 []
235 (update *root*))
237 ;;
238 ;; Rendering
239 ;;
241 (defn relative-transform
242 "Returns AffineTransform: layer context -> AWT component."
243 []
244 (let [tr (.getTransform *graphics*)]
245 (.preConcatenate tr *inverse-initial-transform*)
246 tr))
248 (defn inverse-relative-transform
249 "Returns AffineTransform: AWT component -> layer context."
250 []
251 (let [tr (.getTransform *graphics*)]
252 (.invert tr) ; absolute -> layer
253 (.concatenate tr *initial-transform*) ; component -> absolute
254 tr))
256 (defn transform-point [^AffineTransform tr x y]
257 (let [p (Point2D$Double. x y)]
258 (.transform tr p p)
259 [(.x p) (.y p)]))
261 ;; (defn- clip
262 ;; "Intersect clipping area with the specified shape or bounds.
263 ;; Returns new clip (Shape or nil if empty)."
264 ;; ([x y w h]
265 ;; (clip (Rectangle2D$Double. x y w h)))
266 ;; ([shape]
267 ;; (let [a1 (Area. shape)
268 ;; a2 (if (instance? Area *clip*) *clip* (Area. *clip*))]
269 ;; (.transform a1 (relative-transform))
270 ;; (.intersect a1 a2)
271 ;; (if (.isEmpty a1)
272 ;; nil
273 ;; a1))))
275 ;; Use faster clipping calculation provided by Graphics2D.
276 (defn- clip
277 "Intersect clipping area with the specified bounds in current
278 transform coordinates. Returns new clip in the AWT component
279 coordinates (Shape or nil if empty)."
280 [x y w h]
281 (let [^Graphics2D clip-g (.create *graphics*)]
282 (doto clip-g
283 (.setClip x y w h)
284 (.setTransform *initial-transform*)
285 (.clip *clip*))
286 (try
287 (if (.isEmpty (.getClipBounds clip-g))
288 nil
289 (.getClip clip-g))
290 (finally
291 (.dispose clip-g)))))
293 (defn- ^Graphics2D apply-theme
294 "Set graphics' color and font to match theme.
295 Modifies and returns the first argument."
296 ([]
297 (apply-theme *graphics* *theme*))
298 ([^Graphics2D graphics theme]
299 (doto graphics
300 (.setColor (:fore-color theme))
301 (.setFont (:font theme)))))
303 (defn- ^Graphics2D create-graphics
304 ([]
305 (apply-theme (.create *graphics*) *theme*))
306 ([x y w h]
307 (apply-theme (.create *graphics* x y w h) *theme*)))
309 (defn- with-bounds-noclip*
310 [x y w h f & args]
311 (let [graphics (create-graphics)]
312 (try
313 (.translate graphics (int x) (int y))
314 (binding [*width* w
315 *height* h
316 *graphics* graphics]
317 (apply f args))
318 (finally
319 (.dispose graphics)))))
321 (defn with-bounds*
322 [x y w h f & args]
323 (when-let [clip (clip x y w h)]
324 (let [graphics (create-graphics x y w h)]
325 (try
326 (binding [*width* w
327 *height* h
328 *clip* clip
329 *graphics* graphics]
330 (apply f args))
331 (finally
332 (.dispose graphics))))))
334 (defmacro with-bounds
335 [x y w h & body]
336 `(with-bounds* ~x ~y ~w ~h (fn [] ~@body)))
338 (defmacro with-theme
339 [theme & body]
340 `(binding [*theme* (merge *theme* ~theme)]
341 ~@body))
343 (defmacro with-color
344 [color-or-keyword & body]
345 (let [color-form (if (keyword? color-or-keyword)
346 `(~color-or-keyword *theme*)
347 color-or-keyword)]
348 `(let [color# ~color-form
349 old-color# (.getColor *graphics*)]
350 (try
351 (.setColor *graphics* color#)
352 ~@body
353 (finally
354 (.setColor *graphics* old-color#))))))
356 (defn with-hints*
357 [hints f & args]
358 (if hints
359 (let [g *graphics*
360 old (.getRenderingHints g)]
361 (try
362 (.addRenderingHints g hints)
363 (binding [*font-context* (.getFontRenderContext g)]
364 (apply f args))
365 (finally
366 (.setRenderingHints g old))))
367 (apply f args)))
369 (defmacro with-hints
370 [hints & body]
371 `(with-hints ~hints (fn [] ~@body)))
373 ;; TODO: constructor for AffineTransform.
374 ;; (transform :scale 0.3 0.5
375 ;; :translate 5 10
376 ;; :rotate (/ Math/PI 2))
378 (defmacro with-transform [transform & body]
379 `(let [old-t# (.getTransform *graphics*)]
380 (try
381 (.transform *graphics* ~transform)
382 ~@body
383 (finally
384 (.setTransform *graphics* old-t#)))))
386 (defmacro with-rotate [theta ax ay & body]
387 `(let [transform# (AffineTransform/getRotateInstance ~theta ~ax ~ay)]
388 (with-transform transform# ~@body)))
390 (defmacro with-translate [x y & body]
391 `(let [x# ~x
392 y# ~y]
393 (try
394 (.translate *graphics* x# y#)
395 ~@body
396 (finally
397 (.translate *graphics* (- x#) (- y#))))))
399 (defn draw!
400 "Draws layer."
401 ([layer]
402 (let [graphics (create-graphics)]
403 (try
404 (binding [*graphics* graphics]
405 (render! layer))
406 (finally
407 (.dispose graphics)))))
408 ([layer x y]
409 (draw! layer x y true))
410 ([layer x y clip?]
411 (let [size (layer-size layer)]
412 (draw! layer x y (:width size) (:height size) clip?)))
413 ([layer x y width height]
414 (draw! layer x y width height true))
415 ([layer x y width height clip?]
416 (if clip?
417 (with-bounds* x y width height render! layer)
418 (with-bounds-noclip* x y width height render! layer))))
420 (defn draw-anchored!
421 "Draws layer. Location is relative to the layer's anchor point for
422 the specified alignment."
423 ([layer h-align v-align x y]
424 (let [anchor (anchor layer h-align v-align)]
425 (draw! layer (- x (:x anchor)) (- y (:y anchor)))))
426 ([layer h-align v-align x y w h]
427 (let [anchor (anchor layer h-align v-align)]
428 (draw! layer (- x (:x anchor)) (- y (:y anchor)) w h))))
430 (defn draw-root!
431 "Draws the root layer."
432 ([layer graphics width height event-dispatcher]
433 (draw-root! layer graphics width height event-dispatcher nil))
434 ([layer ^Graphics2D graphics width height event-dispatcher target]
435 ;; (.setRenderingHint graphics
436 ;; RenderingHints/KEY_INTERPOLATION
437 ;; RenderingHints/VALUE_INTERPOLATION_BILINEAR)
438 ;; (.setRenderingHint graphics
439 ;; RenderingHints/KEY_ALPHA_INTERPOLATION
440 ;; RenderingHints/VALUE_ALPHA_INTERPOLATION_QUALITY)
441 ;; (.setRenderingHint graphics
442 ;; RenderingHints/KEY_ANTIALIASING
443 ;; RenderingHints/VALUE_ANTIALIAS_ON)
444 ;; (.setRenderingHint graphics
445 ;; RenderingHints/KEY_TEXT_ANTIALIASING
446 ;; RenderingHints/VALUE_TEXT_ANTIALIAS_ON)
447 (binding [*root* layer
448 *target* target
449 *graphics* graphics
450 *font-context* (.getFontRenderContext graphics)
451 *initial-transform* (.getTransform graphics)
452 *inverse-initial-transform*
453 (-> graphics .getTransform .createInverse)
454 *event-dispatcher* event-dispatcher
455 *width* width
456 *height* height
457 *clip* (Rectangle2D$Double. 0 0 width height)
458 *time* (System/nanoTime)]
459 (apply-theme)
460 (let [tmp-watcher (Object.)]
461 ;; Keep current context observers until the rendering is
462 ;; complete. Some observers may be invoked twice if they
463 ;; appear in both groups until tmp-watcher is removed.
464 (replace-observers-watcher layer tmp-watcher)
465 (try
466 (render! layer)
467 (finally
468 (remove-observers tmp-watcher)
469 (commit event-dispatcher)))))))
471 (defn root-size
472 ([layer font-context]
473 (root-size layer font-context nil))
474 ([layer font-context target]
475 (binding [*root* layer
476 *target* target
477 *font-context* font-context]
478 (layer-size layer))))
480 ;;
481 ;; Event handling.
482 ;;
484 (defn with-handlers*
485 [handle handlers f & args]
486 (binding [*event-dispatcher* (create-dispatcher
487 *event-dispatcher* handle handlers)]
488 (apply f args)))
490 (defmacro with-handlers
491 "specs => (:event-id name & handler-body)*
493 Execute form with the specified event handlers."
494 [handle form & specs]
495 `(with-handlers* ~handle
496 ~(reduce (fn [m spec]
497 (assoc m (first spec)
498 `(fn [~(second spec)]
499 ~@(nnext spec)))) {}
500 specs)
501 (fn [] ~form)))
503 (defn picked? [handle]
504 (handle-picked? *event-dispatcher* handle))
506 (defn hovered? [handle]
507 (handle-hovered? *event-dispatcher* handle))
509 ;;
510 ;; EventDispatcher implementation
511 ;;
513 (def awt-events
514 {java.awt.event.MouseEvent/MOUSE_CLICKED :mouse-clicked
515 java.awt.event.MouseEvent/MOUSE_DRAGGED :mouse-dragged
516 java.awt.event.MouseEvent/MOUSE_ENTERED :mouse-entered
517 java.awt.event.MouseEvent/MOUSE_EXITED :mouse-exited
518 java.awt.event.MouseEvent/MOUSE_MOVED :mouse-moved
519 java.awt.event.MouseEvent/MOUSE_PRESSED :mouse-pressed
520 java.awt.event.MouseEvent/MOUSE_RELEASED :mouse-released
521 java.awt.event.MouseEvent/MOUSE_WHEEL :mouse-wheel})
523 (def dummy-event-dispatcher
524 (reify
525 EventDispatcher
526 (listen! [this component])
527 (create-dispatcher [this handle handlers] this)
528 (commit [this])
529 (handle-picked? [this handle])
530 (handle-hovered? [this handle])))
532 (defrecord DispatcherNode [handle handlers parent
533 ^Shape clip ^AffineTransform transform
534 bindings]
535 EventDispatcher
536 (listen! [this component]
537 (listen! parent component))
538 (create-dispatcher [this handle handlers]
539 (create-dispatcher parent handle handlers))
540 (commit [this]
541 (commit parent))
542 (handle-picked? [this handle]
543 (handle-picked? parent handle))
544 (handle-hovered? [this handle]
545 (handle-hovered? parent handle)))
547 (defn- make-node [handle handlers]
548 (DispatcherNode. handle handlers *event-dispatcher* *clip*
549 (inverse-relative-transform)
550 (get-thread-bindings)))
552 (defn- add-node [tree node]
553 (assoc-cons tree (:parent node) node))
555 (defn- nodes [tree]
556 (apply concat (vals tree)))
558 (defn- under-cursor
559 "Returns a vector of child nodes under cursor."
560 [x y tree node]
561 (some #(if (.contains ^Shape (:clip %) x y)
562 (conj (vec (under-cursor x y tree %)) %))
563 (get tree node)))
565 (defn- remove-all [coll1 coll2 pred]
566 (filter #(not (some (partial pred %) coll2)) coll1))
568 (defn- translate-mouse-event [^java.awt.event.MouseEvent event
569 ^AffineTransform tr id]
570 (let [[x y] (transform-point tr (.getX event) (.getY event))
571 rotation (if (instance? MouseWheelEvent event)
572 (.getWheelRotation ^MouseWheelEvent event)
573 nil)]
574 (MouseEvent. id (.getWhen event) x y
575 (.getXOnScreen event) (.getYOnScreen event)
576 (.getButton event)
577 rotation)))
579 (defn- translate-and-dispatch
580 ([nodes first-only ^java.awt.event.MouseEvent event]
581 (translate-and-dispatch nodes first-only
582 event (awt-events (.getID event))))
583 ([nodes first-only event id]
584 (if-let [node (first nodes)]
585 (if-let [handler (get (:handlers node) id)]
586 (do
587 (let [translated (translate-mouse-event event (:transform node) id)]
588 (with-bindings* (:bindings node)
589 handler translated))
590 (if-not first-only
591 (recur (rest nodes) false event id)))
592 (recur (rest nodes) first-only event id)))))
594 (defn- dispatch-mouse-motion
595 "Dispatches mouse motion events."
596 [hovered-ref tree root ^java.awt.event.MouseEvent event]
597 (let [x (.getX event)
598 y (.getY event)
599 [hovered hovered2] (dosync
600 [@hovered-ref
601 (ref-set hovered-ref
602 (under-cursor x y tree root))])
603 pred #(= (:handle %1) (:handle %2))
604 exited (remove-all hovered hovered2 pred)
605 entered (remove-all hovered2 hovered pred)
606 moved (remove-all hovered2 entered pred)]
607 (translate-and-dispatch exited false event :mouse-exited)
608 (translate-and-dispatch entered false event :mouse-entered)
609 (translate-and-dispatch moved true event :mouse-moved)))
611 (defn- dispatch-mouse-button
612 [picked-ref hovered-ref ^java.awt.event.MouseEvent event]
613 (let [id (awt-events (.getID event))
614 nodes (case id
615 :mouse-pressed
616 (dosync
617 (ref-set picked-ref @hovered-ref))
618 :mouse-released
619 (dosync
620 (let [picked @picked-ref]
621 (ref-set picked-ref nil)
622 picked))
623 @hovered-ref)]
624 (translate-and-dispatch nodes true event id)))
626 (defn root-event-dispatcher []
627 (let [tree-r (ref {}) ; register
628 tree (ref {}) ; dispatch
629 hovered (ref '())
630 picked (ref '())]
631 (reify
632 EventDispatcher
633 (listen! [this component]
634 (doto ^Component component
635 (.addMouseListener this)
636 (.addMouseWheelListener this)
637 (.addMouseMotionListener this)))
638 (create-dispatcher [this handle handlers]
639 (let [node (make-node handle handlers)]
640 (dosync (alter tree-r add-node node))
641 node))
642 (commit [this]
643 ;; TODO: retain contexts that do not intersect graphics
644 ;; clipping area in tree.
645 (dosync (ref-set tree @tree-r)
646 (ref-set tree-r {})))
647 (handle-picked? [this handle]
648 (some #(= handle (:handle %)) @picked))
649 (handle-hovered? [this handle]
650 (some #(= handle (:handle %)) @hovered))
651 MouseListener
652 (mouseEntered [this event]
653 (dispatch-mouse-motion hovered @tree this event))
654 (mouseExited [this event]
655 (dispatch-mouse-motion hovered @tree this event))
656 (mouseClicked [this event]
657 (dispatch-mouse-button picked hovered event))
658 (mousePressed [this event]
659 (dispatch-mouse-button picked hovered event))
660 (mouseReleased [this event]
661 (dispatch-mouse-button picked hovered event))
662 MouseWheelListener
663 (mouseWheelMoved [this event]
664 (dispatch-mouse-button picked hovered event))
665 MouseMotionListener
666 (mouseDragged [this event]
667 (translate-and-dispatch @picked true event))
668 (mouseMoved [this event]
669 (dispatch-mouse-motion hovered @tree this event)))))