Mercurial > hg > indyvon
view src/net/kryshen/indyvon/core.clj @ 65:fd1bcb67bc32
New mechanism for layers to trigger repaints.
| author | Mikhail Kryshen <mikhail@kryshen.net> |
|---|---|
| date | Fri, 27 Aug 2010 01:24:31 +0400 |
| parents | 702a4939312d |
| children | a1999c1f7289 |
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 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 (defn add-observer
117 ([target f]
118 (add-observer target f :default))
119 ([target f group-id]
120 (swap! observers assoc-in-cons [group-id target] f)
121 nil))
123 (defn remove-group
124 "Remove group of observers."
125 [group-id]
126 (swap! observers dissoc group-id)
127 nil)
129 (defn- change-group-id*
130 [observers old-id new-id]
131 (let [group (get observers old-id)]
132 (assoc (dissoc observers old-id)
133 new-id group)))
135 (defn- change-group-id
136 [old-id new-id]
137 (swap! observers change-group-id* old-id new-id))
139 (defn update
140 "Notify observers."
141 [target & args]
142 (doseq [f (reduce #(concat %1 (get %2 target)) nil (vals @observers))]
143 (apply f target args)))
145 (defn repaint
146 "Repaint the current scene."
147 []
148 (update *root*))
150 (defn add-context-observer
151 "Observer registered with this function will be automatically
152 removed after the next frame rendering is complete."
153 [target f]
154 (let [root *root*]
155 (add-observer target f root)))
157 (defn repaint-on-update
158 "Trigger repaint of the current scene when the target updates."
159 [target]
160 (let [root *root*]
161 (add-observer target (fn [_] (update root)) root)))
163 ;;
164 ;; Rendering
165 ;;
167 (defn- relative-transform
168 "AffineTransform: layer context -> awt component."
169 []
170 (let [tr (.getTransform *graphics*)]
171 (.preConcatenate tr *inverse-initial-transform*)
172 tr))
174 (defn- inverse-relative-transform
175 "AffineTransform: awt component -> layer context."
176 []
177 (let [tr (.getTransform *graphics*)]
178 (.invert tr) ; absolute -> layer
179 (.concatenate tr *initial-transform*) ; component -> absolute
180 tr))
182 (defn- clip
183 "Intersect clipping area with the specified shape or bounds.
184 Returns new clip (Shape or nil if empty)."
185 ([x y w h]
186 (clip (Rectangle2D$Double. x y w h)))
187 ([shape]
188 (let [a1 (Area. shape)
189 a2 (if (instance? Area *clip*) *clip* (Area. *clip*))]
190 (.transform a1 (relative-transform))
191 (.intersect a1 a2)
192 (if (.isEmpty a1)
193 nil
194 a1))))
196 (defn- ^Graphics2D apply-theme
197 "Set graphics' color and font to match theme.
198 Modifies and returns the first argument."
199 ([]
200 (apply-theme *graphics* *theme*))
201 ([^Graphics2D graphics theme]
202 (doto graphics
203 (.setColor (:fore-color theme))
204 (.setFont (:font theme)))))
206 (defn- ^Graphics2D create-graphics
207 ([]
208 (create-graphics 0 0 *width* *height*))
209 ([x y w h]
210 (apply-theme (.create *graphics* x y w h) *theme*)))
212 (defn with-bounds*
213 [x y w h f & args]
214 (when-let [clip (clip x y w h)]
215 (let [graphics (create-graphics x y w h)]
216 (try
217 (binding [*width* w
218 *height* h
219 *clip* clip
220 *graphics* graphics]
221 (apply f args))
222 (finally
223 (.dispose graphics))))))
225 (defmacro with-bounds
226 [x y w h & body]
227 `(with-bounds* ~x ~y ~w ~h (fn [] ~@body)))
229 (defn with-handlers*
230 [handle handlers f & args]
231 (binding
232 [*event-dispatcher* (create-dispatcher
233 *event-dispatcher* handle handlers)]
234 (apply f args)))
236 (defmacro with-handlers
237 "specs => (:event-id name & handler-body)*
239 Execute form with the specified event handlers."
240 [handle form & specs]
241 `(with-handlers* ~handle
242 ~(reduce (fn [m spec]
243 (assoc m (first spec)
244 `(fn [~(second spec)]
245 ~@(nnext spec)))) {}
246 specs)
247 (fn [] ~form)))
249 (defmacro with-theme
250 [theme & body]
251 `(binding [*theme* (merge *theme* ~theme)]
252 ~@body))
254 (defmacro with-color
255 [color & body]
256 `(let [color# (.getColor *graphics*)]
257 (try
258 (.setColor *graphics* ~color)
259 ~@body
260 (finally
261 (.setColor *graphics* color#)))))
263 ;; TODO:
264 ;;
265 ;; (with-transform
266 ;; (rotate ...)
267 ;; (draw ...)
268 ;; (scale ...)
269 ;; (draw ...))
271 (defmacro with-transform [transform & body]
272 `(let [old-t# (.getTransform *graphics*)]
273 (try
274 (.transform *graphics* ~transform)
275 ~@body
276 (finally
277 (.setTransform *graphics* old-t#)))))
279 (defmacro with-rotate [theta ax ay & body]
280 `(let [transform# (AffineTransform/getRotateInstance ~theta ~ax ~ay)]
281 (with-transform transform# ~@body)))
283 (defn- geometry-vec [geometry]
284 (if (vector? geometry)
285 geometry
286 [(:x geometry) (:y geometry) (:width geometry) (:height geometry)]))
288 (defn draw!
289 "Draws layer."
290 ([layer]
291 (let [graphics (create-graphics)]
292 (try
293 (binding [*graphics* graphics]
294 (render! layer))
295 (finally
296 (.dispose graphics)))))
297 ([layer x y]
298 (let [size (layer-size layer)]
299 (draw! layer x y (:width size) (:height size))))
300 ([layer x y width height]
301 (with-bounds* x y width height render! layer)))
303 (defn draw-anchored!
304 "Draws layer. Location is relative to the layer's anchor point for
305 the specified alignment."
306 ([layer h-align v-align x y]
307 (let [anchor (anchor layer h-align v-align)]
308 (draw! layer (- x (:x anchor)) (- y (:y anchor)))))
309 ([layer h-align v-align x y w h]
310 (let [anchor (anchor layer h-align v-align)]
311 (draw! layer (- x (:x anchor)) (- y (:y anchor)) w h))))
313 (defn draw-root!
314 "Draws the root layer."
315 ([layer graphics width height event-dispatcher]
316 (draw-root! layer graphics width height event-dispatcher nil))
317 ([layer ^Graphics2D graphics width height event-dispatcher target]
318 (binding [*root* layer
319 *target* target
320 *graphics* graphics
321 *font-context* (.getFontRenderContext graphics)
322 *initial-transform* (.getTransform graphics)
323 *inverse-initial-transform*
324 (-> graphics .getTransform .createInverse)
325 *event-dispatcher* event-dispatcher
326 *width* width
327 *height* height
328 *clip* (Rectangle2D$Double. 0 0 width height)]
329 (let [tmp-group (Object.)]
330 (apply-theme)
331 (.clearRect graphics 0 0 width height)
332 (change-group-id layer tmp-group)
333 (try
334 (render! layer)
335 (finally
336 (remove-group tmp-group)
337 (commit event-dispatcher)))))))
339 (defn root-size
340 ([layer font-context]
341 (root-size layer font-context nil))
342 ([layer font-context target]
343 (binding [*root* layer
344 *target* target
345 *font-context* font-context]
346 (layer-size layer))))
348 ;;
349 ;; EventDispatcher implementation
350 ;;
352 (def awt-events
353 {java.awt.event.MouseEvent/MOUSE_CLICKED :mouse-clicked
354 java.awt.event.MouseEvent/MOUSE_DRAGGED :mouse-dragged
355 java.awt.event.MouseEvent/MOUSE_ENTERED :mouse-entered
356 java.awt.event.MouseEvent/MOUSE_EXITED :mouse-exited
357 java.awt.event.MouseEvent/MOUSE_MOVED :mouse-moved
358 java.awt.event.MouseEvent/MOUSE_PRESSED :mouse-pressed
359 java.awt.event.MouseEvent/MOUSE_RELEASED :mouse-released})
361 (def dummy-event-dispatcher
362 (reify
363 EventDispatcher
364 (listen! [this component])
365 (create-dispatcher [this handle handlers] this)
366 (commit [this])))
368 (defrecord DispatcherNode [handle handlers parent
369 ^Shape clip ^AffineTransform transform
370 bindings]
371 EventDispatcher
372 (listen! [this component]
373 (listen! parent component))
374 (create-dispatcher [this handle handlers]
375 (create-dispatcher parent handle handlers))
376 (commit [this]
377 (commit parent)))
379 (defn- make-node [handle handlers]
380 (DispatcherNode. handle handlers *event-dispatcher* *clip*
381 (inverse-relative-transform)
382 (get-thread-bindings)))
384 (defn- add-node [tree node]
385 (assoc-cons tree (:parent node) node))
387 (defn- under-cursor
388 "Returns a vector of child nodes under cursor."
389 [x y tree node]
390 (some #(if (.contains ^Shape (:clip %) x y)
391 (conj (vec (under-cursor x y tree %)) %))
392 (get tree node)))
394 (defn- remove-all [coll1 coll2 pred]
395 (filter #(not (some (partial pred %) coll2)) coll1))
397 (defn- transform [^AffineTransform tr x y]
398 (let [p (Point2D$Double. x y)]
399 (.transform tr p p)
400 [(.x p) (.y p)]))
402 (defn- translate-mouse-event [^java.awt.event.MouseEvent event
403 ^AffineTransform tr id]
404 (let [[x y] (transform tr (.getX event) (.getY event))]
405 (MouseEvent. id (.getWhen event) x y
406 (.getXOnScreen event) (.getYOnScreen event)
407 (.getButton event))))
409 (defn- translate-and-dispatch
410 ([nodes first-only ^java.awt.event.MouseEvent event]
411 (translate-and-dispatch nodes first-only
412 event (awt-events (.getID event))))
413 ([nodes first-only event id]
414 (if-let [node (first nodes)]
415 (if-let [handler (get (:handlers node) id)]
416 (do
417 (with-bindings* (:bindings node)
418 handler
419 (translate-mouse-event event (:transform node) id))
420 (if-not first-only
421 (recur (rest nodes) false event id)))
422 (recur (rest nodes) first-only event id)))))
424 (defn- dispatch-mouse-motion
425 "Dispatches mouse motion events."
426 [hovered-ref tree root ^java.awt.event.MouseEvent event]
427 (let [x (.getX event)
428 y (.getY event)
429 [hovered hovered2] (dosync
430 [@hovered-ref
431 (ref-set hovered-ref
432 (under-cursor x y tree root))])
433 pred #(= (:handle %1) (:handle %2))
434 exited (remove-all hovered hovered2 pred)
435 entered (remove-all hovered2 hovered pred)
436 moved (remove-all hovered2 entered pred)]
437 (translate-and-dispatch exited false event :mouse-exited)
438 (translate-and-dispatch entered false event :mouse-entered)
439 (translate-and-dispatch moved true event :mouse-moved)))
441 (defn- dispatch-mouse-button
442 [picked-ref hovered-ref ^java.awt.event.MouseEvent event]
443 (let [id (awt-events (.getID event))
444 hovered (if (= id :mouse-pressed)
445 (dosync (ref-set picked-ref @hovered-ref))
446 @hovered-ref)]
447 (translate-and-dispatch hovered true event id)))
449 (defn root-event-dispatcher []
450 (let [tree-r (ref {}) ; register
451 tree (ref {}) ; dispatch
452 hovered (ref '())
453 picked (ref '())]
454 (reify
455 EventDispatcher
456 (listen! [this component]
457 (doto component
458 (.addMouseListener this)
459 (.addMouseMotionListener this)))
460 (create-dispatcher [this handle handlers]
461 (let [node (make-node handle handlers)]
462 (dosync (alter tree-r add-node node))
463 node))
464 (commit [this]
465 (dosync (ref-set tree @tree-r)
466 (ref-set tree-r {})))
467 MouseListener
468 (mouseEntered [this event]
469 (dispatch-mouse-motion hovered @tree this event))
470 (mouseExited [this event]
471 (dispatch-mouse-motion hovered @tree this event))
472 (mouseClicked [this event]
473 (dispatch-mouse-button picked hovered event))
474 (mousePressed [this event]
475 (dispatch-mouse-button picked hovered event))
476 (mouseReleased [this event]
477 (translate-and-dispatch @picked true event))
478 ;;(dispatch-mouse-button picked hovered event))
479 MouseMotionListener
480 (mouseDragged [this event]
481 (translate-and-dispatch @picked true event))
482 (mouseMoved [this event]
483 (dispatch-mouse-motion hovered @tree this event)))))
485 ;;
486 ;; ИДЕИ:
487 ;;
488 ;; Контекст: биндинги или запись?
489 ;;
490 ;; Установка обработчиков (в контексте слоя):
491 ;;
492 ;; (listen
493 ;; (:mouse-entered e
494 ;; ...)
495 ;; (:mouse-exited e
496 ;; ...))
497 ;;
498 ;; Не надо IMGUI.
499 ;; Построение сцены путем декорирования слоев:
500 ;;
501 ;; (listener
502 ;; (:action e (println e))
503 ;; (:mouse-dragged e (println e))
504 ;; (theme :font "Helvetica-14"
505 ;; (vbox
506 ;; (button (text-layer "Button 1"))
507 ;; (button (text-layer "Button 2")))))
508 ;;