Mercurial > hg > indyvon
view src/net/kryshen/indyvon/core.clj @ 81:5d2153e8a28d
Code cleanup.
| author | Mikhail Kryshen <mikhail@kryshen.net> |
|---|---|
| date | Thu, 02 Sep 2010 03:55:44 +0400 |
| parents | 5fd50e400124 |
| children | e718a69f7d99 |
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)))
27 ;;
28 ;; Layer context
29 ;;
31 (def ^Graphics2D *graphics*)
33 (def ^FontRenderContext *font-context*)
35 (def ^{:tag Component
36 :doc "Target AWT component, may be nil if drawing off-screen."}
37 *target*)
39 (def ^{:doc "Width of the rendering area."}
40 *width*)
42 (def ^{:doc "Height of the rendering area."}
43 *height*)
45 (def ^Shape *clip*)
47 (def ^{:doc "The root (background) layer of the scene."}
48 *root*)
50 (def ^{:doc "Time in nanoseconds when the rendering of the current
51 frame starts."}
52 *time*)
54 (def *event-dispatcher*)
56 (def ^{:tag AffineTransform
57 :doc "Initial transform associated with the graphics context."}
58 *initial-transform*)
60 (def ^{:tag AffineTransform
61 :doc "Inversion of the initial transform associated with
62 the graphics context."}
63 *inverse-initial-transform*)
65 (defrecord Theme [fore-color back-color alt-back-color border-color font])
67 ;; REMIND: use system colors, see java.awt.SystemColor.
68 (defn default-theme []
69 (Theme. Color/BLACK Color/WHITE Color/LIGHT_GRAY
70 Color/BLUE (Font. "Sans" Font/PLAIN 12)))
72 (def *theme* (default-theme))
74 (defrecord Location [x y])
75 (defrecord Size [width height])
76 (defrecord Bounds [x y width height])
78 ;;
79 ;; Core protocols and types
80 ;;
82 (defprotocol Layer
83 "Basic UI element."
84 (render! [this])
85 (layer-size [this]))
87 ;; TODO: modifiers
88 (defrecord MouseEvent [id when x y x-on-screen y-on-screen button])
90 ;; TODO: KeyEvent
92 (defprotocol EventDispatcher
93 (listen! [this ^Component component]
94 "Listen for events on the specified AWT Component.")
95 (create-dispatcher [this handle handlers]
96 "Returns new event dispatcher associated with the specified event
97 handlers (an event-id -> handler-fn map). Handle is used to
98 match the contexts between commits.")
99 (commit [this]
100 "Apply the registered handlers for event processing.")
101 (handle-picked? [this handle]
102 "Returns true if the specified handle received the :mouse-pressed
103 event and have not yet received :moused-released.")
104 (handle-hovered? [this handle]
105 "Returns true if the specified handle received the :mouse-entered
106 event and have not yet received :mouse-exited."))
108 (defprotocol Anchored
109 "Provide anchor point for Layers. Used by viewport."
110 (anchor [this h-align v-align]
111 "Anchor point: [x y], h-align could be :left, :center or :right,
112 v-align is :top, :center or :bottom"))
114 (defn default-anchor [layer h-align v-align]
115 (if (and (= h-align :left)
116 (= v-align :top))
117 (Location. 0 0)
118 (let [size (layer-size layer)]
119 (Location.
120 (case h-align
121 :top 0
122 :center (/ (:width size) 2)
123 :right (:width size))
124 (case v-align
125 :left 0
126 :center (/ (:height size) 2)
127 :bottom (:height size))))))
129 ;; Default implementation of Anchored for any Layer.
130 (extend-protocol Anchored
131 net.kryshen.indyvon.core.Layer
132 (anchor [this h-align v-align]
133 (default-anchor this h-align v-align)))
135 (defn- assoc-cons [m key val]
136 (->> (get m key) (cons val) (assoc m key)))
138 (defn- assoc-in-cons [m keys val]
139 (->> (get-in m keys) (cons val) (assoc-in m keys)))
141 ;;
142 ;; Observers
143 ;;
145 (def observers (atom nil))
147 ;; TODO: groups should be weakly referenced.
148 (defn add-observer
149 "Add observer fn for the target to the specified group."
150 [group target f]
151 (swap! observers assoc-in-cons [group target] f)
152 nil)
154 (defn remove-observer-group
155 "Remove group of observers."
156 [group]
157 (swap! observers dissoc group)
158 nil)
160 (defn- replace-observer-group*
161 [observers old-id new-id]
162 (let [group (get observers old-id)]
163 (assoc (dissoc observers old-id)
164 new-id group)))
166 (defn- replace-observer-group
167 [old-id new-id]
168 (swap! observers replace-observer-group* old-id new-id))
170 (defn update
171 "Notify observers."
172 [target & args]
173 (doseq [f (reduce #(concat %1 (get %2 target)) nil (vals @observers))]
174 (apply f target args)))
176 (defn add-context-observer
177 "Observer registered with this function will be automatically
178 removed after the next frame rendering is complete."
179 [target f]
180 (let [root *root*]
181 (add-observer root target f)))
183 (defn repaint-on-update
184 "Trigger repaint of the current scene when the target updates."
185 [target]
186 (let [root *root*]
187 (if (not= root target)
188 (add-observer root target (fn [_] (update root))))))
190 (defn repaint
191 "Repaint the current scene."
192 []
193 (update *root*))
195 ;;
196 ;; Rendering
197 ;;
199 (defn- relative-transform
200 "AffineTransform: layer context -> awt component."
201 []
202 (let [tr (.getTransform *graphics*)]
203 (.preConcatenate tr *inverse-initial-transform*)
204 tr))
206 (defn- inverse-relative-transform
207 "AffineTransform: awt component -> layer context."
208 []
209 (let [tr (.getTransform *graphics*)]
210 (.invert tr) ; absolute -> layer
211 (.concatenate tr *initial-transform*) ; component -> absolute
212 tr))
214 (defn- clip
215 "Intersect clipping area with the specified shape or bounds.
216 Returns new clip (Shape or nil if empty)."
217 ([x y w h]
218 (clip (Rectangle2D$Double. x y w h)))
219 ([shape]
220 (let [a1 (Area. shape)
221 a2 (if (instance? Area *clip*) *clip* (Area. *clip*))]
222 (.transform a1 (relative-transform))
223 (.intersect a1 a2)
224 (if (.isEmpty a1)
225 nil
226 a1))))
228 (defn- ^Graphics2D apply-theme
229 "Set graphics' color and font to match theme.
230 Modifies and returns the first argument."
231 ([]
232 (apply-theme *graphics* *theme*))
233 ([^Graphics2D graphics theme]
234 (doto graphics
235 (.setColor (:fore-color theme))
236 (.setFont (:font theme)))))
238 (defn- ^Graphics2D create-graphics
239 ([]
240 (create-graphics 0 0 *width* *height*))
241 ([x y w h]
242 (apply-theme (.create *graphics* x y w h) *theme*)))
244 (defn with-bounds*
245 [x y w h f & args]
246 (when-let [clip (clip x y w h)]
247 (let [graphics (create-graphics x y w h)]
248 (try
249 (binding [*width* w
250 *height* h
251 *clip* clip
252 *graphics* graphics]
253 (apply f args))
254 (finally
255 (.dispose graphics))))))
257 (defmacro with-bounds
258 [x y w h & body]
259 `(with-bounds* ~x ~y ~w ~h (fn [] ~@body)))
261 (defmacro with-theme
262 [theme & body]
263 `(binding [*theme* (merge *theme* ~theme)]
264 ~@body))
266 (defmacro with-color
267 [color-or-keyword & body]
268 (let [color-form (if (keyword? color-or-keyword)
269 `(~color-or-keyword *theme*)
270 color-or-keyword)]
271 `(let [color# ~color-form
272 old-color# (.getColor *graphics*)]
273 (try
274 (.setColor *graphics* color#)
275 ~@body
276 (finally
277 (.setColor *graphics* old-color#))))))
279 ;; TODO: constructor for AffineTransform.
280 ;; (transform :scale 0.3 0.5
281 ;; :translate 5 10
282 ;; :rotate (/ Math/PI 2))
284 (defmacro with-transform [transform & body]
285 `(let [old-t# (.getTransform *graphics*)]
286 (try
287 (.transform *graphics* ~transform)
288 ~@body
289 (finally
290 (.setTransform *graphics* old-t#)))))
292 (defmacro with-rotate [theta ax ay & body]
293 `(let [transform# (AffineTransform/getRotateInstance ~theta ~ax ~ay)]
294 (with-transform transform# ~@body)))
296 (defn draw!
297 "Draws layer."
298 ([layer]
299 (let [graphics (create-graphics)]
300 (try
301 (binding [*graphics* graphics]
302 (render! layer))
303 (finally
304 (.dispose graphics)))))
305 ([layer x y]
306 (let [size (layer-size layer)]
307 (draw! layer x y (:width size) (:height size))))
308 ([layer x y width height]
309 (with-bounds* x y width height render! layer)))
311 (defn draw-anchored!
312 "Draws layer. Location is relative to the layer's anchor point for
313 the specified alignment."
314 ([layer h-align v-align x y]
315 (let [anchor (anchor layer h-align v-align)]
316 (draw! layer (- x (:x anchor)) (- y (:y anchor)))))
317 ([layer h-align v-align x y w h]
318 (let [anchor (anchor layer h-align v-align)]
319 (draw! layer (- x (:x anchor)) (- y (:y anchor)) w h))))
321 (defn draw-root!
322 "Draws the root layer."
323 ([layer graphics width height event-dispatcher]
324 (draw-root! layer graphics width height event-dispatcher nil))
325 ([layer ^Graphics2D graphics width height event-dispatcher target]
326 (binding [*root* layer
327 *target* target
328 *graphics* graphics
329 *font-context* (.getFontRenderContext graphics)
330 *initial-transform* (.getTransform graphics)
331 *inverse-initial-transform*
332 (-> graphics .getTransform .createInverse)
333 *event-dispatcher* event-dispatcher
334 *width* width
335 *height* height
336 *clip* (Rectangle2D$Double. 0 0 width height)
337 *time* (System/nanoTime)]
338 ;; (.setRenderingHint graphics
339 ;; RenderingHints/KEY_INTERPOLATION
340 ;; RenderingHints/VALUE_INTERPOLATION_BILINEAR)
341 ;; (.setRenderingHint graphics
342 ;; RenderingHints/KEY_ALPHA_INTERPOLATION
343 ;; RenderingHints/VALUE_ALPHA_INTERPOLATION_QUALITY)
344 ;; (.setRenderingHint graphics
345 ;; RenderingHints/KEY_ANTIALIASING
346 ;; RenderingHints/VALUE_ANTIALIAS_ON)
347 (apply-theme)
348 (with-color (:back-color *theme*)
349 (.fillRect graphics 0 0 width height))
350 (let [tmp-group (Object.)]
351 ;; Keep current context observers until the rendering is complete.
352 ;; Some observers may be invoked twice if they appear in both
353 ;; groups until tmp-group is removed.
354 (replace-observer-group layer tmp-group)
355 (try
356 (render! layer)
357 (finally
358 (remove-observer-group tmp-group)
359 (commit event-dispatcher)))))))
361 (defn root-size
362 ([layer font-context]
363 (root-size layer font-context nil))
364 ([layer font-context target]
365 (binding [*root* layer
366 *target* target
367 *font-context* font-context]
368 (layer-size layer))))
370 ;;
371 ;; Event handling.
372 ;;
374 (defn with-handlers*
375 [handle handlers f & args]
376 (binding [*event-dispatcher* (create-dispatcher
377 *event-dispatcher* handle handlers)]
378 (apply f args)))
380 (defmacro with-handlers
381 "specs => (:event-id name & handler-body)*
383 Execute form with the specified event handlers."
384 [handle form & specs]
385 `(with-handlers* ~handle
386 ~(reduce (fn [m spec]
387 (assoc m (first spec)
388 `(fn [~(second spec)]
389 ~@(nnext spec)))) {}
390 specs)
391 (fn [] ~form)))
393 (defn picked? [handle]
394 (handle-picked? *event-dispatcher* handle))
396 (defn hovered? [handle]
397 (handle-hovered? *event-dispatcher* handle))
400 ;;
401 ;; EventDispatcher implementation
402 ;;
404 (def awt-events
405 {java.awt.event.MouseEvent/MOUSE_CLICKED :mouse-clicked
406 java.awt.event.MouseEvent/MOUSE_DRAGGED :mouse-dragged
407 java.awt.event.MouseEvent/MOUSE_ENTERED :mouse-entered
408 java.awt.event.MouseEvent/MOUSE_EXITED :mouse-exited
409 java.awt.event.MouseEvent/MOUSE_MOVED :mouse-moved
410 java.awt.event.MouseEvent/MOUSE_PRESSED :mouse-pressed
411 java.awt.event.MouseEvent/MOUSE_RELEASED :mouse-released})
413 (def dummy-event-dispatcher
414 (reify
415 EventDispatcher
416 (listen! [this component])
417 (create-dispatcher [this handle handlers] this)
418 (commit [this])
419 (handle-picked? [this handle])
420 (handle-hovered? [this handle])))
422 (defrecord DispatcherNode [handle handlers parent
423 ^Shape clip ^AffineTransform transform
424 bindings]
425 EventDispatcher
426 (listen! [this component]
427 (listen! parent component))
428 (create-dispatcher [this handle handlers]
429 (create-dispatcher parent handle handlers))
430 (commit [this]
431 (commit parent))
432 (handle-picked? [this handle]
433 (handle-picked? parent handle))
434 (handle-hovered? [this handle]
435 (handle-hovered? parent handle)))
437 (defn- make-node [handle handlers]
438 (DispatcherNode. handle handlers *event-dispatcher* *clip*
439 (inverse-relative-transform)
440 (get-thread-bindings)))
442 (defn- add-node [tree node]
443 (assoc-cons tree (:parent node) node))
445 (defn- under-cursor
446 "Returns a vector of child nodes under cursor."
447 [x y tree node]
448 (some #(if (.contains ^Shape (:clip %) x y)
449 (conj (vec (under-cursor x y tree %)) %))
450 (get tree node)))
452 (defn- remove-all [coll1 coll2 pred]
453 (filter #(not (some (partial pred %) coll2)) coll1))
455 (defn- transform [^AffineTransform tr x y]
456 (let [p (Point2D$Double. x y)]
457 (.transform tr p p)
458 [(.x p) (.y p)]))
460 (defn- translate-mouse-event [^java.awt.event.MouseEvent event
461 ^AffineTransform tr id]
462 (let [[x y] (transform tr (.getX event) (.getY event))]
463 (MouseEvent. id (.getWhen event) x y
464 (.getXOnScreen event) (.getYOnScreen event)
465 (.getButton event))))
467 (defn- translate-and-dispatch
468 ([nodes first-only ^java.awt.event.MouseEvent event]
469 (translate-and-dispatch nodes first-only
470 event (awt-events (.getID event))))
471 ([nodes first-only event id]
472 (if-let [node (first nodes)]
473 (if-let [handler (get (:handlers node) id)]
474 (do
475 (with-bindings* (:bindings node)
476 handler
477 (translate-mouse-event event (:transform node) id))
478 (if-not first-only
479 (recur (rest nodes) false event id)))
480 (recur (rest nodes) first-only event id)))))
482 (defn- dispatch-mouse-motion
483 "Dispatches mouse motion events."
484 [hovered-ref tree root ^java.awt.event.MouseEvent event]
485 (let [x (.getX event)
486 y (.getY event)
487 [hovered hovered2] (dosync
488 [@hovered-ref
489 (ref-set hovered-ref
490 (under-cursor x y tree root))])
491 pred #(= (:handle %1) (:handle %2))
492 exited (remove-all hovered hovered2 pred)
493 entered (remove-all hovered2 hovered pred)
494 moved (remove-all hovered2 entered pred)]
495 (translate-and-dispatch exited false event :mouse-exited)
496 (translate-and-dispatch entered false event :mouse-entered)
497 (translate-and-dispatch moved true event :mouse-moved)))
499 (defn- dispatch-mouse-button
500 [picked-ref hovered-ref ^java.awt.event.MouseEvent event]
501 (let [id (awt-events (.getID event))
502 nodes (case id
503 :mouse-pressed
504 (dosync
505 (ref-set picked-ref @hovered-ref))
506 :mouse-released
507 (dosync
508 (let [picked @picked-ref]
509 (ref-set picked-ref nil)
510 picked))
511 @hovered-ref)]
512 (translate-and-dispatch nodes true event id)))
514 (defn root-event-dispatcher []
515 (let [tree-r (ref {}) ; register
516 tree (ref {}) ; dispatch
517 hovered (ref '())
518 picked (ref '())]
519 (reify
520 EventDispatcher
521 (listen! [this component]
522 (doto component
523 (.addMouseListener this)
524 (.addMouseMotionListener this)))
525 (create-dispatcher [this handle handlers]
526 (let [node (make-node handle handlers)]
527 (dosync (alter tree-r add-node node))
528 node))
529 (commit [this]
530 (dosync (ref-set tree @tree-r)
531 (ref-set tree-r {})))
532 (handle-picked? [this handle]
533 (some #(= handle (:handle %)) @picked))
534 (handle-hovered? [this handle]
535 (some #(= handle (:handle %)) @hovered))
536 MouseListener
537 (mouseEntered [this event]
538 (dispatch-mouse-motion hovered @tree this event))
539 (mouseExited [this event]
540 (dispatch-mouse-motion hovered @tree this event))
541 (mouseClicked [this event]
542 (dispatch-mouse-button picked hovered event))
543 (mousePressed [this event]
544 (dispatch-mouse-button picked hovered event))
545 (mouseReleased [this event]
546 (dispatch-mouse-button picked hovered event))
547 MouseMotionListener
548 (mouseDragged [this event]
549 (translate-and-dispatch @picked true event))
550 (mouseMoved [this event]
551 (dispatch-mouse-motion hovered @tree this event)))))