Mercurial > hg > indyvon
view src/net/kryshen/indyvon/core.clj @ 50:409b1b16053d
Code cleanup and docstrings.
| author | Mikhail Kryshen <mikhail@kryshen.net> |
|---|---|
| date | Thu, 29 Jul 2010 01:28:30 +0400 |
| parents | ca728127d605 |
| children | a20b1fccc0ef |
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)
10 (java.awt.event MouseListener MouseMotionListener)
11 (java.awt.font FontRenderContext)))
13 (def ^Graphics2D *graphics*)
14 (def ^FontRenderContext *font-context*)
15 (def ^Component *target*)
16 (def *bounds*)
17 (def *clip*)
18 (def *update*)
19 (def *event-dispatcher*)
21 (defrecord Theme [fore-color back-color alt-back-color border-color font])
23 (defn default-theme []
24 (Theme. Color/BLACK Color/LIGHT_GRAY Color/WHITE
25 Color/BLUE (Font. "Sans" Font/PLAIN 12)))
27 (def *theme* (default-theme))
29 (defrecord Location [x y])
30 (defrecord Size [width height])
31 (defrecord Bounds [x y width height])
33 (defprotocol Layer
34 "Basic UI element."
35 (render! [this])
36 (layer-size [this]))
38 ;; TODO: modifiers
39 (defrecord MouseEvent [id when x y x-on-screen y-on-screen button])
41 (defprotocol EventDispatcher
42 (listen! [this ^Component component]
43 "Listen for events on the specified AWT Component.")
44 (create-dispatcher [this handle handlers]
45 "Returns new event dispatcher associated with the specified event
46 handlers (an event-id -> handler-fn map). Handle is used to
47 match the contexts between commits.")
48 (commit [this]
49 "Apply the registered handlers for event processing."))
51 (defprotocol Anchored
52 "Provide anchor point for Layers. Used by viewport."
53 (anchor [this h-align v-align]
54 "Anchor point: [x y], h-align could be :left, :center or :right,
55 v-align is :top, :center or :bottom"))
57 ;; Default implementation of Anchored for any Layer.
58 (extend-protocol Anchored
59 net.kryshen.indyvon.core.Layer
60 (anchor [this h-align v-align]
61 (if (and (= h-align :left)
62 (= v-align :top))
63 (Location. 0 0)
64 (let [size (layer-size this)]
65 (Location.
66 (case h-align
67 :top 0
68 :center (/ (:width size) 2)
69 :right (:width size))
70 (case v-align
71 :left 0
72 :center (/ (:height size) 2)
73 :bottom (:height size)))))))
75 (defn- ^Graphics2D make-graphics [^Graphics2D graphics x y w h]
76 (.create graphics x y w h))
78 (defn- ^Graphics2D apply-theme [^Graphics2D graphics theme]
79 (doto graphics
80 (.setColor (:fore-color theme))
81 (.setFont (:font theme))))
83 (defn intersect
84 "Compute intersection between a pair of rectangles (Bounds)."
85 ([b1 b2]
86 (let [x1 (:x b1)
87 y1 (:y b1)
88 x2 (:x b2)
89 y2 (:y b2)]
90 (intersect x1 y1 (+ x1 (:width b1)) (+ y1 (:height b1))
91 x2 y2 (+ x2 (:width b2)) (+ y2 (:height b2)))))
92 ([x11 y11 x12 y12, x21 y21 x22 y22]
93 (let [x1 (max x11 x21)
94 y1 (max y11 y21)
95 x2 (min x12 x22)
96 y2 (min y12 y22)]
97 (Bounds. x1 y1 (- x2 x1) (- y2 y1)))))
99 (defn ^Graphics2D create-graphics
100 ([]
101 (create-graphics 0 0 (:width *bounds*) (:height *bounds*)))
102 ([x y w h]
103 (apply-theme (.create *graphics* x y w h) *theme*)))
105 (defmacro with-bounds [x y w h & body]
106 `(let [bounds# (Bounds. (+ ~x (:x *bounds*))
107 (+ ~y (:y *bounds*))
108 ~w ~h)
109 clip# (intersect bounds# *clip*)]
110 (when (and (pos? (:width clip#)) (pos? (:height clip#)))
111 (let [graphics# (create-graphics ~x ~y ~w ~h)]
112 (try
113 (binding [*bounds* bounds#
114 *clip* clip#
115 *graphics* graphics#]
116 ~@body)
117 (finally
118 (.dispose graphics#)))))))
120 (defmacro with-handlers* [handle handlers & body]
121 `(binding
122 [*event-dispatcher*
123 (create-dispatcher *event-dispatcher* ~handle ~handlers)]
124 ~@body))
126 (defmacro with-handlers
127 "specs => (:event-id name & handler-body)*
129 Execute form with the specified event handlers."
130 [handle form & specs]
131 `(with-handlers* ~handle
132 ~(reduce (fn [m spec]
133 (assoc m (first spec)
134 `(fn [~(second spec)]
135 ~@(nnext spec)))) {}
136 specs)
137 ~form))
139 (defn with-theme* [theme f & args]
140 (apply with-bindings* {#'*theme* (merge *theme* theme)}
141 f args))
143 (defmacro with-theme [theme & body]
144 `(binding [*theme* (merge *theme* ~theme)]
145 ~@body))
147 (defmacro with-color [color & body]
148 `(let [color# (.getColor *graphics*)]
149 (try
150 (.setColor *graphics* ~color)
151 ~@body
152 (finally
153 (.setColor *graphics* color#)))))
155 (defn- geometry-vec [geometry]
156 (if (vector? geometry)
157 geometry
158 [(:x geometry) (:y geometry) (:width geometry) (:height geometry)]))
160 (defn draw!
161 ([layer]
162 (let [graphics (create-graphics)]
163 (try
164 (binding [*graphics* graphics]
165 (render! layer))
166 (finally
167 (.dispose graphics)))))
168 ([layer x y]
169 (let [size (layer-size layer)]
170 (draw! layer x y (:width size) (:height size))))
171 ([layer x y width height]
172 (with-bounds x y width height
173 (render! layer))))
175 (defn draw-anchored!
176 "Draw with location relative to the anchor point."
177 ([layer h-align v-align x y]
178 (let [anchor (anchor layer h-align v-align)]
179 (draw! layer (- x (:x anchor)) (- y (:y anchor)))))
180 ([layer h-align v-align x y w h]
181 (let [anchor (anchor layer h-align v-align)]
182 (draw! layer (- x (:x anchor)) (- y (:y anchor)) w h))))
184 ;;
185 ;; EventDispatcher implementation
186 ;;
188 (def awt-events
189 {java.awt.event.MouseEvent/MOUSE_CLICKED :mouse-clicked
190 java.awt.event.MouseEvent/MOUSE_DRAGGED :mouse-dragged
191 java.awt.event.MouseEvent/MOUSE_ENTERED :mouse-entered
192 java.awt.event.MouseEvent/MOUSE_EXITED :mouse-exited
193 java.awt.event.MouseEvent/MOUSE_MOVED :mouse-moved
194 java.awt.event.MouseEvent/MOUSE_PRESSED :mouse-pressed
195 java.awt.event.MouseEvent/MOUSE_RELEASED :mouse-released})
197 (defrecord DispatcherNode [handle handlers parent bounds bindings]
198 EventDispatcher
199 (listen! [this component]
200 (listen! parent component))
201 (create-dispatcher [this handle handlers]
202 (create-dispatcher parent handle handlers))
203 (commit [this]
204 (commit parent)))
206 (defn- make-node [handle handlers]
207 (DispatcherNode. handle handlers *event-dispatcher* *clip*
208 (get-thread-bindings)))
210 (defn- assoc-cons [m key val]
211 (assoc m key (cons val (get m key))))
213 (defn- add-node [tree node]
214 (assoc-cons tree (:parent node) node))
216 (defn- inside?
217 ([x y bounds]
218 (inside? x y (:x bounds) (:y bounds)
219 (:width bounds) (:height bounds)))
220 ([px py x y w h]
221 (and (>= px x)
222 (>= py y)
223 (< px (+ x w))
224 (< py (+ y h)))))
226 (defn- under-cursor
227 "Returns a vector of child nodes under cursor."
228 [x y tree node]
229 (some #(if (inside? x y (:bounds %))
230 (conj (vec (under-cursor x y tree %)) %))
231 (get tree node)))
233 (defn- remove-all [coll1 coll2 pred]
234 (filter #(not (some (partial pred %) coll2)) coll1))
236 (defn- translate-mouse-event [^java.awt.event.MouseEvent event x y id]
237 (MouseEvent. id (.getWhen event)
238 (- (.getX event) x) (- (.getY event) y)
239 (.getXOnScreen event) (.getYOnScreen event)
240 (.getButton event)))
242 (defn- translate-and-dispatch
243 ([nodes first-only ^java.awt.event.MouseEvent event]
244 (translate-and-dispatch nodes first-only
245 event (awt-events (.getID event))))
246 ([nodes first-only event id]
247 (if-let [node (first nodes)]
248 (if-let [handler (get (:handlers node) id)]
249 (do
250 (with-bindings* (:bindings node)
251 handler
252 (translate-mouse-event event
253 (-> node :bounds :x) (-> node :bounds :y) id))
254 (if-not first-only
255 (recur (rest nodes) false event id)))
256 (recur (rest nodes) first-only event id)))))
258 (defn- dispatch-mouse-motion
259 "Dispatches mouse motion events."
260 [hovered-ref tree root ^java.awt.event.MouseEvent event]
261 (let [x (.getX event)
262 y (.getY event)
263 [hovered hovered2] (dosync
264 [@hovered-ref
265 (ref-set hovered-ref
266 (under-cursor x y tree root))])
267 pred #(= (:handle %1) (:handle %2))
268 exited (remove-all hovered hovered2 pred)
269 entered (remove-all hovered2 hovered pred)
270 moved (remove-all hovered2 entered pred)]
271 (translate-and-dispatch exited false event :mouse-exited)
272 (translate-and-dispatch entered false event :mouse-entered)
273 (translate-and-dispatch moved true event :mouse-moved)))
275 (defn- dispatch-mouse-button
276 [picked-ref hovered-ref ^java.awt.event.MouseEvent event]
277 (let [id (awt-events (.getID event))
278 hovered (if (= id :mouse-pressed)
279 (dosync (ref-set picked-ref @hovered-ref))
280 @hovered-ref)]
281 (translate-and-dispatch hovered true event id)))
283 (defn root-event-dispatcher []
284 (let [tree-r (ref {}) ; register
285 tree (ref {}) ; dispatch
286 hovered (ref '())
287 picked (ref '())]
288 (reify
289 EventDispatcher
290 (listen! [this component]
291 (doto component
292 (.addMouseListener this)
293 (.addMouseMotionListener this)))
294 (create-dispatcher [this handle handlers]
295 (let [node (make-node handle handlers)]
296 (dosync (alter tree-r add-node node))
297 node))
298 (commit [this]
299 (dosync (ref-set tree @tree-r)
300 (ref-set tree-r {})))
301 MouseListener
302 (mouseEntered [this event]
303 (dispatch-mouse-motion hovered @tree this event))
304 (mouseExited [this event]
305 (dispatch-mouse-motion hovered @tree this event))
306 (mouseClicked [this event]
307 (dispatch-mouse-button picked hovered event))
308 (mousePressed [this event]
309 (dispatch-mouse-button picked hovered event))
310 (mouseReleased [this event]
311 (translate-and-dispatch @picked true event))
312 ;;(dispatch-mouse-button picked hovered event))
313 MouseMotionListener
314 (mouseDragged [this event]
315 (translate-and-dispatch @picked true event))
316 (mouseMoved [this event]
317 (dispatch-mouse-motion hovered @tree this event)))))
319 ;;
320 ;; ИДЕИ:
321 ;;
322 ;; Контекст: биндинги или запись?
323 ;;
324 ;; Установка обработчиков (в контексте слоя):
325 ;;
326 ;; (listen
327 ;; (:mouse-entered e
328 ;; ...)
329 ;; (:mouse-exited e
330 ;; ...))
331 ;;
332 ;; Не надо IMGUI.
333 ;; Построение сцены путем декорирования слоев:
334 ;;
335 ;; (listener
336 ;; (:action e (println e))
337 ;; (:mouse-dragged e (println e))
338 ;; (theme :font "Helvetica-14"
339 ;; (vbox
340 ;; (button (text-layer "Button 1"))
341 ;; (button (text-layer "Button 2")))))
342 ;;