view src/net/kryshen/indyvon/core.clj @ 61:88bb47e3a401

Asynchronous drawing (first working version).
author Mikhail Kryshen <mikhail@kryshen.net>
date Wed, 25 Aug 2010 22:03:01 +0400
parents 7e456697924d
children 702a4939312d
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 ;;
106 ;; Rendering
107 ;;
109 (defn- relative-transform
110 "AffineTransform: layer context -> awt component."
111 []
112 (let [tr (.getTransform *graphics*)]
113 (.preConcatenate tr *inverse-initial-transform*)
114 tr))
116 (defn- inverse-relative-transform
117 "AffineTransform: awt component -> layer context."
118 []
119 (let [tr (.getTransform *graphics*)]
120 (.invert tr) ; absolute -> layer
121 (.concatenate tr *initial-transform*) ; component -> absolute
122 tr))
124 (defn- clip
125 "Intersect clipping area with the specified shape or bounds.
126 Returns new clip (Shape or nil if empty)."
127 ([x y w h]
128 (clip (Rectangle2D$Double. x y w h)))
129 ([shape]
130 (let [a1 (Area. shape)
131 a2 (if (instance? Area *clip*) *clip* (Area. *clip*))]
132 (.transform a1 (relative-transform))
133 (.intersect a1 a2)
134 (if (.isEmpty a1)
135 nil
136 a1))))
138 (defn- ^Graphics2D apply-theme
139 "Set graphics' color and font to match theme.
140 Modifies and returns the first argument."
141 ([]
142 (apply-theme *graphics* *theme*))
143 ([^Graphics2D graphics theme]
144 (doto graphics
145 (.setColor (:fore-color theme))
146 (.setFont (:font theme)))))
148 (defn- ^Graphics2D create-graphics
149 ([]
150 (create-graphics 0 0 *width* *height*))
151 ([x y w h]
152 (apply-theme (.create *graphics* x y w h) *theme*)))
154 (defn with-bounds*
155 [x y w h f & args]
156 (when-let [clip (clip x y w h)]
157 (let [graphics (create-graphics x y w h)]
158 (try
159 (binding [*width* w
160 *height* h
161 *clip* clip
162 *graphics* graphics]
163 (apply f args))
164 (finally
165 (.dispose graphics))))))
167 (defmacro with-bounds
168 [x y w h & body]
169 `(with-bounds* ~x ~y ~w ~h (fn [] ~@body)))
171 (defn with-handlers*
172 [handle handlers f & args]
173 (binding
174 [*event-dispatcher* (create-dispatcher
175 *event-dispatcher* handle handlers)]
176 (apply f args)))
178 (defmacro with-handlers
179 "specs => (:event-id name & handler-body)*
181 Execute form with the specified event handlers."
182 [handle form & specs]
183 `(with-handlers* ~handle
184 ~(reduce (fn [m spec]
185 (assoc m (first spec)
186 `(fn [~(second spec)]
187 ~@(nnext spec)))) {}
188 specs)
189 (fn [] ~form)))
191 (defmacro with-theme
192 [theme & body]
193 `(binding [*theme* (merge *theme* ~theme)]
194 ~@body))
196 (defmacro with-color
197 [color & body]
198 `(let [color# (.getColor *graphics*)]
199 (try
200 (.setColor *graphics* ~color)
201 ~@body
202 (finally
203 (.setColor *graphics* color#)))))
205 ;; TODO:
206 ;;
207 ;; (with-transform
208 ;; (rotate ...)
209 ;; (draw ...)
210 ;; (scale ...)
211 ;; (draw ...))
213 (defmacro with-transform [transform & body]
214 `(let [old-t# (.getTransform *graphics*)]
215 (try
216 (.transform *graphics* ~transform)
217 ~@body
218 (finally
219 (.setTransform *graphics* old-t#)))))
221 (defmacro with-rotate [theta ax ay & body]
222 `(let [transform# (AffineTransform/getRotateInstance ~theta ~ax ~ay)]
223 (with-transform transform# ~@body)))
225 (defn- geometry-vec [geometry]
226 (if (vector? geometry)
227 geometry
228 [(:x geometry) (:y geometry) (:width geometry) (:height geometry)]))
230 (defn draw!
231 "Draws layer."
232 ([layer]
233 (let [graphics (create-graphics)]
234 (try
235 (binding [*graphics* graphics]
236 (render! layer))
237 (finally
238 (.dispose graphics)))))
239 ([layer x y]
240 (let [size (layer-size layer)]
241 (draw! layer x y (:width size) (:height size))))
242 ([layer x y width height]
243 (with-bounds* x y width height render! layer)))
245 (defn context-draw!
246 "Sets up layer context, draws layer and commits event dispatcher."
247 ([layer graphics event-dispatcher update-fn width height]
248 (context-draw! layer nil graphics event-dispatcher update-fn width height))
249 ([layer component ^Graphics2D graphics event-dispatcher update-fn
250 width height]
251 (binding [*graphics* graphics
252 *font-context* (.getFontRenderContext graphics)
253 *initial-transform* (.getTransform graphics)
254 *inverse-initial-transform*
255 (-> graphics .getTransform .createInverse)
256 *target* component
257 *update* update-fn
258 *event-dispatcher* event-dispatcher
259 *width* width
260 *height* height
261 *clip* (Rectangle2D$Double. 0 0 width height)]
262 (apply-theme)
263 (render! layer)
264 (commit event-dispatcher))))
266 (defn draw-anchored!
267 "Draws layer. Location is relative to the layer's anchor point for
268 the specified alignment."
269 ([layer h-align v-align x y]
270 (let [anchor (anchor layer h-align v-align)]
271 (draw! layer (- x (:x anchor)) (- y (:y anchor)))))
272 ([layer h-align v-align x y w h]
273 (let [anchor (anchor layer h-align v-align)]
274 (draw! layer (- x (:x anchor)) (- y (:y anchor)) w h))))
276 ;;
277 ;; EventDispatcher implementation
278 ;;
280 (def awt-events
281 {java.awt.event.MouseEvent/MOUSE_CLICKED :mouse-clicked
282 java.awt.event.MouseEvent/MOUSE_DRAGGED :mouse-dragged
283 java.awt.event.MouseEvent/MOUSE_ENTERED :mouse-entered
284 java.awt.event.MouseEvent/MOUSE_EXITED :mouse-exited
285 java.awt.event.MouseEvent/MOUSE_MOVED :mouse-moved
286 java.awt.event.MouseEvent/MOUSE_PRESSED :mouse-pressed
287 java.awt.event.MouseEvent/MOUSE_RELEASED :mouse-released})
289 (def dummy-event-dispatcher
290 (reify
291 EventDispatcher
292 (listen! [this component])
293 (create-dispatcher [this handle handlers] this)
294 (commit [this])))
296 (defrecord DispatcherNode [handle handlers parent
297 ^Shape clip ^AffineTransform transform
298 bindings]
299 EventDispatcher
300 (listen! [this component]
301 (listen! parent component))
302 (create-dispatcher [this handle handlers]
303 (create-dispatcher parent handle handlers))
304 (commit [this]
305 (commit parent)))
307 (defn- make-node [handle handlers]
308 (DispatcherNode. handle handlers *event-dispatcher* *clip*
309 (inverse-relative-transform)
310 (get-thread-bindings)))
312 (defn- assoc-cons [m key val]
313 (assoc m key (cons val (get m key))))
315 (defn- add-node [tree node]
316 (assoc-cons tree (:parent node) node))
318 (defn- under-cursor
319 "Returns a vector of child nodes under cursor."
320 [x y tree node]
321 (some #(if (.contains ^Shape (:clip %) x y)
322 (conj (vec (under-cursor x y tree %)) %))
323 (get tree node)))
325 (defn- remove-all [coll1 coll2 pred]
326 (filter #(not (some (partial pred %) coll2)) coll1))
328 (defn- transform [^AffineTransform tr x y]
329 (let [p (Point2D$Double. x y)]
330 (.transform tr p p)
331 [(.x p) (.y p)]))
333 (defn- translate-mouse-event [^java.awt.event.MouseEvent event
334 ^AffineTransform tr id]
335 (let [[x y] (transform tr (.getX event) (.getY event))]
336 (MouseEvent. id (.getWhen event) x y
337 (.getXOnScreen event) (.getYOnScreen event)
338 (.getButton event))))
340 (defn- translate-and-dispatch
341 ([nodes first-only ^java.awt.event.MouseEvent event]
342 (translate-and-dispatch nodes first-only
343 event (awt-events (.getID event))))
344 ([nodes first-only event id]
345 (if-let [node (first nodes)]
346 (if-let [handler (get (:handlers node) id)]
347 (do
348 (with-bindings* (:bindings node)
349 handler
350 (translate-mouse-event event (:transform node) id))
351 (if-not first-only
352 (recur (rest nodes) false event id)))
353 (recur (rest nodes) first-only event id)))))
355 (defn- dispatch-mouse-motion
356 "Dispatches mouse motion events."
357 [hovered-ref tree root ^java.awt.event.MouseEvent event]
358 (let [x (.getX event)
359 y (.getY event)
360 [hovered hovered2] (dosync
361 [@hovered-ref
362 (ref-set hovered-ref
363 (under-cursor x y tree root))])
364 pred #(= (:handle %1) (:handle %2))
365 exited (remove-all hovered hovered2 pred)
366 entered (remove-all hovered2 hovered pred)
367 moved (remove-all hovered2 entered pred)]
368 (translate-and-dispatch exited false event :mouse-exited)
369 (translate-and-dispatch entered false event :mouse-entered)
370 (translate-and-dispatch moved true event :mouse-moved)))
372 (defn- dispatch-mouse-button
373 [picked-ref hovered-ref ^java.awt.event.MouseEvent event]
374 (let [id (awt-events (.getID event))
375 hovered (if (= id :mouse-pressed)
376 (dosync (ref-set picked-ref @hovered-ref))
377 @hovered-ref)]
378 (translate-and-dispatch hovered true event id)))
380 (defn root-event-dispatcher []
381 (let [tree-r (ref {}) ; register
382 tree (ref {}) ; dispatch
383 hovered (ref '())
384 picked (ref '())]
385 (reify
386 EventDispatcher
387 (listen! [this component]
388 (doto component
389 (.addMouseListener this)
390 (.addMouseMotionListener this)))
391 (create-dispatcher [this handle handlers]
392 (let [node (make-node handle handlers)]
393 (dosync (alter tree-r add-node node))
394 node))
395 (commit [this]
396 (dosync (ref-set tree @tree-r)
397 (ref-set tree-r {})))
398 MouseListener
399 (mouseEntered [this event]
400 (dispatch-mouse-motion hovered @tree this event))
401 (mouseExited [this event]
402 (dispatch-mouse-motion hovered @tree this event))
403 (mouseClicked [this event]
404 (dispatch-mouse-button picked hovered event))
405 (mousePressed [this event]
406 (dispatch-mouse-button picked hovered event))
407 (mouseReleased [this event]
408 (translate-and-dispatch @picked true event))
409 ;;(dispatch-mouse-button picked hovered event))
410 MouseMotionListener
411 (mouseDragged [this event]
412 (translate-and-dispatch @picked true event))
413 (mouseMoved [this event]
414 (dispatch-mouse-motion hovered @tree this event)))))
416 ;;
417 ;; ИДЕИ:
418 ;;
419 ;; Контекст: биндинги или запись?
420 ;;
421 ;; Установка обработчиков (в контексте слоя):
422 ;;
423 ;; (listen
424 ;; (:mouse-entered e
425 ;; ...)
426 ;; (:mouse-exited e
427 ;; ...))
428 ;;
429 ;; Не надо IMGUI.
430 ;; Построение сцены путем декорирования слоев:
431 ;;
432 ;; (listener
433 ;; (:action e (println e))
434 ;; (:mouse-dragged e (println e))
435 ;; (theme :font "Helvetica-14"
436 ;; (vbox
437 ;; (button (text-layer "Button 1"))
438 ;; (button (text-layer "Button 2")))))
439 ;;