view src/net/kryshen/indyvon/core.clj @ 67:a19cf5007d14

Asynchronous drawing.
author Mikhail Kryshen <mikhail@kryshen.net>
date Sat, 28 Aug 2010 02:37:30 +0400
parents a1999c1f7289
children 9b511fe09867
line source
1 ;;
2 ;; Copyright (C) 2010 Mikhail Kryshen <mikhail@kryshen.net>
3 ;;
4 ;; This file is part of Indyvon.
5 ;;
7 (ns net.kryshen.indyvon.core
8 (:import
9 (java.awt Graphics2D RenderingHints Component Color Font AWTEvent Shape)
10 (java.awt.geom AffineTransform Point2D$Double Rectangle2D$Double Area)
11 (java.awt.event MouseListener MouseMotionListener)
12 (java.awt.font FontRenderContext)))
14 ;;
15 ;; Layer context
16 ;;
18 (def ^Graphics2D *graphics*)
20 (def ^FontRenderContext *font-context*)
22 (def ^{:tag Component
23 :doc "Target AWT component, may be nil if drawing off-screen."}
24 *target*)
26 (def *width*)
28 (def *height*)
30 (def ^Shape *clip*)
32 (def *root*)
34 (def *event-dispatcher*)
36 (def ^{:tag AffineTransform
37 :doc "Initial transform associated with the graphics context"}
38 *initial-transform*)
40 (def ^{:tag AffineTransform
41 :doc "Inversion of the initial transform associated with
42 the graphics context"}
43 *inverse-initial-transform*)
45 (defrecord Theme [fore-color back-color alt-back-color border-color font])
47 ;; REMIND: use system colors, see java.awt.SystemColor.
48 (defn default-theme []
49 (Theme. Color/BLACK Color/LIGHT_GRAY Color/WHITE
50 Color/BLUE (Font. "Sans" Font/PLAIN 12)))
52 (def *theme* (default-theme))
54 (defrecord Location [x y])
55 (defrecord Size [width height])
56 (defrecord Bounds [x y width height])
58 ;;
59 ;; Core protocols and types
60 ;;
62 (defprotocol Layer
63 "Basic UI element."
64 (render! [this])
65 (layer-size [this]))
67 ;; TODO: modifiers
68 (defrecord MouseEvent [id when x y x-on-screen y-on-screen button])
70 (defprotocol EventDispatcher
71 (listen! [this ^Component component]
72 "Listen for events on the specified AWT Component.")
73 (create-dispatcher [this handle handlers]
74 "Returns new event dispatcher associated with the specified event
75 handlers (an event-id -> handler-fn map). Handle is used to
76 match the contexts between commits.")
77 (commit [this]
78 "Apply the registered handlers for event processing."))
80 (defprotocol Anchored
81 "Provide anchor point for Layers. Used by viewport."
82 (anchor [this h-align v-align]
83 "Anchor point: [x y], h-align could be :left, :center or :right,
84 v-align is :top, :center or :bottom"))
86 ;; Default implementation of Anchored for any Layer.
87 (extend-protocol Anchored
88 net.kryshen.indyvon.core.Layer
89 (anchor [this h-align v-align]
90 (if (and (= h-align :left)
91 (= v-align :top))
92 (Location. 0 0)
93 (let [size (layer-size this)]
94 (Location.
95 (case h-align
96 :top 0
97 :center (/ (:width size) 2)
98 :right (:width size))
99 (case v-align
100 :left 0
101 :center (/ (:height size) 2)
102 :bottom (:height size)))))))
104 (defn- assoc-cons [m key val]
105 (->> (get m key) (cons val) (assoc m key)))
107 (defn- assoc-in-cons [m keys val]
108 (->> (get-in m keys) (cons val) (assoc-in m keys)))
110 ;;
111 ;; Observers
112 ;;
114 (def observers (atom nil))
116 ;; TODO: groups should be weakly referenced.
117 ;; Need persistent analog to java.util.WeakHashMap.
118 (defn add-observer
119 "Add observer fn for the target to the specified group."
120 [group target f]
121 (swap! observers assoc-in-cons [group target] f)
122 nil)
124 (defn remove-observer-group
125 "Remove group of observers."
126 [group]
127 (swap! observers dissoc group)
128 nil)
130 ;; (defn- replace-observer-group*
131 ;; [observers old-id new-id]
132 ;; (let [group (get observers old-id)]
133 ;; (assoc (dissoc observers old-id)
134 ;; new-id group)))
136 ;; (defn- replace-observer-group
137 ;; [old-id new-id]
138 ;; (swap! observers replace-observer-group* old-id new-id))
140 (defn update
141 "Notify observers."
142 [target & args]
143 (doseq [f (reduce #(concat %1 (get %2 target)) nil (vals @observers))]
144 (apply f target args)))
146 (defn repaint
147 "Repaint the current scene."
148 []
149 (update *root*))
151 (defn add-context-observer
152 "Observer registered with this function will be automatically
153 removed after the next frame rendering is complete."
154 [target f]
155 (let [root *root*]
156 (add-observer root target f)))
158 (defn repaint-on-update
159 "Trigger repaint of the current scene when the target updates."
160 [target]
161 (let [root *root*]
162 (if (not= root target)
163 (add-observer root target (fn [_] (update root))))))
165 ;;
166 ;; Rendering
167 ;;
169 (defn- relative-transform
170 "AffineTransform: layer context -> awt component."
171 []
172 (let [tr (.getTransform *graphics*)]
173 (.preConcatenate tr *inverse-initial-transform*)
174 tr))
176 (defn- inverse-relative-transform
177 "AffineTransform: awt component -> layer context."
178 []
179 (let [tr (.getTransform *graphics*)]
180 (.invert tr) ; absolute -> layer
181 (.concatenate tr *initial-transform*) ; component -> absolute
182 tr))
184 (defn- clip
185 "Intersect clipping area with the specified shape or bounds.
186 Returns new clip (Shape or nil if empty)."
187 ([x y w h]
188 (clip (Rectangle2D$Double. x y w h)))
189 ([shape]
190 (let [a1 (Area. shape)
191 a2 (if (instance? Area *clip*) *clip* (Area. *clip*))]
192 (.transform a1 (relative-transform))
193 (.intersect a1 a2)
194 (if (.isEmpty a1)
195 nil
196 a1))))
198 (defn- ^Graphics2D apply-theme
199 "Set graphics' color and font to match theme.
200 Modifies and returns the first argument."
201 ([]
202 (apply-theme *graphics* *theme*))
203 ([^Graphics2D graphics theme]
204 (doto graphics
205 (.setColor (:fore-color theme))
206 (.setFont (:font theme)))))
208 (defn- ^Graphics2D create-graphics
209 ([]
210 (create-graphics 0 0 *width* *height*))
211 ([x y w h]
212 (apply-theme (.create *graphics* x y w h) *theme*)))
214 (defn with-bounds*
215 [x y w h f & args]
216 (when-let [clip (clip x y w h)]
217 (let [graphics (create-graphics x y w h)]
218 (try
219 (binding [*width* w
220 *height* h
221 *clip* clip
222 *graphics* graphics]
223 (apply f args))
224 (finally
225 (.dispose graphics))))))
227 (defmacro with-bounds
228 [x y w h & body]
229 `(with-bounds* ~x ~y ~w ~h (fn [] ~@body)))
231 (defn with-handlers*
232 [handle handlers f & args]
233 (binding
234 [*event-dispatcher* (create-dispatcher
235 *event-dispatcher* handle handlers)]
236 (apply f args)))
238 (defmacro with-handlers
239 "specs => (:event-id name & handler-body)*
241 Execute form with the specified event handlers."
242 [handle form & specs]
243 `(with-handlers* ~handle
244 ~(reduce (fn [m spec]
245 (assoc m (first spec)
246 `(fn [~(second spec)]
247 ~@(nnext spec)))) {}
248 specs)
249 (fn [] ~form)))
251 (defmacro with-theme
252 [theme & body]
253 `(binding [*theme* (merge *theme* ~theme)]
254 ~@body))
256 (defmacro with-color
257 [color & body]
258 `(let [color# (.getColor *graphics*)]
259 (try
260 (.setColor *graphics* ~color)
261 ~@body
262 (finally
263 (.setColor *graphics* color#)))))
265 ;; TODO:
266 ;;
267 ;; (with-transform
268 ;; (rotate ...)
269 ;; (draw ...)
270 ;; (scale ...)
271 ;; (draw ...))
273 (defmacro with-transform [transform & body]
274 `(let [old-t# (.getTransform *graphics*)]
275 (try
276 (.transform *graphics* ~transform)
277 ~@body
278 (finally
279 (.setTransform *graphics* old-t#)))))
281 (defmacro with-rotate [theta ax ay & body]
282 `(let [transform# (AffineTransform/getRotateInstance ~theta ~ax ~ay)]
283 (with-transform transform# ~@body)))
285 (defn- geometry-vec [geometry]
286 (if (vector? geometry)
287 geometry
288 [(:x geometry) (:y geometry) (:width geometry) (:height geometry)]))
290 (defn draw!
291 "Draws layer."
292 ([layer]
293 (let [graphics (create-graphics)]
294 (try
295 (binding [*graphics* graphics]
296 (render! layer))
297 (finally
298 (.dispose graphics)))))
299 ([layer x y]
300 (let [size (layer-size layer)]
301 (draw! layer x y (:width size) (:height size))))
302 ([layer x y width height]
303 (with-bounds* x y width height render! layer)))
305 (defn draw-anchored!
306 "Draws layer. Location is relative to the layer's anchor point for
307 the specified alignment."
308 ([layer h-align v-align x y]
309 (let [anchor (anchor layer h-align v-align)]
310 (draw! layer (- x (:x anchor)) (- y (:y anchor)))))
311 ([layer h-align v-align x y w h]
312 (let [anchor (anchor layer h-align v-align)]
313 (draw! layer (- x (:x anchor)) (- y (:y anchor)) w h))))
315 (defn draw-root!
316 "Draws the root layer."
317 ([layer graphics width height event-dispatcher]
318 (draw-root! layer graphics width height event-dispatcher nil))
319 ([layer ^Graphics2D graphics width height event-dispatcher target]
320 (binding [*root* layer
321 *target* target
322 *graphics* graphics
323 *font-context* (.getFontRenderContext graphics)
324 *initial-transform* (.getTransform graphics)
325 *inverse-initial-transform*
326 (-> graphics .getTransform .createInverse)
327 *event-dispatcher* event-dispatcher
328 *width* width
329 *height* height
330 *clip* (Rectangle2D$Double. 0 0 width height)]
331 ;; (.setRenderingHint graphics
332 ;; RenderingHints/KEY_INTERPOLATION
333 ;; RenderingHints/VALUE_INTERPOLATION_BILINEAR)
334 ;; (.setRenderingHint graphics
335 ;; RenderingHints/KEY_ALPHA_INTERPOLATION
336 ;; RenderingHints/VALUE_ALPHA_INTERPOLATION_QUALITY)
337 ;; (.setRenderingHint graphics
338 ;; RenderingHints/KEY_ANTIALIASING
339 ;; RenderingHints/VALUE_ANTIALIAS_ON)
340 (apply-theme)
341 (with-color (:back-color *theme*)
342 (.fillRect graphics 0 0 width height))
343 (remove-observer-group layer)
344 (try
345 (render! layer)
346 (finally
347 (commit event-dispatcher))))))
349 (defn root-size
350 ([layer font-context]
351 (root-size layer font-context nil))
352 ([layer font-context target]
353 (binding [*root* layer
354 *target* target
355 *font-context* font-context]
356 (layer-size layer))))
358 ;;
359 ;; EventDispatcher implementation
360 ;;
362 (def awt-events
363 {java.awt.event.MouseEvent/MOUSE_CLICKED :mouse-clicked
364 java.awt.event.MouseEvent/MOUSE_DRAGGED :mouse-dragged
365 java.awt.event.MouseEvent/MOUSE_ENTERED :mouse-entered
366 java.awt.event.MouseEvent/MOUSE_EXITED :mouse-exited
367 java.awt.event.MouseEvent/MOUSE_MOVED :mouse-moved
368 java.awt.event.MouseEvent/MOUSE_PRESSED :mouse-pressed
369 java.awt.event.MouseEvent/MOUSE_RELEASED :mouse-released})
371 (def dummy-event-dispatcher
372 (reify
373 EventDispatcher
374 (listen! [this component])
375 (create-dispatcher [this handle handlers] this)
376 (commit [this])))
378 (defrecord DispatcherNode [handle handlers parent
379 ^Shape clip ^AffineTransform transform
380 bindings]
381 EventDispatcher
382 (listen! [this component]
383 (listen! parent component))
384 (create-dispatcher [this handle handlers]
385 (create-dispatcher parent handle handlers))
386 (commit [this]
387 (commit parent)))
389 (defn- make-node [handle handlers]
390 (DispatcherNode. handle handlers *event-dispatcher* *clip*
391 (inverse-relative-transform)
392 (get-thread-bindings)))
394 (defn- add-node [tree node]
395 (assoc-cons tree (:parent node) node))
397 (defn- under-cursor
398 "Returns a vector of child nodes under cursor."
399 [x y tree node]
400 (some #(if (.contains ^Shape (:clip %) x y)
401 (conj (vec (under-cursor x y tree %)) %))
402 (get tree node)))
404 (defn- remove-all [coll1 coll2 pred]
405 (filter #(not (some (partial pred %) coll2)) coll1))
407 (defn- transform [^AffineTransform tr x y]
408 (let [p (Point2D$Double. x y)]
409 (.transform tr p p)
410 [(.x p) (.y p)]))
412 (defn- translate-mouse-event [^java.awt.event.MouseEvent event
413 ^AffineTransform tr id]
414 (let [[x y] (transform tr (.getX event) (.getY event))]
415 (MouseEvent. id (.getWhen event) x y
416 (.getXOnScreen event) (.getYOnScreen event)
417 (.getButton event))))
419 (defn- translate-and-dispatch
420 ([nodes first-only ^java.awt.event.MouseEvent event]
421 (translate-and-dispatch nodes first-only
422 event (awt-events (.getID event))))
423 ([nodes first-only event id]
424 (if-let [node (first nodes)]
425 (if-let [handler (get (:handlers node) id)]
426 (do
427 (with-bindings* (:bindings node)
428 handler
429 (translate-mouse-event event (:transform node) id))
430 (if-not first-only
431 (recur (rest nodes) false event id)))
432 (recur (rest nodes) first-only event id)))))
434 (defn- dispatch-mouse-motion
435 "Dispatches mouse motion events."
436 [hovered-ref tree root ^java.awt.event.MouseEvent event]
437 (let [x (.getX event)
438 y (.getY event)
439 [hovered hovered2] (dosync
440 [@hovered-ref
441 (ref-set hovered-ref
442 (under-cursor x y tree root))])
443 pred #(= (:handle %1) (:handle %2))
444 exited (remove-all hovered hovered2 pred)
445 entered (remove-all hovered2 hovered pred)
446 moved (remove-all hovered2 entered pred)]
447 (translate-and-dispatch exited false event :mouse-exited)
448 (translate-and-dispatch entered false event :mouse-entered)
449 (translate-and-dispatch moved true event :mouse-moved)))
451 (defn- dispatch-mouse-button
452 [picked-ref hovered-ref ^java.awt.event.MouseEvent event]
453 (let [id (awt-events (.getID event))
454 hovered (if (= id :mouse-pressed)
455 (dosync (ref-set picked-ref @hovered-ref))
456 @hovered-ref)]
457 (translate-and-dispatch hovered true event id)))
459 (defn root-event-dispatcher []
460 (let [tree-r (ref {}) ; register
461 tree (ref {}) ; dispatch
462 hovered (ref '())
463 picked (ref '())]
464 (reify
465 EventDispatcher
466 (listen! [this component]
467 (doto component
468 (.addMouseListener this)
469 (.addMouseMotionListener this)))
470 (create-dispatcher [this handle handlers]
471 (let [node (make-node handle handlers)]
472 (dosync (alter tree-r add-node node))
473 node))
474 (commit [this]
475 (dosync (ref-set tree @tree-r)
476 (ref-set tree-r {})))
477 MouseListener
478 (mouseEntered [this event]
479 (dispatch-mouse-motion hovered @tree this event))
480 (mouseExited [this event]
481 (dispatch-mouse-motion hovered @tree this event))
482 (mouseClicked [this event]
483 (dispatch-mouse-button picked hovered event))
484 (mousePressed [this event]
485 (dispatch-mouse-button picked hovered event))
486 (mouseReleased [this event]
487 (translate-and-dispatch @picked true event))
488 ;;(dispatch-mouse-button picked hovered event))
489 MouseMotionListener
490 (mouseDragged [this event]
491 (translate-and-dispatch @picked true event))
492 (mouseMoved [this event]
493 (dispatch-mouse-motion hovered @tree this event)))))
495 ;;
496 ;; ИДЕИ:
497 ;;
498 ;; Контекст: биндинги или запись?
499 ;;
500 ;; Установка обработчиков (в контексте слоя):
501 ;;
502 ;; (listen
503 ;; (:mouse-entered e
504 ;; ...)
505 ;; (:mouse-exited e
506 ;; ...))
507 ;;
508 ;; Не надо IMGUI.
509 ;; Построение сцены путем декорирования слоев:
510 ;;
511 ;; (listener
512 ;; (:action e (println e))
513 ;; (:mouse-dragged e (println e))
514 ;; (theme :font "Helvetica-14"
515 ;; (vbox
516 ;; (button (text-layer "Button 1"))
517 ;; (button (text-layer "Button 2")))))
518 ;;