view src/net/kryshen/indyvon/core.clj @ 95:df9dedc80485

Atomic add-observer.
author Mikhail Kryshen <mikhail@kryshen.net>
date Thu, 03 Mar 2011 03:20:23 +0300
parents dd7b8dbb20bc
children 72821bd32e2e
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 (java.awt.font FontRenderContext)
26 java.util.concurrent.ConcurrentMap
27 com.google.common.collect.MapMaker))
29 ;;
30 ;; Layer context
31 ;;
33 (def ^Graphics2D *graphics*)
35 (def ^FontRenderContext *font-context*)
37 (def ^{:tag Component
38 :doc "Target AWT component, may be nil if drawing off-screen."}
39 *target*)
41 (def ^{:doc "Width of the rendering area."}
42 *width*)
44 (def ^{:doc "Height of the rendering area."}
45 *height*)
47 (def ^Shape *clip*)
49 (def ^{:doc "The root (background) layer of the scene."}
50 *root*)
52 (def ^{:doc "Time in nanoseconds when the rendering of the current
53 frame starts."}
54 *time*)
56 (def *event-dispatcher*)
58 (def ^{:tag AffineTransform
59 :doc "Initial transform associated with the graphics context."}
60 *initial-transform*)
62 (def ^{:tag AffineTransform
63 :doc "Inversion of the initial transform associated with
64 the graphics context."}
65 *inverse-initial-transform*)
67 (defrecord Theme [fore-color back-color alt-back-color border-color font])
69 ;; REMIND: use system colors, see java.awt.SystemColor.
70 (defn default-theme []
71 (Theme. Color/BLACK Color/WHITE Color/LIGHT_GRAY
72 Color/BLUE (Font. "Sans" Font/PLAIN 12)))
74 (def *theme* (default-theme))
76 (defrecord Location [x y])
77 (defrecord Size [width height])
78 (defrecord Bounds [x y width height])
80 ;;
81 ;; Core protocols and types
82 ;;
84 (defprotocol Layer
85 "Basic UI element."
86 (render! [this])
87 (layer-size [this]))
89 ;; TODO: modifiers
90 (defrecord MouseEvent [id when x y x-on-screen y-on-screen button])
92 ;; TODO: KeyEvent
94 (defprotocol EventDispatcher
95 (listen! [this ^Component component]
96 "Listen for events on the specified AWT Component.")
97 (create-dispatcher [this handle handlers]
98 "Returns new event dispatcher associated with the specified event
99 handlers (an event-id -> handler-fn map). Handle is used to
100 match the contexts between commits.")
101 (commit [this]
102 "Apply the registered handlers for event processing.")
103 (handle-picked? [this handle]
104 "Returns true if the specified handle received the :mouse-pressed
105 event and have not yet received :moused-released.")
106 (handle-hovered? [this handle]
107 "Returns true if the specified handle received the :mouse-entered
108 event and have not yet received :mouse-exited."))
110 (defprotocol Anchored
111 "Provide anchor point for Layers. Used by viewport."
112 (anchor [this h-align v-align]
113 "Anchor point: [x y], h-align could be :left, :center or :right,
114 v-align is :top, :center or :bottom"))
116 (defn default-anchor [layer h-align v-align]
117 (if (and (= h-align :left)
118 (= v-align :top))
119 (Location. 0 0)
120 (let [size (layer-size layer)]
121 (Location.
122 (case h-align
123 :top 0
124 :center (/ (:width size) 2)
125 :right (:width size))
126 (case v-align
127 :left 0
128 :center (/ (:height size) 2)
129 :bottom (:height size))))))
131 ;; Default implementation of Anchored for any Layer.
132 (extend-protocol Anchored
133 net.kryshen.indyvon.core.Layer
134 (anchor [this h-align v-align]
135 (default-anchor this h-align v-align)))
137 (defn- assoc-cons [m key val]
138 (->> (get m key) (cons val) (assoc m key)))
140 ;;
141 ;; Observers
142 ;; The mechanism used by layers to request repaints
143 ;;
145 (def ^ConcurrentMap observers
146 (-> (MapMaker.) (.weakKeys) (.makeMap)))
148 (defn- cm-replace!
149 "Wrap ConcurrentMap replace method to treat nil value as absent
150 mapping. Use with maps that does not support nil values."
151 [^ConcurrentMap cmap key old new]
152 (if (nil? old)
153 (nil? (.putIfAbsent cmap key new))
154 (.replace cmap key old new)))
156 (defn- cm-swap!
157 "Atomically swaps the value associated with key in ConcurrentMap
158 to be (apply f current-value args). Returns the new value."
159 [cmap key f & args]
160 (loop []
161 (let [old (.get cmap key)
162 new (apply f old args)]
163 (if (cm-replace! cmap key old new)
164 new
165 (recur)))))
167 (defn add-observer
168 "Add observer fn for the target. Watcher identifies the group of
169 observers and could be used to remove the group. Watcher is weakly
170 referenced, all associated observers will be removed when the
171 wathcer is removed by gc. The observer fn will be called with
172 watcher and target arguments and any additional arguments specified
173 in update call."
174 [watcher target f]
175 (cm-swap! observers watcher assoc-cons target f)
176 nil)
178 (defn remove-observers
179 "Remove group of observers associated with the specified watcher."
180 [watcher]
181 (.remove observers watcher)
182 nil)
184 (defn- replace-observers-watcher
185 [old-watcher new-watcher]
186 (if-let [old (.remove observers old-watcher)]
187 (.put observers new-watcher old))
188 nil)
190 (defn update
191 "Notify observers."
192 [target & args]
193 (doseq [entry observers
194 f (get (val entry) target)]
195 (apply f (key entry) target args)))
197 (defn add-context-observer
198 "Observer registered with this function will be automatically
199 removed after the next frame rendering is complete."
200 [target f]
201 (let [root *root*]
202 (add-observer root target f)))
204 (defn repaint-on-update
205 "Trigger repaint of the current scene when the target updates."
206 [target]
207 (let [root *root*]
208 (if (not= root target)
209 (add-observer root target (fn [w _] (update w))))))
211 (defn repaint
212 "Repaint the current scene."
213 []
214 (update *root*))
216 ;;
217 ;; Rendering
218 ;;
220 (defn relative-transform
221 "Returns AffineTransform: layer context -> AWT component."
222 []
223 (let [tr (.getTransform *graphics*)]
224 (.preConcatenate tr *inverse-initial-transform*)
225 tr))
227 (defn inverse-relative-transform
228 "Returns AffineTransform: AWT component -> layer context."
229 []
230 (let [tr (.getTransform *graphics*)]
231 (.invert tr) ; absolute -> layer
232 (.concatenate tr *initial-transform*) ; component -> absolute
233 tr))
235 (defn transform-point [^AffineTransform tr x y]
236 (let [p (Point2D$Double. x y)]
237 (.transform tr p p)
238 [(.x p) (.y p)]))
240 ;; (defn- clip
241 ;; "Intersect clipping area with the specified shape or bounds.
242 ;; Returns new clip (Shape or nil if empty)."
243 ;; ([x y w h]
244 ;; (clip (Rectangle2D$Double. x y w h)))
245 ;; ([shape]
246 ;; (let [a1 (Area. shape)
247 ;; a2 (if (instance? Area *clip*) *clip* (Area. *clip*))]
248 ;; (.transform a1 (relative-transform))
249 ;; (.intersect a1 a2)
250 ;; (if (.isEmpty a1)
251 ;; nil
252 ;; a1))))
254 ;; Use faster clipping calculation provided by Graphics2D.
255 (defn- clip
256 "Intersect clipping area with the specified bounds in current
257 transform coordinates. Returns new clip in the AWT component
258 coordinates (Shape or nil if empty)."
259 [x y w h]
260 (let [^Graphics2D clip-g (.create *graphics*)]
261 (doto clip-g
262 (.setClip x y w h)
263 (.setTransform *initial-transform*)
264 (.clip *clip*))
265 (try
266 (if (.isEmpty (.getClipBounds clip-g))
267 nil
268 (.getClip clip-g))
269 (finally
270 (.dispose clip-g)))))
272 (defn- ^Graphics2D apply-theme
273 "Set graphics' color and font to match theme.
274 Modifies and returns the first argument."
275 ([]
276 (apply-theme *graphics* *theme*))
277 ([^Graphics2D graphics theme]
278 (doto graphics
279 (.setColor (:fore-color theme))
280 (.setFont (:font theme)))))
282 (defn- ^Graphics2D create-graphics
283 ([]
284 (create-graphics 0 0 *width* *height*))
285 ([x y w h]
286 (apply-theme (.create *graphics* x y w h) *theme*)))
288 (defn with-bounds*
289 [x y w h f & args]
290 (when-let [clip (clip x y w h)]
291 (let [graphics (create-graphics x y w h)]
292 (try
293 (binding [*width* w
294 *height* h
295 *clip* clip
296 *graphics* graphics]
297 (apply f args))
298 (finally
299 (.dispose graphics))))))
301 (defmacro with-bounds
302 [x y w h & body]
303 `(with-bounds* ~x ~y ~w ~h (fn [] ~@body)))
305 (defmacro with-theme
306 [theme & body]
307 `(binding [*theme* (merge *theme* ~theme)]
308 ~@body))
310 (defmacro with-color
311 [color-or-keyword & body]
312 (let [color-form (if (keyword? color-or-keyword)
313 `(~color-or-keyword *theme*)
314 color-or-keyword)]
315 `(let [color# ~color-form
316 old-color# (.getColor *graphics*)]
317 (try
318 (.setColor *graphics* color#)
319 ~@body
320 (finally
321 (.setColor *graphics* old-color#))))))
323 ;; TODO: constructor for AffineTransform.
324 ;; (transform :scale 0.3 0.5
325 ;; :translate 5 10
326 ;; :rotate (/ Math/PI 2))
328 (defmacro with-transform [transform & body]
329 `(let [old-t# (.getTransform *graphics*)]
330 (try
331 (.transform *graphics* ~transform)
332 ~@body
333 (finally
334 (.setTransform *graphics* old-t#)))))
336 (defmacro with-rotate [theta ax ay & body]
337 `(let [transform# (AffineTransform/getRotateInstance ~theta ~ax ~ay)]
338 (with-transform transform# ~@body)))
340 (defn draw!
341 "Draws layer."
342 ([layer]
343 (let [graphics (create-graphics)]
344 (try
345 (binding [*graphics* graphics]
346 (render! layer))
347 (finally
348 (.dispose graphics)))))
349 ([layer x y]
350 (let [size (layer-size layer)]
351 (draw! layer x y (:width size) (:height size))))
352 ([layer x y width height]
353 (with-bounds* x y width height render! layer)))
355 (defn draw-anchored!
356 "Draws layer. Location is relative to the layer's anchor point for
357 the specified alignment."
358 ([layer h-align v-align x y]
359 (let [anchor (anchor layer h-align v-align)]
360 (draw! layer (- x (:x anchor)) (- y (:y anchor)))))
361 ([layer h-align v-align x y w h]
362 (let [anchor (anchor layer h-align v-align)]
363 (draw! layer (- x (:x anchor)) (- y (:y anchor)) w h))))
365 (defn draw-root!
366 "Draws the root layer."
367 ([layer graphics width height event-dispatcher]
368 (draw-root! layer graphics width height event-dispatcher nil))
369 ([layer ^Graphics2D graphics width height event-dispatcher target]
370 (binding [*root* layer
371 *target* target
372 *graphics* graphics
373 *font-context* (.getFontRenderContext graphics)
374 *initial-transform* (.getTransform graphics)
375 *inverse-initial-transform*
376 (-> graphics .getTransform .createInverse)
377 *event-dispatcher* event-dispatcher
378 *width* width
379 *height* height
380 *clip* (Rectangle2D$Double. 0 0 width height)
381 *time* (System/nanoTime)]
382 ;; (.setRenderingHint graphics
383 ;; RenderingHints/KEY_INTERPOLATION
384 ;; RenderingHints/VALUE_INTERPOLATION_BILINEAR)
385 ;; (.setRenderingHint graphics
386 ;; RenderingHints/KEY_ALPHA_INTERPOLATION
387 ;; RenderingHints/VALUE_ALPHA_INTERPOLATION_QUALITY)
388 ;; (.setRenderingHint graphics
389 ;; RenderingHints/KEY_ANTIALIASING
390 ;; RenderingHints/VALUE_ANTIALIAS_ON)
391 (apply-theme)
392 (let [tmp-watcher (Object.)]
393 ;; Keep current context observers until the rendering is
394 ;; complete. Some observers may be invoked twice if they
395 ;; appear in both groups until tmp-watcher is removed.
396 (replace-observers-watcher layer tmp-watcher)
397 (try
398 (render! layer)
399 (finally
400 (remove-observers tmp-watcher)
401 (commit event-dispatcher)))))))
403 (defn root-size
404 ([layer font-context]
405 (root-size layer font-context nil))
406 ([layer font-context target]
407 (binding [*root* layer
408 *target* target
409 *font-context* font-context]
410 (layer-size layer))))
412 ;;
413 ;; Event handling.
414 ;;
416 (defn with-handlers*
417 [handle handlers f & args]
418 (binding [*event-dispatcher* (create-dispatcher
419 *event-dispatcher* handle handlers)]
420 (apply f args)))
422 (defmacro with-handlers
423 "specs => (:event-id name & handler-body)*
425 Execute form with the specified event handlers."
426 [handle form & specs]
427 `(with-handlers* ~handle
428 ~(reduce (fn [m spec]
429 (assoc m (first spec)
430 `(fn [~(second spec)]
431 ~@(nnext spec)))) {}
432 specs)
433 (fn [] ~form)))
435 (defn picked? [handle]
436 (handle-picked? *event-dispatcher* handle))
438 (defn hovered? [handle]
439 (handle-hovered? *event-dispatcher* handle))
442 ;;
443 ;; EventDispatcher implementation
444 ;;
446 (def awt-events
447 {java.awt.event.MouseEvent/MOUSE_CLICKED :mouse-clicked
448 java.awt.event.MouseEvent/MOUSE_DRAGGED :mouse-dragged
449 java.awt.event.MouseEvent/MOUSE_ENTERED :mouse-entered
450 java.awt.event.MouseEvent/MOUSE_EXITED :mouse-exited
451 java.awt.event.MouseEvent/MOUSE_MOVED :mouse-moved
452 java.awt.event.MouseEvent/MOUSE_PRESSED :mouse-pressed
453 java.awt.event.MouseEvent/MOUSE_RELEASED :mouse-released})
455 (def dummy-event-dispatcher
456 (reify
457 EventDispatcher
458 (listen! [this component])
459 (create-dispatcher [this handle handlers] this)
460 (commit [this])
461 (handle-picked? [this handle])
462 (handle-hovered? [this handle])))
464 (defrecord DispatcherNode [handle handlers parent
465 ^Shape clip ^AffineTransform transform
466 bindings]
467 EventDispatcher
468 (listen! [this component]
469 (listen! parent component))
470 (create-dispatcher [this handle handlers]
471 (create-dispatcher parent handle handlers))
472 (commit [this]
473 (commit parent))
474 (handle-picked? [this handle]
475 (handle-picked? parent handle))
476 (handle-hovered? [this handle]
477 (handle-hovered? parent handle)))
479 (defn- make-node [handle handlers]
480 (DispatcherNode. handle handlers *event-dispatcher* *clip*
481 (inverse-relative-transform)
482 (get-thread-bindings)))
484 (defn- add-node [tree node]
485 (assoc-cons tree (:parent node) node))
487 (defn- under-cursor
488 "Returns a vector of child nodes under cursor."
489 [x y tree node]
490 (some #(if (.contains ^Shape (:clip %) x y)
491 (conj (vec (under-cursor x y tree %)) %))
492 (get tree node)))
494 (defn- remove-all [coll1 coll2 pred]
495 (filter #(not (some (partial pred %) coll2)) coll1))
497 (defn- translate-mouse-event [^java.awt.event.MouseEvent event
498 ^AffineTransform tr id]
499 (let [[x y] (transform-point tr (.getX event) (.getY event))]
500 (MouseEvent. id (.getWhen event) x y
501 (.getXOnScreen event) (.getYOnScreen event)
502 (.getButton event))))
504 (defn- translate-and-dispatch
505 ([nodes first-only ^java.awt.event.MouseEvent event]
506 (translate-and-dispatch nodes first-only
507 event (awt-events (.getID event))))
508 ([nodes first-only event id]
509 (if-let [node (first nodes)]
510 (if-let [handler (get (:handlers node) id)]
511 (do
512 (with-bindings* (:bindings node)
513 handler
514 (translate-mouse-event event (:transform node) id))
515 (if-not first-only
516 (recur (rest nodes) false event id)))
517 (recur (rest nodes) first-only event id)))))
519 (defn- dispatch-mouse-motion
520 "Dispatches mouse motion events."
521 [hovered-ref tree root ^java.awt.event.MouseEvent event]
522 (let [x (.getX event)
523 y (.getY event)
524 [hovered hovered2] (dosync
525 [@hovered-ref
526 (ref-set hovered-ref
527 (under-cursor x y tree root))])
528 pred #(= (:handle %1) (:handle %2))
529 exited (remove-all hovered hovered2 pred)
530 entered (remove-all hovered2 hovered pred)
531 moved (remove-all hovered2 entered pred)]
532 (translate-and-dispatch exited false event :mouse-exited)
533 (translate-and-dispatch entered false event :mouse-entered)
534 (translate-and-dispatch moved true event :mouse-moved)))
536 (defn- dispatch-mouse-button
537 [picked-ref hovered-ref ^java.awt.event.MouseEvent event]
538 (let [id (awt-events (.getID event))
539 nodes (case id
540 :mouse-pressed
541 (dosync
542 (ref-set picked-ref @hovered-ref))
543 :mouse-released
544 (dosync
545 (let [picked @picked-ref]
546 (ref-set picked-ref nil)
547 picked))
548 @hovered-ref)]
549 (translate-and-dispatch nodes true event id)))
551 (defn root-event-dispatcher []
552 (let [tree-r (ref {}) ; register
553 tree (ref {}) ; dispatch
554 hovered (ref '())
555 picked (ref '())]
556 (reify
557 EventDispatcher
558 (listen! [this component]
559 (doto component
560 (.addMouseListener this)
561 (.addMouseMotionListener this)))
562 (create-dispatcher [this handle handlers]
563 (let [node (make-node handle handlers)]
564 (dosync (alter tree-r add-node node))
565 node))
566 (commit [this]
567 (dosync (ref-set tree @tree-r)
568 (ref-set tree-r {})))
569 (handle-picked? [this handle]
570 (some #(= handle (:handle %)) @picked))
571 (handle-hovered? [this handle]
572 (some #(= handle (:handle %)) @hovered))
573 MouseListener
574 (mouseEntered [this event]
575 (dispatch-mouse-motion hovered @tree this event))
576 (mouseExited [this event]
577 (dispatch-mouse-motion hovered @tree this event))
578 (mouseClicked [this event]
579 (dispatch-mouse-button picked hovered event))
580 (mousePressed [this event]
581 (dispatch-mouse-button picked hovered event))
582 (mouseReleased [this event]
583 (dispatch-mouse-button picked hovered event))
584 MouseMotionListener
585 (mouseDragged [this event]
586 (translate-and-dispatch @picked true event))
587 (mouseMoved [this event]
588 (dispatch-mouse-motion hovered @tree this event)))))