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