Mercurial > hg > indyvon
view src/net/kryshen/indyvon/core.clj @ 64:702a4939312d
New mechanism for layers to trigger repaints (beginning).
| author | Mikhail Kryshen <mikhail@kryshen.net> |
|---|---|
| date | Thu, 26 Aug 2010 06:29:30 +0400 |
| parents | 88bb47e3a401 |
| children | fd1bcb67bc32 |
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 *event-dispatcher*)
34 (def ^{:doc "Fn to be called in a layer context to request redraw."}
35 *update*)
37 (def ^{:tag AffineTransform
38 :doc "Initial transform associated with the graphics context"}
39 *initial-transform*)
41 (def ^{:tag AffineTransform
42 :doc "Inversion of the initial transform associated with
43 the graphics context"}
44 *inverse-initial-transform*)
46 (defrecord Theme [fore-color back-color alt-back-color border-color font])
48 ;; REMIND: use system colors, see java.awt.SystemColor.
49 (defn default-theme []
50 (Theme. Color/BLACK Color/LIGHT_GRAY Color/WHITE
51 Color/BLUE (Font. "Sans" Font/PLAIN 12)))
53 (def *theme* (default-theme))
55 (defrecord Location [x y])
56 (defrecord Size [width height])
57 (defrecord Bounds [x y width height])
59 ;;
60 ;; Core protocols and types
61 ;;
63 (defprotocol Layer
64 "Basic UI element."
65 (render! [this])
66 (layer-size [this]))
68 ;; TODO: modifiers
69 (defrecord MouseEvent [id when x y x-on-screen y-on-screen button])
71 (defprotocol EventDispatcher
72 (listen! [this ^Component component]
73 "Listen for events on the specified AWT Component.")
74 (create-dispatcher [this handle handlers]
75 "Returns new event dispatcher associated with the specified event
76 handlers (an event-id -> handler-fn map). Handle is used to
77 match the contexts between commits.")
78 (commit [this]
79 "Apply the registered handlers for event processing."))
81 (defprotocol Anchored
82 "Provide anchor point for Layers. Used by viewport."
83 (anchor [this h-align v-align]
84 "Anchor point: [x y], h-align could be :left, :center or :right,
85 v-align is :top, :center or :bottom"))
87 ;; Default implementation of Anchored for any Layer.
88 (extend-protocol Anchored
89 net.kryshen.indyvon.core.Layer
90 (anchor [this h-align v-align]
91 (if (and (= h-align :left)
92 (= v-align :top))
93 (Location. 0 0)
94 (let [size (layer-size this)]
95 (Location.
96 (case h-align
97 :top 0
98 :center (/ (:width size) 2)
99 :right (:width size))
100 (case v-align
101 :left 0
102 :center (/ (:height size) 2)
103 :bottom (:height size)))))))
105 (defn- assoc-cons [m key val]
106 (->> (get m key) (cons val) (assoc m key)))
108 (defn- assoc-in-cons [m keys val]
109 (->> (get-in m keys) (cons val) (assoc-in m keys)))
111 ;;
112 ;; Observers
113 ;;
115 (def observers (atom nil))
117 (defn add-observer
118 ([target f]
119 (add-observer target f :default))
120 ([target f group-id]
121 (swap! observers assoc-in-cons [group-id target] f)
122 nil))
124 (defn remove-group
125 "Remove group of observers."
126 [group-id]
127 (swap! observers dissoc group-id)
128 nil)
130 (defn- change-group-id*
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- change-group-id
137 [old-id new-id]
138 (swap! observers change-group-id* 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 ;;
147 ;; Rendering
148 ;;
150 (defn- relative-transform
151 "AffineTransform: layer context -> awt component."
152 []
153 (let [tr (.getTransform *graphics*)]
154 (.preConcatenate tr *inverse-initial-transform*)
155 tr))
157 (defn- inverse-relative-transform
158 "AffineTransform: awt component -> layer context."
159 []
160 (let [tr (.getTransform *graphics*)]
161 (.invert tr) ; absolute -> layer
162 (.concatenate tr *initial-transform*) ; component -> absolute
163 tr))
165 (defn- clip
166 "Intersect clipping area with the specified shape or bounds.
167 Returns new clip (Shape or nil if empty)."
168 ([x y w h]
169 (clip (Rectangle2D$Double. x y w h)))
170 ([shape]
171 (let [a1 (Area. shape)
172 a2 (if (instance? Area *clip*) *clip* (Area. *clip*))]
173 (.transform a1 (relative-transform))
174 (.intersect a1 a2)
175 (if (.isEmpty a1)
176 nil
177 a1))))
179 (defn- ^Graphics2D apply-theme
180 "Set graphics' color and font to match theme.
181 Modifies and returns the first argument."
182 ([]
183 (apply-theme *graphics* *theme*))
184 ([^Graphics2D graphics theme]
185 (doto graphics
186 (.setColor (:fore-color theme))
187 (.setFont (:font theme)))))
189 (defn- ^Graphics2D create-graphics
190 ([]
191 (create-graphics 0 0 *width* *height*))
192 ([x y w h]
193 (apply-theme (.create *graphics* x y w h) *theme*)))
195 (defn with-bounds*
196 [x y w h f & args]
197 (when-let [clip (clip x y w h)]
198 (let [graphics (create-graphics x y w h)]
199 (try
200 (binding [*width* w
201 *height* h
202 *clip* clip
203 *graphics* graphics]
204 (apply f args))
205 (finally
206 (.dispose graphics))))))
208 (defmacro with-bounds
209 [x y w h & body]
210 `(with-bounds* ~x ~y ~w ~h (fn [] ~@body)))
212 (defn with-handlers*
213 [handle handlers f & args]
214 (binding
215 [*event-dispatcher* (create-dispatcher
216 *event-dispatcher* handle handlers)]
217 (apply f args)))
219 (defmacro with-handlers
220 "specs => (:event-id name & handler-body)*
222 Execute form with the specified event handlers."
223 [handle form & specs]
224 `(with-handlers* ~handle
225 ~(reduce (fn [m spec]
226 (assoc m (first spec)
227 `(fn [~(second spec)]
228 ~@(nnext spec)))) {}
229 specs)
230 (fn [] ~form)))
232 (defmacro with-theme
233 [theme & body]
234 `(binding [*theme* (merge *theme* ~theme)]
235 ~@body))
237 (defmacro with-color
238 [color & body]
239 `(let [color# (.getColor *graphics*)]
240 (try
241 (.setColor *graphics* ~color)
242 ~@body
243 (finally
244 (.setColor *graphics* color#)))))
246 ;; TODO:
247 ;;
248 ;; (with-transform
249 ;; (rotate ...)
250 ;; (draw ...)
251 ;; (scale ...)
252 ;; (draw ...))
254 (defmacro with-transform [transform & body]
255 `(let [old-t# (.getTransform *graphics*)]
256 (try
257 (.transform *graphics* ~transform)
258 ~@body
259 (finally
260 (.setTransform *graphics* old-t#)))))
262 (defmacro with-rotate [theta ax ay & body]
263 `(let [transform# (AffineTransform/getRotateInstance ~theta ~ax ~ay)]
264 (with-transform transform# ~@body)))
266 (defn- geometry-vec [geometry]
267 (if (vector? geometry)
268 geometry
269 [(:x geometry) (:y geometry) (:width geometry) (:height geometry)]))
271 (defn draw!
272 "Draws layer."
273 ([layer]
274 (let [graphics (create-graphics)]
275 (try
276 (binding [*graphics* graphics]
277 (render! layer))
278 (finally
279 (.dispose graphics)))))
280 ([layer x y]
281 (let [size (layer-size layer)]
282 (draw! layer x y (:width size) (:height size))))
283 ([layer x y width height]
284 (with-bounds* x y width height render! layer)))
286 ;; TODO: объект-сцена вместо context-draw!
287 ;; Сцена устанавливает контекст и рисует слой. Сцена - слой?
288 ;; Сцена идентифицирует группу обозревателя слоев.
289 ;; Обновления любого слоя, изображенного в сцене, вызывает обновление сцены.
290 ;; Обозреватель сцены вызывает repaint().
292 (defn context-draw!
293 "Sets up layer context, draws layer and commits event dispatcher."
294 ([layer graphics event-dispatcher update-fn width height]
295 (context-draw! layer nil graphics event-dispatcher update-fn width height))
296 ([layer component ^Graphics2D graphics event-dispatcher update-fn
297 width height]
298 (binding [*graphics* graphics
299 *font-context* (.getFontRenderContext graphics)
300 *initial-transform* (.getTransform graphics)
301 *inverse-initial-transform*
302 (-> graphics .getTransform .createInverse)
303 *target* component
304 *update* update-fn
305 *event-dispatcher* event-dispatcher
306 *width* width
307 *height* height
308 *clip* (Rectangle2D$Double. 0 0 width height)]
309 (apply-theme)
310 (render! layer)
311 (commit event-dispatcher))))
313 (defn draw-anchored!
314 "Draws layer. Location is relative to the layer's anchor point for
315 the specified alignment."
316 ([layer h-align v-align x y]
317 (let [anchor (anchor layer h-align v-align)]
318 (draw! layer (- x (:x anchor)) (- y (:y anchor)))))
319 ([layer h-align v-align x y w h]
320 (let [anchor (anchor layer h-align v-align)]
321 (draw! layer (- x (:x anchor)) (- y (:y anchor)) w h))))
323 ;;
324 ;; EventDispatcher implementation
325 ;;
327 (def awt-events
328 {java.awt.event.MouseEvent/MOUSE_CLICKED :mouse-clicked
329 java.awt.event.MouseEvent/MOUSE_DRAGGED :mouse-dragged
330 java.awt.event.MouseEvent/MOUSE_ENTERED :mouse-entered
331 java.awt.event.MouseEvent/MOUSE_EXITED :mouse-exited
332 java.awt.event.MouseEvent/MOUSE_MOVED :mouse-moved
333 java.awt.event.MouseEvent/MOUSE_PRESSED :mouse-pressed
334 java.awt.event.MouseEvent/MOUSE_RELEASED :mouse-released})
336 (def dummy-event-dispatcher
337 (reify
338 EventDispatcher
339 (listen! [this component])
340 (create-dispatcher [this handle handlers] this)
341 (commit [this])))
343 (defrecord DispatcherNode [handle handlers parent
344 ^Shape clip ^AffineTransform transform
345 bindings]
346 EventDispatcher
347 (listen! [this component]
348 (listen! parent component))
349 (create-dispatcher [this handle handlers]
350 (create-dispatcher parent handle handlers))
351 (commit [this]
352 (commit parent)))
354 (defn- make-node [handle handlers]
355 (DispatcherNode. handle handlers *event-dispatcher* *clip*
356 (inverse-relative-transform)
357 (get-thread-bindings)))
359 (defn- add-node [tree node]
360 (assoc-cons tree (:parent node) node))
362 (defn- under-cursor
363 "Returns a vector of child nodes under cursor."
364 [x y tree node]
365 (some #(if (.contains ^Shape (:clip %) x y)
366 (conj (vec (under-cursor x y tree %)) %))
367 (get tree node)))
369 (defn- remove-all [coll1 coll2 pred]
370 (filter #(not (some (partial pred %) coll2)) coll1))
372 (defn- transform [^AffineTransform tr x y]
373 (let [p (Point2D$Double. x y)]
374 (.transform tr p p)
375 [(.x p) (.y p)]))
377 (defn- translate-mouse-event [^java.awt.event.MouseEvent event
378 ^AffineTransform tr id]
379 (let [[x y] (transform tr (.getX event) (.getY event))]
380 (MouseEvent. id (.getWhen event) x y
381 (.getXOnScreen event) (.getYOnScreen event)
382 (.getButton event))))
384 (defn- translate-and-dispatch
385 ([nodes first-only ^java.awt.event.MouseEvent event]
386 (translate-and-dispatch nodes first-only
387 event (awt-events (.getID event))))
388 ([nodes first-only event id]
389 (if-let [node (first nodes)]
390 (if-let [handler (get (:handlers node) id)]
391 (do
392 (with-bindings* (:bindings node)
393 handler
394 (translate-mouse-event event (:transform node) id))
395 (if-not first-only
396 (recur (rest nodes) false event id)))
397 (recur (rest nodes) first-only event id)))))
399 (defn- dispatch-mouse-motion
400 "Dispatches mouse motion events."
401 [hovered-ref tree root ^java.awt.event.MouseEvent event]
402 (let [x (.getX event)
403 y (.getY event)
404 [hovered hovered2] (dosync
405 [@hovered-ref
406 (ref-set hovered-ref
407 (under-cursor x y tree root))])
408 pred #(= (:handle %1) (:handle %2))
409 exited (remove-all hovered hovered2 pred)
410 entered (remove-all hovered2 hovered pred)
411 moved (remove-all hovered2 entered pred)]
412 (translate-and-dispatch exited false event :mouse-exited)
413 (translate-and-dispatch entered false event :mouse-entered)
414 (translate-and-dispatch moved true event :mouse-moved)))
416 (defn- dispatch-mouse-button
417 [picked-ref hovered-ref ^java.awt.event.MouseEvent event]
418 (let [id (awt-events (.getID event))
419 hovered (if (= id :mouse-pressed)
420 (dosync (ref-set picked-ref @hovered-ref))
421 @hovered-ref)]
422 (translate-and-dispatch hovered true event id)))
424 (defn root-event-dispatcher []
425 (let [tree-r (ref {}) ; register
426 tree (ref {}) ; dispatch
427 hovered (ref '())
428 picked (ref '())]
429 (reify
430 EventDispatcher
431 (listen! [this component]
432 (doto component
433 (.addMouseListener this)
434 (.addMouseMotionListener this)))
435 (create-dispatcher [this handle handlers]
436 (let [node (make-node handle handlers)]
437 (dosync (alter tree-r add-node node))
438 node))
439 (commit [this]
440 (dosync (ref-set tree @tree-r)
441 (ref-set tree-r {})))
442 MouseListener
443 (mouseEntered [this event]
444 (dispatch-mouse-motion hovered @tree this event))
445 (mouseExited [this event]
446 (dispatch-mouse-motion hovered @tree this event))
447 (mouseClicked [this event]
448 (dispatch-mouse-button picked hovered event))
449 (mousePressed [this event]
450 (dispatch-mouse-button picked hovered event))
451 (mouseReleased [this event]
452 (translate-and-dispatch @picked true event))
453 ;;(dispatch-mouse-button picked hovered event))
454 MouseMotionListener
455 (mouseDragged [this event]
456 (translate-and-dispatch @picked true event))
457 (mouseMoved [this event]
458 (dispatch-mouse-motion hovered @tree this event)))))
460 ;;
461 ;; ИДЕИ:
462 ;;
463 ;; Контекст: биндинги или запись?
464 ;;
465 ;; Установка обработчиков (в контексте слоя):
466 ;;
467 ;; (listen
468 ;; (:mouse-entered e
469 ;; ...)
470 ;; (:mouse-exited e
471 ;; ...))
472 ;;
473 ;; Не надо IMGUI.
474 ;; Построение сцены путем декорирования слоев:
475 ;;
476 ;; (listener
477 ;; (:action e (println e))
478 ;; (:mouse-dragged e (println e))
479 ;; (theme :font "Helvetica-14"
480 ;; (vbox
481 ;; (button (text-layer "Button 1"))
482 ;; (button (text-layer "Button 2")))))
483 ;;