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