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