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