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