Mercurial > hg > indyvon

view src/net/kryshen/indyvon/core.clj @ 104:491152048c89

find changesets by author, revision, files, or words in the commit message
Added Scene record to enclose state retained between repaints.
author Mikhail Kryshen <mikhail@kryshen.net>
date Thu, 19 May 2011 20:10:45 +0400
parents fd8fb8a3ff5a
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 ;;
19
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))
30
31 ;;
32 ;; Layer context
33 ;;
34
35 (def ^{:dynamic true
36 :tag Graphics2D}
37 *graphics*)
38
39 (def ^{:dynamic true
40 :tag FontRenderContext}
41 *font-context*)
42
43 (def ^{:dynamic true
44 :tag Component
45 :doc "Target AWT component, may be nil if drawing off-screen."}
46 *target*)
47
48 (def ^{:dynamic true
49 :doc "Width of the rendering area."}
50 *width*)
51
52 (def ^{:dynamic true
53 :doc "Height of the rendering area."}
54 *height*)
55
56 (def ^{:dynamic true
57 :tag Shape}
58 *clip*)
59
60 (def ^{:dynamic true
61 :doc "Time in nanoseconds when the rendering of the current
62 frame starts."}
63 *time*)
64
65 (def ^{:dynamic true
66 :doc "Encloses state that should be retained between repaints."}
67 *scene*)
68
69 (def ^{:dynamic true}
70 *event-dispatcher*)
71
72 (def ^{:dynamic true
73 :tag AffineTransform
74 :doc "Initial transform associated with the graphics context."}
75 *initial-transform*)
76
77 (def ^{:dynamic true
78 :tag AffineTransform
79 :doc "Inversion of the initial transform associated with
80 the graphics context."}
81 *inverse-initial-transform*)
82
83 (defrecord Theme [fore-color back-color alt-back-color border-color
84 shadow-color font])
85
86 ;; REMIND: use system colors, see java.awt.SystemColor.
87 (defn default-theme []
88 (Theme. Color/BLACK
89 Color/WHITE
90 (Color. 0xC8 0xD2 0xD8)
91 (Color. 0 0 0xC8)
92 (Color. 0x44 0x44 0x44)
93 (Font. "Sans" Font/PLAIN 12)))
94
95 (def ^{:dynamic true} *theme* (default-theme))
96
97 (defrecord Location [x y])
98 (defrecord Size [width height])
99 (defrecord Bounds [x y width height])
100
101 ;;
102 ;; Core protocols and types
103 ;;
104
105 (defprotocol Layer
106 "Basic UI element."
107 (render! [this])
108 (layer-size [this]))
109
110 ;; TODO: modifiers
111 (defrecord MouseEvent [id when x y x-on-screen y-on-screen button
112 wheel-rotation])
113
114 ;; TODO: KeyEvent
115
116 (defprotocol EventDispatcher
117 (listen! [this component]
118 "Listen for events on the specified AWT Component.")
119 (create-dispatcher [this handle handlers]
120 "Returns new event dispatcher associated with the specified event
121 handlers (an event-id -> handler-fn map). Handle is used to
122 match the contexts between commits.")
123 (commit [this]
124 "Apply the registered handlers for event processing.")
125 (handle-picked? [this handle]
126 "Returns true if the specified handle received the :mouse-pressed
127 event and have not yet received :moused-released.")
128 (handle-hovered? [this handle]
129 "Returns true if the specified handle received the :mouse-entered
130 event and have not yet received :mouse-exited."))
131
132 (defprotocol Anchored
133 "Provide anchor point for Layers. Used by viewport."
134 (anchor [this h-align v-align]
135 "Anchor point: [x y], h-align could be :left, :center or :right,
136 v-align is :top, :center or :bottom"))
137
138 (defn default-anchor [layer h-align v-align]
139 (if (and (= h-align :left)
140 (= v-align :top))
141 (Location. 0 0)
142 (let [size (layer-size layer)]
143 (Location.
144 (case h-align
145 :left 0
146 :center (/ (:width size) 2)
147 :right (:width size))
148 (case v-align
149 :top 0
150 :center (/ (:height size) 2)
151 :bottom (:height size))))))
152
153 ;; Default implementation of Anchored for any Layer.
154 (extend-protocol Anchored
155 net.kryshen.indyvon.core.Layer
156 (anchor [this h-align v-align]
157 (default-anchor this h-align v-align)))
158
159 (defn- assoc-cons [m key val]
160 (->> (get m key) (cons val) (assoc m key)))
161
162 ;;
163 ;; Observers
164 ;; The mechanism used by layers to request repaints
165 ;;
166
167 (def ^ConcurrentMap observers
168 (-> (MapMaker.) (.weakKeys) (.makeMap)))
169
170 (defn- cm-replace!
171 "Wrap ConcurrentMap replace method to treat nil value as absent
172 mapping. Use with maps that does not support nil values."
173 [^ConcurrentMap cmap key old new]
174 (if (nil? old)
175 (nil? (.putIfAbsent cmap key new))
176 (.replace cmap key old new)))
177
178 (defn- cm-swap!
179 "Atomically swaps the value associated with key in ConcurrentMap
180 to be (apply f current-value args). Returns the new value."
181 [^ConcurrentMap cmap key f & args]
182 (loop []
183 (let [old (.get cmap key)
184 new (apply f old args)]
185 (if (cm-replace! cmap key old new)
186 new
187 (recur)))))
188
189 (defn add-observer
190 "Add observer fn for the target. Watcher identifies the group of
191 observers and could be used to remove the group. Watcher is weakly
192 referenced, all associated observers will be removed when the
193 wathcer is removed by gc. The observer fn will be called with
194 watcher and target arguments and any additional arguments specified
195 in update call."
196 [watcher target f]
197 (cm-swap! observers watcher assoc-cons target f)
198 nil)
199
200 (defn remove-observers
201 "Remove group of observers associated with the specified watcher."
202 [watcher]
203 (.remove observers watcher)
204 nil)
205
206 (defn- replace-observers-watcher
207 [old-watcher new-watcher]
208 (if-let [old (.remove observers old-watcher)]
209 (.put observers new-watcher old))
210 nil)
211
212 (defn update
213 "Notify observers."
214 [target & args]
215 (doseq [entry observers
216 f (get (val entry) target)]
217 (apply f (key entry) target args)))
218
219 (defn add-context-observer
220 "Observer registered with this function will be automatically
221 removed after the next repaint is complete."
222 [target f]
223 (add-observer *scene* target f))
224
225 (defn repaint-on-update
226 "Trigger repaint of the current scene when the target updates."
227 [target]
228 (let [scene *scene*]
229 (if-not (identical? scene target)
230 (add-observer scene target (fn [w _] (update w))))))
231
232 (defn repaint
233 "Repaint the current scene."
234 []
235 (update *scene*))
236
237 ;;
238 ;; Rendering
239 ;;
240
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))
247
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))
255
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)]))
260
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))))
274
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)))))
292
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)))))
302
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*)))
308
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)))))
320
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))))))
333
334 (defmacro with-bounds
335 [x y w h & body]
336 `(with-bounds* ~x ~y ~w ~h (fn [] ~@body)))
337
338 (defmacro with-theme
339 [theme & body]
340 `(binding [*theme* (merge *theme* ~theme)]
341 ~@body))
342
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#))))))
355
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)))
368
369 (defmacro with-hints
370 [hints & body]
371 `(with-hints ~hints (fn [] ~@body)))
372
373 ;; TODO: constructor for AffineTransform.
374 ;; (transform :scale 0.3 0.5
375 ;; :translate 5 10
376 ;; :rotate (/ Math/PI 2))
377
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#)))))
385
386 (defmacro with-rotate [theta ax ay & body]
387 `(let [transform# (AffineTransform/getRotateInstance ~theta ~ax ~ay)]
388 (with-transform transform# ~@body)))
389
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#))))))
398
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))))
419
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))))
429
430 ;;
431 ;; Event handling.
432 ;;
433
434 (defn with-handlers*
435 [handle handlers f & args]
436 (binding [*event-dispatcher* (create-dispatcher
437 *event-dispatcher* handle handlers)]
438 (apply f args)))
439
440 (defmacro with-handlers
441 "specs => (:event-id name & handler-body)*
442
443 Execute form with the specified event handlers."
444 [handle form & specs]
445 `(with-handlers* ~handle
446 ~(reduce (fn [m spec]
447 (assoc m (first spec)
448 `(fn [~(second spec)]
449 ~@(nnext spec)))) {}
450 specs)
451 (fn [] ~form)))
452
453 (defn picked? [handle]
454 (handle-picked? *event-dispatcher* handle))
455
456 (defn hovered? [handle]
457 (handle-hovered? *event-dispatcher* handle))
458
459 ;;
460 ;; EventDispatcher implementation
461 ;;
462
463 (def awt-events
464 {java.awt.event.MouseEvent/MOUSE_CLICKED :mouse-clicked
465 java.awt.event.MouseEvent/MOUSE_DRAGGED :mouse-dragged
466 java.awt.event.MouseEvent/MOUSE_ENTERED :mouse-entered
467 java.awt.event.MouseEvent/MOUSE_EXITED :mouse-exited
468 java.awt.event.MouseEvent/MOUSE_MOVED :mouse-moved
469 java.awt.event.MouseEvent/MOUSE_PRESSED :mouse-pressed
470 java.awt.event.MouseEvent/MOUSE_RELEASED :mouse-released
471 java.awt.event.MouseEvent/MOUSE_WHEEL :mouse-wheel})
472
473 (def dummy-event-dispatcher
474 (reify
475 EventDispatcher
476 (listen! [this component])
477 (create-dispatcher [this handle handlers] this)
478 (commit [this])
479 (handle-picked? [this handle])
480 (handle-hovered? [this handle])))
481
482 (defrecord DispatcherNode [handle handlers parent
483 ^Shape clip ^AffineTransform transform
484 bindings]
485 EventDispatcher
486 (listen! [this component]
487 (listen! parent component))
488 (create-dispatcher [this handle handlers]
489 (create-dispatcher parent handle handlers))
490 (commit [this]
491 (commit parent))
492 (handle-picked? [this handle]
493 (handle-picked? parent handle))
494 (handle-hovered? [this handle]
495 (handle-hovered? parent handle)))
496
497 (defn- make-node [handle handlers]
498 (DispatcherNode. handle handlers *event-dispatcher* *clip*
499 (inverse-relative-transform)
500 (get-thread-bindings)))
501
502 (defn- add-node [tree node]
503 (assoc-cons tree (:parent node) node))
504
505 (defn- nodes [tree]
506 (apply concat (vals tree)))
507
508 (defn- under-cursor
509 "Returns a vector of child nodes under cursor."
510 [x y tree node]
511 (some #(if (.contains ^Shape (:clip %) x y)
512 (conj (vec (under-cursor x y tree %)) %))
513 (get tree node)))
514
515 (defn- remove-all [coll1 coll2 pred]
516 (filter #(not (some (partial pred %) coll2)) coll1))
517
518 (defn- translate-mouse-event [^java.awt.event.MouseEvent event
519 ^AffineTransform tr id]
520 (let [[x y] (transform-point tr (.getX event) (.getY event))
521 rotation (if (instance? MouseWheelEvent event)
522 (.getWheelRotation ^MouseWheelEvent event)
523 nil)]
524 (MouseEvent. id (.getWhen event) x y
525 (.getXOnScreen event) (.getYOnScreen event)
526 (.getButton event)
527 rotation)))
528
529 (defn- translate-and-dispatch
530 ([nodes first-only ^java.awt.event.MouseEvent event]
531 (translate-and-dispatch nodes first-only
532 event (awt-events (.getID event))))
533 ([nodes first-only event id]
534 (if-let [node (first nodes)]
535 (if-let [handler (get (:handlers node) id)]
536 (do
537 (let [translated (translate-mouse-event event (:transform node) id)]
538 (with-bindings* (:bindings node)
539 handler translated))
540 (if-not first-only
541 (recur (rest nodes) false event id)))
542 (recur (rest nodes) first-only event id)))))
543
544 (defn- dispatch-mouse-motion
545 "Dispatches mouse motion events."
546 [hovered-ref tree root ^java.awt.event.MouseEvent event]
547 (let [x (.getX event)
548 y (.getY event)
549 [hovered hovered2] (dosync
550 [@hovered-ref
551 (ref-set hovered-ref
552 (under-cursor x y tree root))])
553 pred #(= (:handle %1) (:handle %2))
554 exited (remove-all hovered hovered2 pred)
555 entered (remove-all hovered2 hovered pred)
556 moved (remove-all hovered2 entered pred)]
557 (translate-and-dispatch exited false event :mouse-exited)
558 (translate-and-dispatch entered false event :mouse-entered)
559 (translate-and-dispatch moved true event :mouse-moved)))
560
561 (defn- dispatch-mouse-button
562 [picked-ref hovered-ref ^java.awt.event.MouseEvent event]
563 (let [id (awt-events (.getID event))
564 nodes (case id
565 :mouse-pressed
566 (dosync
567 (ref-set picked-ref @hovered-ref))
568 :mouse-released
569 (dosync
570 (let [picked @picked-ref]
571 (ref-set picked-ref nil)
572 picked))
573 @hovered-ref)]
574 (translate-and-dispatch nodes true event id)))
575
576 (defn root-event-dispatcher []
577 (let [tree-r (ref {}) ; register
578 tree (ref {}) ; dispatch
579 hovered (ref '())
580 picked (ref '())]
581 (reify
582 EventDispatcher
583 (listen! [this component]
584 (doto ^Component component
585 (.addMouseListener this)
586 (.addMouseWheelListener this)
587 (.addMouseMotionListener this)))
588 (create-dispatcher [this handle handlers]
589 (let [node (make-node handle handlers)]
590 (dosync (alter tree-r add-node node))
591 node))
592 (commit [this]
593 ;; TODO: retain contexts that do not intersect graphics
594 ;; clipping area in tree.
595 (dosync (ref-set tree @tree-r)
596 (ref-set tree-r {})))
597 (handle-picked? [this handle]
598 (some #(= handle (:handle %)) @picked))
599 (handle-hovered? [this handle]
600 (some #(= handle (:handle %)) @hovered))
601 MouseListener
602 (mouseEntered [this event]
603 (dispatch-mouse-motion hovered @tree this event))
604 (mouseExited [this event]
605 (dispatch-mouse-motion hovered @tree this event))
606 (mouseClicked [this event]
607 (dispatch-mouse-button picked hovered event))
608 (mousePressed [this event]
609 (dispatch-mouse-button picked hovered event))
610 (mouseReleased [this event]
611 (dispatch-mouse-button picked hovered event))
612 MouseWheelListener
613 (mouseWheelMoved [this event]
614 (dispatch-mouse-button picked hovered event))
615 MouseMotionListener
616 (mouseDragged [this event]
617 (translate-and-dispatch @picked true event))
618 (mouseMoved [this event]
619 (dispatch-mouse-motion hovered @tree this event)))))
620
621 ;;
622 ;; Scene
623 ;;
624
625 (defrecord Scene [layer event-dispatcher component])
626
627 (defn make-scene
628 ([layer]
629 (make-scene layer dummy-event-dispatcher nil))
630 ([layer event-dispatcher]
631 (make-scene layer event-dispatcher nil))
632 ([layer event-dispatcher component]
633 (Scene. layer event-dispatcher component)))
634
635 (defn draw-scene!
636 [scene ^Graphics2D graphics width height]
637 ;; (.setRenderingHint graphics
638 ;; RenderingHints/KEY_INTERPOLATION
639 ;; RenderingHints/VALUE_INTERPOLATION_BILINEAR)
640 ;; (.setRenderingHint graphics
641 ;; RenderingHints/KEY_ALPHA_INTERPOLATION
642 ;; RenderingHints/VALUE_ALPHA_INTERPOLATION_QUALITY)
643 ;; (.setRenderingHint graphics
644 ;; RenderingHints/KEY_ANTIALIASING
645 ;; RenderingHints/VALUE_ANTIALIAS_ON)
646 ;; (.setRenderingHint graphics
647 ;; RenderingHints/KEY_TEXT_ANTIALIASING
648 ;; RenderingHints/VALUE_TEXT_ANTIALIAS_ON)
649 (binding [*scene* scene
650 *graphics* graphics
651 *font-context* (.getFontRenderContext graphics)
652 *initial-transform* (.getTransform graphics)
653 *inverse-initial-transform* (-> graphics
654 .getTransform
655 .createInverse)
656 *event-dispatcher* (:event-dispatcher scene)
657 *width* width
658 *height* height
659 *clip* (Rectangle2D$Double. 0 0 width height)
660 *time* (System/nanoTime)]
661 (apply-theme)
662 (let [tmp-watcher (Object.)]
663 ;; Keep current context observers until the rendering is
664 ;; complete. Some observers may be invoked twice if they
665 ;; appear in both groups until tmp-watcher is removed.
666 (replace-observers-watcher scene tmp-watcher)
667 (try
668 (render! (:layer scene))
669 (finally
670 (remove-observers tmp-watcher)
671 (commit (:event-dispatcher scene)))))))
672
673 (defn scene-size [scene font-context]
674 (binding [*scene* scene
675 *font-context* font-context]
676 (layer-size (:layer scene))))
677
678 (defn set-cursor! [^Cursor cursor]
679 (when-let [^Component component (:component *scene*)]
680 (EventQueue/invokeLater #(.setCursor component cursor))))