view src/net/kryshen/indyvon/core.clj @ 79:5fd50e400124

Fixed processing of mouse-released events.
author Mikhail Kryshen <mikhail@kryshen.net>
date Wed, 01 Sep 2010 22:24:17 +0400
parents 4c0f2af742ba
children 5d2153e8a28d
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 ^{: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 (defprotocol EventDispatcher
91 (listen! [this ^Component component]
92 "Listen for events on the specified AWT Component.")
93 (create-dispatcher [this handle handlers]
94 "Returns new event dispatcher associated with the specified event
95 handlers (an event-id -> handler-fn map). Handle is used to
96 match the contexts between commits.")
97 (commit [this]
98 "Apply the registered handlers for event processing.")
99 (handle-picked? [this handle]
100 "Returns true if the specified handle received the :mouse-pressed
101 event and have not yet received :moused-released.")
102 (handle-hovered? [this handle]
103 "Returns true if the specified handle received the :mouse-entered
104 event and have not yet received :mouse-exited."))
106 (defprotocol Anchored
107 "Provide anchor point for Layers. Used by viewport."
108 (anchor [this h-align v-align]
109 "Anchor point: [x y], h-align could be :left, :center or :right,
110 v-align is :top, :center or :bottom"))
112 (defn default-anchor [layer h-align v-align]
113 (if (and (= h-align :left)
114 (= v-align :top))
115 (Location. 0 0)
116 (let [size (layer-size layer)]
117 (Location.
118 (case h-align
119 :top 0
120 :center (/ (:width size) 2)
121 :right (:width size))
122 (case v-align
123 :left 0
124 :center (/ (:height size) 2)
125 :bottom (:height size))))))
127 ;; Default implementation of Anchored for any Layer.
128 (extend-protocol Anchored
129 net.kryshen.indyvon.core.Layer
130 (anchor [this h-align v-align]
131 (default-anchor this h-align v-align)))
133 (defn- assoc-cons [m key val]
134 (->> (get m key) (cons val) (assoc m key)))
136 (defn- assoc-in-cons [m keys val]
137 (->> (get-in m keys) (cons val) (assoc-in m keys)))
139 ;;
140 ;; Observers
141 ;;
143 (def observers (atom nil))
145 ;; TODO: groups should be weakly referenced.
146 (defn add-observer
147 "Add observer fn for the target to the specified group."
148 [group target f]
149 (swap! observers assoc-in-cons [group target] f)
150 nil)
152 (defn remove-observer-group
153 "Remove group of observers."
154 [group]
155 (swap! observers dissoc group)
156 nil)
158 (defn- replace-observer-group*
159 [observers old-id new-id]
160 (let [group (get observers old-id)]
161 (assoc (dissoc observers old-id)
162 new-id group)))
164 (defn- replace-observer-group
165 [old-id new-id]
166 (swap! observers replace-observer-group* old-id new-id))
168 (defn update
169 "Notify observers."
170 [target & args]
171 (doseq [f (reduce #(concat %1 (get %2 target)) nil (vals @observers))]
172 (apply f target args)))
174 (defn add-context-observer
175 "Observer registered with this function will be automatically
176 removed after the next frame rendering is complete."
177 [target f]
178 (let [root *root*]
179 (add-observer root target f)))
181 (defn repaint-on-update
182 "Trigger repaint of the current scene when the target updates."
183 [target]
184 (let [root *root*]
185 (if (not= root target)
186 (add-observer root target (fn [_] (update root))))))
188 (defn repaint
189 "Repaint the current scene."
190 []
191 (update *root*))
193 ;;
194 ;; Rendering
195 ;;
197 (defn- relative-transform
198 "AffineTransform: layer context -> awt component."
199 []
200 (let [tr (.getTransform *graphics*)]
201 (.preConcatenate tr *inverse-initial-transform*)
202 tr))
204 (defn- inverse-relative-transform
205 "AffineTransform: awt component -> layer context."
206 []
207 (let [tr (.getTransform *graphics*)]
208 (.invert tr) ; absolute -> layer
209 (.concatenate tr *initial-transform*) ; component -> absolute
210 tr))
212 (defn- clip
213 "Intersect clipping area with the specified shape or bounds.
214 Returns new clip (Shape or nil if empty)."
215 ([x y w h]
216 (clip (Rectangle2D$Double. x y w h)))
217 ([shape]
218 (let [a1 (Area. shape)
219 a2 (if (instance? Area *clip*) *clip* (Area. *clip*))]
220 (.transform a1 (relative-transform))
221 (.intersect a1 a2)
222 (if (.isEmpty a1)
223 nil
224 a1))))
226 (defn- ^Graphics2D apply-theme
227 "Set graphics' color and font to match theme.
228 Modifies and returns the first argument."
229 ([]
230 (apply-theme *graphics* *theme*))
231 ([^Graphics2D graphics theme]
232 (doto graphics
233 (.setColor (:fore-color theme))
234 (.setFont (:font theme)))))
236 (defn- ^Graphics2D create-graphics
237 ([]
238 (create-graphics 0 0 *width* *height*))
239 ([x y w h]
240 (apply-theme (.create *graphics* x y w h) *theme*)))
242 (defn with-bounds*
243 [x y w h f & args]
244 (when-let [clip (clip x y w h)]
245 (let [graphics (create-graphics x y w h)]
246 (try
247 (binding [*width* w
248 *height* h
249 *clip* clip
250 *graphics* graphics]
251 (apply f args))
252 (finally
253 (.dispose graphics))))))
255 (defmacro with-bounds
256 [x y w h & body]
257 `(with-bounds* ~x ~y ~w ~h (fn [] ~@body)))
259 (defmacro with-theme
260 [theme & body]
261 `(binding [*theme* (merge *theme* ~theme)]
262 ~@body))
264 (defmacro with-color
265 [color-or-keyword & body]
266 (let [color-form (if (keyword? color-or-keyword)
267 `(~color-or-keyword *theme*)
268 color-or-keyword)]
269 `(let [color# ~color-form
270 old-color# (.getColor *graphics*)]
271 (try
272 (.setColor *graphics* color#)
273 ~@body
274 (finally
275 (.setColor *graphics* old-color#))))))
277 ;; TODO: constructor for AffineTransform.
278 ;; (transform :scale 0.3 0.5
279 ;; :translate 5 10
280 ;; :rotate (/ Math/PI 2))
282 (defmacro with-transform [transform & body]
283 `(let [old-t# (.getTransform *graphics*)]
284 (try
285 (.transform *graphics* ~transform)
286 ~@body
287 (finally
288 (.setTransform *graphics* old-t#)))))
290 (defmacro with-rotate [theta ax ay & body]
291 `(let [transform# (AffineTransform/getRotateInstance ~theta ~ax ~ay)]
292 (with-transform transform# ~@body)))
294 (defn draw!
295 "Draws layer."
296 ([layer]
297 (let [graphics (create-graphics)]
298 (try
299 (binding [*graphics* graphics]
300 (render! layer))
301 (finally
302 (.dispose graphics)))))
303 ([layer x y]
304 (let [size (layer-size layer)]
305 (draw! layer x y (:width size) (:height size))))
306 ([layer x y width height]
307 (with-bounds* x y width height render! layer)))
309 (defn draw-anchored!
310 "Draws layer. Location is relative to the layer's anchor point for
311 the specified alignment."
312 ([layer h-align v-align x y]
313 (let [anchor (anchor layer h-align v-align)]
314 (draw! layer (- x (:x anchor)) (- y (:y anchor)))))
315 ([layer h-align v-align x y w h]
316 (let [anchor (anchor layer h-align v-align)]
317 (draw! layer (- x (:x anchor)) (- y (:y anchor)) w h))))
319 (defn draw-root!
320 "Draws the root layer."
321 ([layer graphics width height event-dispatcher]
322 (draw-root! layer graphics width height event-dispatcher nil))
323 ([layer ^Graphics2D graphics width height event-dispatcher target]
324 (binding [*root* layer
325 *target* target
326 *graphics* graphics
327 *font-context* (.getFontRenderContext graphics)
328 *initial-transform* (.getTransform graphics)
329 *inverse-initial-transform*
330 (-> graphics .getTransform .createInverse)
331 *event-dispatcher* event-dispatcher
332 *width* width
333 *height* height
334 *clip* (Rectangle2D$Double. 0 0 width height)
335 *time* (System/nanoTime)]
336 ;; (.setRenderingHint graphics
337 ;; RenderingHints/KEY_INTERPOLATION
338 ;; RenderingHints/VALUE_INTERPOLATION_BILINEAR)
339 ;; (.setRenderingHint graphics
340 ;; RenderingHints/KEY_ALPHA_INTERPOLATION
341 ;; RenderingHints/VALUE_ALPHA_INTERPOLATION_QUALITY)
342 ;; (.setRenderingHint graphics
343 ;; RenderingHints/KEY_ANTIALIASING
344 ;; RenderingHints/VALUE_ANTIALIAS_ON)
345 (apply-theme)
346 (with-color (:back-color *theme*)
347 (.fillRect graphics 0 0 width height))
348 (let [tmp-group (Object.)]
349 ;; Keep current context observers until the rendering is complete.
350 ;; Some observers may be invoked twice if they appear in both
351 ;; groups until tmp-group is removed.
352 (replace-observer-group layer tmp-group)
353 (try
354 (render! layer)
355 (finally
356 (remove-observer-group tmp-group)
357 (commit event-dispatcher)))))))
359 (defn root-size
360 ([layer font-context]
361 (root-size layer font-context nil))
362 ([layer font-context target]
363 (binding [*root* layer
364 *target* target
365 *font-context* font-context]
366 (layer-size layer))))
368 ;;
369 ;; Event handling.
370 ;;
372 (defn with-handlers*
373 [handle handlers f & args]
374 (binding
375 [*event-dispatcher* (create-dispatcher
376 *event-dispatcher* handle handlers)]
377 (apply f args)))
379 (defmacro with-handlers
380 "specs => (:event-id name & handler-body)*
382 Execute form with the specified event handlers."
383 [handle form & specs]
384 `(with-handlers* ~handle
385 ~(reduce (fn [m spec]
386 (assoc m (first spec)
387 `(fn [~(second spec)]
388 ~@(nnext spec)))) {}
389 specs)
390 (fn [] ~form)))
392 (defn picked? [handle]
393 (handle-picked? *event-dispatcher* handle))
395 (defn hovered? [handle]
396 (handle-hovered? *event-dispatcher* handle))
399 ;;
400 ;; EventDispatcher implementation
401 ;;
403 (def awt-events
404 {java.awt.event.MouseEvent/MOUSE_CLICKED :mouse-clicked
405 java.awt.event.MouseEvent/MOUSE_DRAGGED :mouse-dragged
406 java.awt.event.MouseEvent/MOUSE_ENTERED :mouse-entered
407 java.awt.event.MouseEvent/MOUSE_EXITED :mouse-exited
408 java.awt.event.MouseEvent/MOUSE_MOVED :mouse-moved
409 java.awt.event.MouseEvent/MOUSE_PRESSED :mouse-pressed
410 java.awt.event.MouseEvent/MOUSE_RELEASED :mouse-released})
412 (def dummy-event-dispatcher
413 (reify
414 EventDispatcher
415 (listen! [this component])
416 (create-dispatcher [this handle handlers] this)
417 (commit [this])
418 (handle-picked? [this handle])
419 (handle-hovered? [this handle])))
421 (defrecord DispatcherNode [handle handlers parent
422 ^Shape clip ^AffineTransform transform
423 bindings]
424 EventDispatcher
425 (listen! [this component]
426 (listen! parent component))
427 (create-dispatcher [this handle handlers]
428 (create-dispatcher parent handle handlers))
429 (commit [this]
430 (commit parent))
431 (handle-picked? [this handle]
432 (handle-picked? parent handle))
433 (handle-hovered? [this handle]
434 (handle-hovered? parent handle)))
436 (defn- make-node [handle handlers]
437 (DispatcherNode. handle handlers *event-dispatcher* *clip*
438 (inverse-relative-transform)
439 (get-thread-bindings)))
441 (defn- add-node [tree node]
442 (assoc-cons tree (:parent node) node))
444 (defn- under-cursor
445 "Returns a vector of child nodes under cursor."
446 [x y tree node]
447 (some #(if (.contains ^Shape (:clip %) x y)
448 (conj (vec (under-cursor x y tree %)) %))
449 (get tree node)))
451 (defn- remove-all [coll1 coll2 pred]
452 (filter #(not (some (partial pred %) coll2)) coll1))
454 (defn- transform [^AffineTransform tr x y]
455 (let [p (Point2D$Double. x y)]
456 (.transform tr p p)
457 [(.x p) (.y p)]))
459 (defn- translate-mouse-event [^java.awt.event.MouseEvent event
460 ^AffineTransform tr id]
461 (let [[x y] (transform tr (.getX event) (.getY event))]
462 (MouseEvent. id (.getWhen event) x y
463 (.getXOnScreen event) (.getYOnScreen event)
464 (.getButton event))))
466 (defn- translate-and-dispatch
467 ([nodes first-only ^java.awt.event.MouseEvent event]
468 (translate-and-dispatch nodes first-only
469 event (awt-events (.getID event))))
470 ([nodes first-only event id]
471 (if-let [node (first nodes)]
472 (if-let [handler (get (:handlers node) id)]
473 (do
474 (with-bindings* (:bindings node)
475 handler
476 (translate-mouse-event event (:transform node) id))
477 (if-not first-only
478 (recur (rest nodes) false event id)))
479 (recur (rest nodes) first-only event id)))))
481 (defn- dispatch-mouse-motion
482 "Dispatches mouse motion events."
483 [hovered-ref tree root ^java.awt.event.MouseEvent event]
484 (let [x (.getX event)
485 y (.getY event)
486 [hovered hovered2] (dosync
487 [@hovered-ref
488 (ref-set hovered-ref
489 (under-cursor x y tree root))])
490 pred #(= (:handle %1) (:handle %2))
491 exited (remove-all hovered hovered2 pred)
492 entered (remove-all hovered2 hovered pred)
493 moved (remove-all hovered2 entered pred)]
494 (translate-and-dispatch exited false event :mouse-exited)
495 (translate-and-dispatch entered false event :mouse-entered)
496 (translate-and-dispatch moved true event :mouse-moved)))
498 (defn- dispatch-mouse-button
499 [picked-ref hovered-ref ^java.awt.event.MouseEvent event]
500 (let [id (awt-events (.getID event))
501 nodes (case id
502 :mouse-pressed
503 (dosync
504 (ref-set picked-ref @hovered-ref))
505 :mouse-released
506 (dosync
507 (let [picked @picked-ref]
508 (ref-set picked-ref nil)
509 picked))
510 @hovered-ref)]
511 (translate-and-dispatch nodes true event id)))
513 (defn root-event-dispatcher []
514 (let [tree-r (ref {}) ; register
515 tree (ref {}) ; dispatch
516 hovered (ref '())
517 picked (ref '())]
518 (reify
519 EventDispatcher
520 (listen! [this component]
521 (doto component
522 (.addMouseListener this)
523 (.addMouseMotionListener this)))
524 (create-dispatcher [this handle handlers]
525 (let [node (make-node handle handlers)]
526 (dosync (alter tree-r add-node node))
527 node))
528 (commit [this]
529 (dosync (ref-set tree @tree-r)
530 (ref-set tree-r {})))
531 (handle-picked? [this handle]
532 (some #(= handle (:handle %)) @picked))
533 (handle-hovered? [this handle]
534 (some #(= handle (:handle %)) @hovered))
535 MouseListener
536 (mouseEntered [this event]
537 (dispatch-mouse-motion hovered @tree this event))
538 (mouseExited [this event]
539 (dispatch-mouse-motion hovered @tree this event))
540 (mouseClicked [this event]
541 (dispatch-mouse-button picked hovered event))
542 (mousePressed [this event]
543 (dispatch-mouse-button picked hovered event))
544 (mouseReleased [this event]
545 (dispatch-mouse-button picked hovered event))
546 MouseMotionListener
547 (mouseDragged [this event]
548 (translate-and-dispatch @picked true event))
549 (mouseMoved [this event]
550 (dispatch-mouse-motion hovered @tree this event)))))
552 ;;
553 ;; ИДЕИ:
554 ;;
555 ;; Контекст: биндинги или запись?
556 ;;
557 ;; Установка обработчиков (в контексте слоя):
558 ;;
559 ;; (listen
560 ;; (:mouse-entered e
561 ;; ...)
562 ;; (:mouse-exited e
563 ;; ...))
564 ;;
565 ;; Не надо IMGUI.
566 ;; Построение сцены путем декорирования слоев:
567 ;;
568 ;; (listener
569 ;; (:action e (println e))
570 ;; (:mouse-dragged e (println e))
571 ;; (theme :font "Helvetica-14"
572 ;; (vbox
573 ;; (button (text-layer "Button 1"))
574 ;; (button (text-layer "Button 2")))))
575 ;;