Mercurial > hg > indyvon
view src/net/kryshen/indyvon/core.clj @ 54:1d2dfe5026a8
Support transformations.
| author | Mikhail Kryshen <mikhail@kryshen.net> |
|---|---|
| date | Thu, 19 Aug 2010 20:20:21 +0400 |
| parents | a20b1fccc0ef |
| children | 6adbc03a52cb |
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 (def ^Graphics2D *graphics*)
15 (def ^FontRenderContext *font-context*)
16 (def ^Component *target*)
17 (def *bounds*)
18 (def ^Shape *clip*)
19 (def *update*)
20 (def *event-dispatcher*)
22 (def ^AffineTransform *initial-transform*)
23 (def ^AffineTransform *inverse-initial-transform*)
25 (defrecord Theme [fore-color back-color alt-back-color border-color font])
27 (defn default-theme []
28 (Theme. Color/BLACK Color/LIGHT_GRAY Color/WHITE
29 Color/BLUE (Font. "Sans" Font/PLAIN 12)))
31 (def *theme* (default-theme))
33 (defrecord Location [x y])
34 (defrecord Size [width height])
35 (defrecord Bounds [x y width height])
37 (defprotocol Layer
38 "Basic UI element."
39 (render! [this])
40 (layer-size [this]))
42 ;; TODO: modifiers
43 (defrecord MouseEvent [id when x y x-on-screen y-on-screen button])
45 (defprotocol EventDispatcher
46 (listen! [this ^Component component]
47 "Listen for events on the specified AWT Component.")
48 (create-dispatcher [this handle handlers]
49 "Returns new event dispatcher associated with the specified event
50 handlers (an event-id -> handler-fn map). Handle is used to
51 match the contexts between commits.")
52 (commit [this]
53 "Apply the registered handlers for event processing."))
55 (defprotocol Anchored
56 "Provide anchor point for Layers. Used by viewport."
57 (anchor [this h-align v-align]
58 "Anchor point: [x y], h-align could be :left, :center or :right,
59 v-align is :top, :center or :bottom"))
61 ;; Default implementation of Anchored for any Layer.
62 (extend-protocol Anchored
63 net.kryshen.indyvon.core.Layer
64 (anchor [this h-align v-align]
65 (if (and (= h-align :left)
66 (= v-align :top))
67 (Location. 0 0)
68 (let [size (layer-size this)]
69 (Location.
70 (case h-align
71 :top 0
72 :center (/ (:width size) 2)
73 :right (:width size))
74 (case v-align
75 :left 0
76 :center (/ (:height size) 2)
77 :bottom (:height size)))))))
79 (defn- ^Graphics2D make-graphics [^Graphics2D graphics x y w h]
80 (.create graphics x y w h))
82 (defn- ^Graphics2D apply-theme [^Graphics2D graphics theme]
83 (doto graphics
84 (.setColor (:fore-color theme))
85 (.setFont (:font theme))))
87 (defn intersect
88 "Compute intersection between a pair of rectangles (Bounds)."
89 ([b1 b2]
90 (let [x1 (:x b1)
91 y1 (:y b1)
92 x2 (:x b2)
93 y2 (:y b2)]
94 (intersect x1 y1 (+ x1 (:width b1)) (+ y1 (:height b1))
95 x2 y2 (+ x2 (:width b2)) (+ y2 (:height b2)))))
96 ([x11 y11 x12 y12, x21 y21 x22 y22]
97 (let [x1 (max x11 x21)
98 y1 (max y11 y21)
99 x2 (min x12 x22)
100 y2 (min y12 y22)]
101 (Bounds. x1 y1 (- x2 x1) (- y2 y1)))))
103 (defn- relative-transform
104 "AffineTransform: layer -> absolute -> component."
105 []
106 (let [tr (.getTransform *graphics*)]
107 (.preConcatenate tr *inverse-initial-transform*)
108 tr))
110 (defn- inverse-relative-transform
111 "AffineTransform: component (event) -> absolute -> layer."
112 []
113 (let [tr (.getTransform *graphics*)]
114 (.invert tr) ; absolute -> layer
115 (.concatenate tr *initial-transform*) ; component -> absolute
116 tr))
118 (defn clip
119 "Intersect clipping area with the specified shape or bounds.
120 Returns new clip (Shape or nil if empty)."
121 ([x y w h]
122 (clip (Rectangle2D$Double. x y w h)))
123 ([shape]
124 (let [a1 (Area. shape)
125 a2 (if (instance? Area *clip*) *clip* (Area. *clip*))]
126 (.transform a1 (relative-transform))
127 (.intersect a1 a2)
128 (if (.isEmpty a1)
129 nil
130 a1))))
132 (defn ^Graphics2D create-graphics
133 ([]
134 (create-graphics 0 0 (:width *bounds*) (:height *bounds*)))
135 ([x y w h]
136 (apply-theme (.create *graphics* x y w h) *theme*)))
138 (defmacro with-bounds [x y w h & body]
139 `(let [bounds# (Bounds. (+ ~x (:x *bounds*))
140 (+ ~y (:y *bounds*)) ~w ~h)
141 clip# (clip ~x ~y ~w ~h)]
142 (when clip#
143 (let [graphics# (create-graphics ~x ~y ~w ~h)]
144 (try
145 (binding [*bounds* bounds#
146 *clip* clip#
147 *graphics* graphics#]
148 ~@body)
149 (finally
150 (.dispose graphics#)))))))
152 (defmacro with-handlers* [handle handlers & body]
153 `(binding
154 [*event-dispatcher*
155 (create-dispatcher *event-dispatcher* ~handle ~handlers)]
156 ~@body))
158 (defmacro with-handlers
159 "specs => (:event-id name & handler-body)*
161 Execute form with the specified event handlers."
162 [handle form & specs]
163 `(with-handlers* ~handle
164 ~(reduce (fn [m spec]
165 (assoc m (first spec)
166 `(fn [~(second spec)]
167 ~@(nnext spec)))) {}
168 specs)
169 ~form))
171 (defn with-theme* [theme f & args]
172 (apply with-bindings* {#'*theme* (merge *theme* theme)}
173 f args))
175 (defmacro with-theme [theme & body]
176 `(binding [*theme* (merge *theme* ~theme)]
177 ~@body))
179 (defmacro with-color [color & body]
180 `(let [color# (.getColor *graphics*)]
181 (try
182 (.setColor *graphics* ~color)
183 ~@body
184 (finally
185 (.setColor *graphics* color#)))))
187 ;; TODO:
188 ;;
189 ;; (with-transform
190 ;; (rotate ...)
191 ;; (draw ...)
192 ;; (scale ...)
193 ;; (draw ...))
195 (defmacro with-transform [transform & body]
196 `(let [old-t# (.getTransform *graphics*)]
197 (try
198 (.transform *graphics* ~transform)
199 ~@body
200 (finally
201 (.setTransform *graphics* old-t#)))))
203 (defmacro with-rotate [theta ax ay & body]
204 `(let [transform# (AffineTransform/getRotateInstance ~theta ~ax ~ay)]
205 (with-transform transform# ~@body)))
207 (defn- geometry-vec [geometry]
208 (if (vector? geometry)
209 geometry
210 [(:x geometry) (:y geometry) (:width geometry) (:height geometry)]))
212 (defn draw!
213 ([layer]
214 (let [graphics (create-graphics)]
215 (try
216 (binding [*graphics* graphics]
217 (render! layer))
218 (finally
219 (.dispose graphics)))))
220 ([layer x y]
221 (let [size (layer-size layer)]
222 (draw! layer x y (:width size) (:height size))))
223 ([layer x y width height]
224 (with-bounds x y width height
225 (render! layer))))
227 (defn draw-anchored!
228 "Draw with location relative to the anchor point."
229 ([layer h-align v-align x y]
230 (let [anchor (anchor layer h-align v-align)]
231 (draw! layer (- x (:x anchor)) (- y (:y anchor)))))
232 ([layer h-align v-align x y w h]
233 (let [anchor (anchor layer h-align v-align)]
234 (draw! layer (- x (:x anchor)) (- y (:y anchor)) w h))))
236 ;;
237 ;; EventDispatcher implementation
238 ;;
240 (def awt-events
241 {java.awt.event.MouseEvent/MOUSE_CLICKED :mouse-clicked
242 java.awt.event.MouseEvent/MOUSE_DRAGGED :mouse-dragged
243 java.awt.event.MouseEvent/MOUSE_ENTERED :mouse-entered
244 java.awt.event.MouseEvent/MOUSE_EXITED :mouse-exited
245 java.awt.event.MouseEvent/MOUSE_MOVED :mouse-moved
246 java.awt.event.MouseEvent/MOUSE_PRESSED :mouse-pressed
247 java.awt.event.MouseEvent/MOUSE_RELEASED :mouse-released})
249 (defrecord DispatcherNode [handle handlers parent
250 ^Shape clip ^AffineTransform transform
251 bindings]
252 EventDispatcher
253 (listen! [this component]
254 (listen! parent component))
255 (create-dispatcher [this handle handlers]
256 (create-dispatcher parent handle handlers))
257 (commit [this]
258 (commit parent)))
260 (defn- make-node [handle handlers]
261 (DispatcherNode. handle handlers *event-dispatcher* *clip*
262 (inverse-relative-transform)
263 (get-thread-bindings)))
265 (defn- assoc-cons [m key val]
266 (assoc m key (cons val (get m key))))
268 (defn- add-node [tree node]
269 (assoc-cons tree (:parent node) node))
271 (defn- under-cursor
272 "Returns a vector of child nodes under cursor."
273 [x y tree node]
274 (some #(if (.contains (:clip %) x y)
275 (conj (vec (under-cursor x y tree %)) %))
276 (get tree node)))
278 (defn- remove-all [coll1 coll2 pred]
279 (filter #(not (some (partial pred %) coll2)) coll1))
281 (defn- transform [^AffineTransform tr x y]
282 (let [p (Point2D$Double. x y)]
283 (.transform tr p p)
284 [(.x p) (.y p)]))
286 (defn- translate-mouse-event [^java.awt.event.MouseEvent event
287 ^AffineTransform tr id]
288 (let [[x y] (transform tr (.getX event) (.getY event))]
289 (MouseEvent. id (.getWhen event) x y
290 (.getXOnScreen event) (.getYOnScreen event)
291 (.getButton event))))
293 (defn- translate-and-dispatch
294 ([nodes first-only ^java.awt.event.MouseEvent event]
295 (translate-and-dispatch nodes first-only
296 event (awt-events (.getID event))))
297 ([nodes first-only event id]
298 (if-let [node (first nodes)]
299 (if-let [handler (get (:handlers node) id)]
300 (do
301 (with-bindings* (:bindings node)
302 handler
303 (translate-mouse-event event (:transform node) id))
304 (if-not first-only
305 (recur (rest nodes) false event id)))
306 (recur (rest nodes) first-only event id)))))
308 (defn- dispatch-mouse-motion
309 "Dispatches mouse motion events."
310 [hovered-ref tree root ^java.awt.event.MouseEvent event]
311 (let [x (.getX event)
312 y (.getY event)
313 [hovered hovered2] (dosync
314 [@hovered-ref
315 (ref-set hovered-ref
316 (under-cursor x y tree root))])
317 pred #(= (:handle %1) (:handle %2))
318 exited (remove-all hovered hovered2 pred)
319 entered (remove-all hovered2 hovered pred)
320 moved (remove-all hovered2 entered pred)]
321 (translate-and-dispatch exited false event :mouse-exited)
322 (translate-and-dispatch entered false event :mouse-entered)
323 (translate-and-dispatch moved true event :mouse-moved)))
325 (defn- dispatch-mouse-button
326 [picked-ref hovered-ref ^java.awt.event.MouseEvent event]
327 (let [id (awt-events (.getID event))
328 hovered (if (= id :mouse-pressed)
329 (dosync (ref-set picked-ref @hovered-ref))
330 @hovered-ref)]
331 (translate-and-dispatch hovered true event id)))
333 (defn root-event-dispatcher []
334 (let [tree-r (ref {}) ; register
335 tree (ref {}) ; dispatch
336 hovered (ref '())
337 picked (ref '())]
338 (reify
339 EventDispatcher
340 (listen! [this component]
341 (doto component
342 (.addMouseListener this)
343 (.addMouseMotionListener this)))
344 (create-dispatcher [this handle handlers]
345 (let [node (make-node handle handlers)]
346 (dosync (alter tree-r add-node node))
347 node))
348 (commit [this]
349 (dosync (ref-set tree @tree-r)
350 (ref-set tree-r {})))
351 MouseListener
352 (mouseEntered [this event]
353 (dispatch-mouse-motion hovered @tree this event))
354 (mouseExited [this event]
355 (dispatch-mouse-motion hovered @tree this event))
356 (mouseClicked [this event]
357 (dispatch-mouse-button picked hovered event))
358 (mousePressed [this event]
359 (dispatch-mouse-button picked hovered event))
360 (mouseReleased [this event]
361 (translate-and-dispatch @picked true event))
362 ;;(dispatch-mouse-button picked hovered event))
363 MouseMotionListener
364 (mouseDragged [this event]
365 (translate-and-dispatch @picked true event))
366 (mouseMoved [this event]
367 (dispatch-mouse-motion hovered @tree this event)))))
369 ;;
370 ;; ИДЕИ:
371 ;;
372 ;; Контекст: биндинги или запись?
373 ;;
374 ;; Установка обработчиков (в контексте слоя):
375 ;;
376 ;; (listen
377 ;; (:mouse-entered e
378 ;; ...)
379 ;; (:mouse-exited e
380 ;; ...))
381 ;;
382 ;; Не надо IMGUI.
383 ;; Построение сцены путем декорирования слоев:
384 ;;
385 ;; (listener
386 ;; (:action e (println e))
387 ;; (:mouse-dragged e (println e))
388 ;; (theme :font "Helvetica-14"
389 ;; (vbox
390 ;; (button (text-layer "Button 1"))
391 ;; (button (text-layer "Button 2")))))
392 ;;