Mercurial > hg > indyvon
view src/net/kryshen/indyvon/core.clj @ 75:ddfde9cce39a
EventDispatcher can report hovered and picked states for handles.
| author | Mikhail Kryshen <mikhail@kryshen.net> |
|---|---|
| date | Mon, 30 Aug 2010 20:44:23 +0400 |
| parents | a823dd0c2736 |
| children | 4c0f2af742ba |
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 AWTEvent 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 *root*)
49 (def *event-dispatcher*)
51 (def ^{:tag AffineTransform
52 :doc "Initial transform associated with the graphics context."}
53 *initial-transform*)
55 (def ^{:tag AffineTransform
56 :doc "Inversion of the initial transform associated with
57 the graphics context."}
58 *inverse-initial-transform*)
60 (defrecord Theme [fore-color back-color alt-back-color border-color font])
62 ;; REMIND: use system colors, see java.awt.SystemColor.
63 (defn default-theme []
64 (Theme. Color/BLACK Color/WHITE Color/LIGHT_GRAY
65 Color/BLUE (Font. "Sans" Font/PLAIN 12)))
67 (def *theme* (default-theme))
69 (defrecord Location [x y])
70 (defrecord Size [width height])
71 (defrecord Bounds [x y width height])
73 ;;
74 ;; Core protocols and types
75 ;;
77 (defprotocol Layer
78 "Basic UI element."
79 (render! [this])
80 (layer-size [this]))
82 ;; TODO: modifiers
83 (defrecord MouseEvent [id when x y x-on-screen y-on-screen button])
85 (defprotocol EventDispatcher
86 (listen! [this ^Component component]
87 "Listen for events on the specified AWT Component.")
88 (create-dispatcher [this handle handlers]
89 "Returns new event dispatcher associated with the specified event
90 handlers (an event-id -> handler-fn map). Handle is used to
91 match the contexts between commits.")
92 (commit [this]
93 "Apply the registered handlers for event processing.")
94 (handle-picked? [this handle]
95 "Returns true if the specified handle received the :mouse-pressed
96 event and have not yet received :moused-released.")
97 (handle-hovered? [this handle]
98 "Returns true if the specified handle received the :mouse-entered
99 event and have not yet received :mouse-exited."))
101 (defprotocol Anchored
102 "Provide anchor point for Layers. Used by viewport."
103 (anchor [this h-align v-align]
104 "Anchor point: [x y], h-align could be :left, :center or :right,
105 v-align is :top, :center or :bottom"))
107 (defn default-anchor [layer h-align v-align]
108 (if (and (= h-align :left)
109 (= v-align :top))
110 (Location. 0 0)
111 (let [size (layer-size layer)]
112 (Location.
113 (case h-align
114 :top 0
115 :center (/ (:width size) 2)
116 :right (:width size))
117 (case v-align
118 :left 0
119 :center (/ (:height size) 2)
120 :bottom (:height size))))))
122 ;; Default implementation of Anchored for any Layer.
123 (extend-protocol Anchored
124 net.kryshen.indyvon.core.Layer
125 (anchor [this h-align v-align]
126 (default-anchor this h-align v-align)))
128 (defn- assoc-cons [m key val]
129 (->> (get m key) (cons val) (assoc m key)))
131 (defn- assoc-in-cons [m keys val]
132 (->> (get-in m keys) (cons val) (assoc-in m keys)))
134 ;;
135 ;; Observers
136 ;;
138 (def observers (atom nil))
140 ;; TODO: groups should be weakly referenced.
141 (defn add-observer
142 "Add observer fn for the target to the specified group."
143 [group target f]
144 (swap! observers assoc-in-cons [group target] f)
145 nil)
147 (defn remove-observer-group
148 "Remove group of observers."
149 [group]
150 (swap! observers dissoc group)
151 nil)
153 (defn- replace-observer-group*
154 [observers old-id new-id]
155 (let [group (get observers old-id)]
156 (assoc (dissoc observers old-id)
157 new-id group)))
159 (defn- replace-observer-group
160 [old-id new-id]
161 (swap! observers replace-observer-group* old-id new-id))
163 (defn update
164 "Notify observers."
165 [target & args]
166 (doseq [f (reduce #(concat %1 (get %2 target)) nil (vals @observers))]
167 (apply f target args)))
169 (defn add-context-observer
170 "Observer registered with this function will be automatically
171 removed after the next frame rendering is complete."
172 [target f]
173 (let [root *root*]
174 (add-observer root target f)))
176 (defn repaint-on-update
177 "Trigger repaint of the current scene when the target updates."
178 [target]
179 (let [root *root*]
180 (if (not= root target)
181 (add-observer root target (fn [_] (update root))))))
183 (defn repaint
184 "Repaint the current scene."
185 []
186 (update *root*))
188 ;;
189 ;; Rendering
190 ;;
192 (defn- relative-transform
193 "AffineTransform: layer context -> awt component."
194 []
195 (let [tr (.getTransform *graphics*)]
196 (.preConcatenate tr *inverse-initial-transform*)
197 tr))
199 (defn- inverse-relative-transform
200 "AffineTransform: awt component -> layer context."
201 []
202 (let [tr (.getTransform *graphics*)]
203 (.invert tr) ; absolute -> layer
204 (.concatenate tr *initial-transform*) ; component -> absolute
205 tr))
207 (defn- clip
208 "Intersect clipping area with the specified shape or bounds.
209 Returns new clip (Shape or nil if empty)."
210 ([x y w h]
211 (clip (Rectangle2D$Double. x y w h)))
212 ([shape]
213 (let [a1 (Area. shape)
214 a2 (if (instance? Area *clip*) *clip* (Area. *clip*))]
215 (.transform a1 (relative-transform))
216 (.intersect a1 a2)
217 (if (.isEmpty a1)
218 nil
219 a1))))
221 (defn- ^Graphics2D apply-theme
222 "Set graphics' color and font to match theme.
223 Modifies and returns the first argument."
224 ([]
225 (apply-theme *graphics* *theme*))
226 ([^Graphics2D graphics theme]
227 (doto graphics
228 (.setColor (:fore-color theme))
229 (.setFont (:font theme)))))
231 (defn- ^Graphics2D create-graphics
232 ([]
233 (create-graphics 0 0 *width* *height*))
234 ([x y w h]
235 (apply-theme (.create *graphics* x y w h) *theme*)))
237 (defn with-bounds*
238 [x y w h f & args]
239 (when-let [clip (clip x y w h)]
240 (let [graphics (create-graphics x y w h)]
241 (try
242 (binding [*width* w
243 *height* h
244 *clip* clip
245 *graphics* graphics]
246 (apply f args))
247 (finally
248 (.dispose graphics))))))
250 (defmacro with-bounds
251 [x y w h & body]
252 `(with-bounds* ~x ~y ~w ~h (fn [] ~@body)))
254 (defmacro with-theme
255 [theme & body]
256 `(binding [*theme* (merge *theme* ~theme)]
257 ~@body))
259 (defmacro with-color
260 [color-or-keyword & body]
261 (let [color-form (if (keyword? color-or-keyword)
262 `(~color-or-keyword *theme*)
263 color-or-keyword)]
264 `(let [color# ~color-form
265 old-color# (.getColor *graphics*)]
266 (try
267 (.setColor *graphics* color#)
268 ~@body
269 (finally
270 (.setColor *graphics* old-color#))))))
272 ;; TODO: constructor for AffineTransform.
273 ;; (transform :scale 0.3 0.5
274 ;; :translate 5 10
275 ;; :rotate (/ Math/PI 2))
277 (defmacro with-transform [transform & body]
278 `(let [old-t# (.getTransform *graphics*)]
279 (try
280 (.transform *graphics* ~transform)
281 ~@body
282 (finally
283 (.setTransform *graphics* old-t#)))))
285 (defmacro with-rotate [theta ax ay & body]
286 `(let [transform# (AffineTransform/getRotateInstance ~theta ~ax ~ay)]
287 (with-transform transform# ~@body)))
289 (defn draw!
290 "Draws layer."
291 ([layer]
292 (let [graphics (create-graphics)]
293 (try
294 (binding [*graphics* graphics]
295 (render! layer))
296 (finally
297 (.dispose graphics)))))
298 ([layer x y]
299 (let [size (layer-size layer)]
300 (draw! layer x y (:width size) (:height size))))
301 ([layer x y width height]
302 (with-bounds* x y width height render! layer)))
304 (defn draw-anchored!
305 "Draws layer. Location is relative to the layer's anchor point for
306 the specified alignment."
307 ([layer h-align v-align x y]
308 (let [anchor (anchor layer h-align v-align)]
309 (draw! layer (- x (:x anchor)) (- y (:y anchor)))))
310 ([layer h-align v-align x y w h]
311 (let [anchor (anchor layer h-align v-align)]
312 (draw! layer (- x (:x anchor)) (- y (:y anchor)) w h))))
314 (defn draw-root!
315 "Draws the root layer."
316 ([layer graphics width height event-dispatcher]
317 (draw-root! layer graphics width height event-dispatcher nil))
318 ([layer ^Graphics2D graphics width height event-dispatcher target]
319 (binding [*root* layer
320 *target* target
321 *graphics* graphics
322 *font-context* (.getFontRenderContext graphics)
323 *initial-transform* (.getTransform graphics)
324 *inverse-initial-transform*
325 (-> graphics .getTransform .createInverse)
326 *event-dispatcher* event-dispatcher
327 *width* width
328 *height* height
329 *clip* (Rectangle2D$Double. 0 0 width height)]
330 ;; (.setRenderingHint graphics
331 ;; RenderingHints/KEY_INTERPOLATION
332 ;; RenderingHints/VALUE_INTERPOLATION_BILINEAR)
333 ;; (.setRenderingHint graphics
334 ;; RenderingHints/KEY_ALPHA_INTERPOLATION
335 ;; RenderingHints/VALUE_ALPHA_INTERPOLATION_QUALITY)
336 ;; (.setRenderingHint graphics
337 ;; RenderingHints/KEY_ANTIALIASING
338 ;; RenderingHints/VALUE_ANTIALIAS_ON)
339 (apply-theme)
340 (with-color (:back-color *theme*)
341 (.fillRect graphics 0 0 width height))
342 (let [tmp-group (Object.)]
343 ;; Keep current context observers until the rendering is complete.
344 ;; Some observers may be invoked twice if they appear in both
345 ;; groups until tmp-group is removed.
346 (replace-observer-group layer tmp-group)
347 (try
348 (render! layer)
349 (finally
350 (remove-observer-group tmp-group)
351 (commit event-dispatcher)))))))
353 (defn root-size
354 ([layer font-context]
355 (root-size layer font-context nil))
356 ([layer font-context target]
357 (binding [*root* layer
358 *target* target
359 *font-context* font-context]
360 (layer-size layer))))
362 ;;
363 ;; Event handling.
364 ;;
366 (defn with-handlers*
367 [handle handlers f & args]
368 (binding
369 [*event-dispatcher* (create-dispatcher
370 *event-dispatcher* handle handlers)]
371 (apply f args)))
373 (defmacro with-handlers
374 "specs => (:event-id name & handler-body)*
376 Execute form with the specified event handlers."
377 [handle form & specs]
378 `(with-handlers* ~handle
379 ~(reduce (fn [m spec]
380 (assoc m (first spec)
381 `(fn [~(second spec)]
382 ~@(nnext spec)))) {}
383 specs)
384 (fn [] ~form)))
386 (defn picked? [handle]
387 (handle-picked? *event-dispatcher* handle))
389 (defn hovered? [handle]
390 (handle-hovered? *event-dispatcher* handle))
393 ;;
394 ;; EventDispatcher implementation
395 ;;
397 (def awt-events
398 {java.awt.event.MouseEvent/MOUSE_CLICKED :mouse-clicked
399 java.awt.event.MouseEvent/MOUSE_DRAGGED :mouse-dragged
400 java.awt.event.MouseEvent/MOUSE_ENTERED :mouse-entered
401 java.awt.event.MouseEvent/MOUSE_EXITED :mouse-exited
402 java.awt.event.MouseEvent/MOUSE_MOVED :mouse-moved
403 java.awt.event.MouseEvent/MOUSE_PRESSED :mouse-pressed
404 java.awt.event.MouseEvent/MOUSE_RELEASED :mouse-released})
406 (def dummy-event-dispatcher
407 (reify
408 EventDispatcher
409 (listen! [this component])
410 (create-dispatcher [this handle handlers] this)
411 (commit [this])
412 (handle-picked? [this handle])
413 (handle-hovered? [this handle])))
415 (defrecord DispatcherNode [handle handlers parent
416 ^Shape clip ^AffineTransform transform
417 bindings]
418 EventDispatcher
419 (listen! [this component]
420 (listen! parent component))
421 (create-dispatcher [this handle handlers]
422 (create-dispatcher parent handle handlers))
423 (commit [this]
424 (commit parent))
425 (handle-picked? [this handle]
426 (handle-picked? parent handle))
427 (handle-hovered? [this handle]
428 (handle-hovered? parent handle)))
430 (defn- make-node [handle handlers]
431 (DispatcherNode. handle handlers *event-dispatcher* *clip*
432 (inverse-relative-transform)
433 (get-thread-bindings)))
435 (defn- add-node [tree node]
436 (assoc-cons tree (:parent node) node))
438 (defn- under-cursor
439 "Returns a vector of child nodes under cursor."
440 [x y tree node]
441 (some #(if (.contains ^Shape (:clip %) x y)
442 (conj (vec (under-cursor x y tree %)) %))
443 (get tree node)))
445 (defn- remove-all [coll1 coll2 pred]
446 (filter #(not (some (partial pred %) coll2)) coll1))
448 (defn- transform [^AffineTransform tr x y]
449 (let [p (Point2D$Double. x y)]
450 (.transform tr p p)
451 [(.x p) (.y p)]))
453 (defn- translate-mouse-event [^java.awt.event.MouseEvent event
454 ^AffineTransform tr id]
455 (let [[x y] (transform tr (.getX event) (.getY event))]
456 (MouseEvent. id (.getWhen event) x y
457 (.getXOnScreen event) (.getYOnScreen event)
458 (.getButton event))))
460 (defn- translate-and-dispatch
461 ([nodes first-only ^java.awt.event.MouseEvent event]
462 (translate-and-dispatch nodes first-only
463 event (awt-events (.getID event))))
464 ([nodes first-only event id]
465 (if-let [node (first nodes)]
466 (if-let [handler (get (:handlers node) id)]
467 (do
468 (with-bindings* (:bindings node)
469 handler
470 (translate-mouse-event event (:transform node) id))
471 (if-not first-only
472 (recur (rest nodes) false event id)))
473 (recur (rest nodes) first-only event id)))))
475 (defn- dispatch-mouse-motion
476 "Dispatches mouse motion events."
477 [hovered-ref tree root ^java.awt.event.MouseEvent event]
478 (let [x (.getX event)
479 y (.getY event)
480 [hovered hovered2] (dosync
481 [@hovered-ref
482 (ref-set hovered-ref
483 (under-cursor x y tree root))])
484 pred #(= (:handle %1) (:handle %2))
485 exited (remove-all hovered hovered2 pred)
486 entered (remove-all hovered2 hovered pred)
487 moved (remove-all hovered2 entered pred)]
488 (translate-and-dispatch exited false event :mouse-exited)
489 (translate-and-dispatch entered false event :mouse-entered)
490 (translate-and-dispatch moved true event :mouse-moved)))
492 (defn- dispatch-mouse-button
493 [picked-ref hovered-ref ^java.awt.event.MouseEvent event]
494 (let [id (awt-events (.getID event))
495 hovered (if (= id :mouse-pressed)
496 (dosync (ref-set picked-ref @hovered-ref))
497 @hovered-ref)]
498 (translate-and-dispatch hovered true event id)))
500 (defn root-event-dispatcher []
501 (let [tree-r (ref {}) ; register
502 tree (ref {}) ; dispatch
503 hovered (ref '())
504 picked (ref '())]
505 (reify
506 EventDispatcher
507 (listen! [this component]
508 (doto component
509 (.addMouseListener this)
510 (.addMouseMotionListener this)))
511 (create-dispatcher [this handle handlers]
512 (let [node (make-node handle handlers)]
513 (dosync (alter tree-r add-node node))
514 node))
515 (commit [this]
516 (dosync (ref-set tree @tree-r)
517 (ref-set tree-r {})))
518 (handle-picked? [this handle]
519 (some #(= handle (:handle %)) @picked))
520 (handle-hovered? [this handle]
521 (some #(= handle (:handle %)) @hovered))
522 MouseListener
523 (mouseEntered [this event]
524 (dispatch-mouse-motion hovered @tree this event))
525 (mouseExited [this event]
526 (dispatch-mouse-motion hovered @tree this event))
527 (mouseClicked [this event]
528 (dispatch-mouse-button picked hovered event))
529 (mousePressed [this event]
530 (dispatch-mouse-button picked hovered event))
531 (mouseReleased [this event]
532 (translate-and-dispatch @picked true event))
533 ;;(dispatch-mouse-button picked hovered event))
534 MouseMotionListener
535 (mouseDragged [this event]
536 (translate-and-dispatch @picked true event))
537 (mouseMoved [this event]
538 (dispatch-mouse-motion hovered @tree this event)))))
540 ;;
541 ;; ИДЕИ:
542 ;;
543 ;; Контекст: биндинги или запись?
544 ;;
545 ;; Установка обработчиков (в контексте слоя):
546 ;;
547 ;; (listen
548 ;; (:mouse-entered e
549 ;; ...)
550 ;; (:mouse-exited e
551 ;; ...))
552 ;;
553 ;; Не надо IMGUI.
554 ;; Построение сцены путем декорирования слоев:
555 ;;
556 ;; (listener
557 ;; (:action e (println e))
558 ;; (:mouse-dragged e (println e))
559 ;; (theme :font "Helvetica-14"
560 ;; (vbox
561 ;; (button (text-layer "Button 1"))
562 ;; (button (text-layer "Button 2")))))
563 ;;