Mercurial > hg > indyvon
view src/kryshen/indyvon/core.clj @ 38:af3187fdc44d
Type hint.
| author | Mikhail Kryshen <mikhail@kryshen.net> |
|---|---|
| date | Fri, 09 Jul 2010 01:11:01 +0400 |
| parents | d2fb660ca49f |
| children | 930c088e1367 |
line source
1 ;;
2 ;; Copyright (C) 2010 Mikhail Kryshen <mikhail@kryshen.net>
3 ;;
4 ;; This file is part of Indyvon.
5 ;;
7 (ns kryshen.indyvon.core
8 (:import (java.awt Graphics2D Component Color Font)
9 (java.awt.event MouseListener MouseMotionListener)
10 (java.awt.font FontRenderContext)))
12 (def ^Graphics2D *graphics*)
13 (def ^FontRenderContext *font-context*)
14 (def ^Component *target*)
15 (def *bounds*)
16 (def *clip*)
17 (def *update*)
18 (def *event-dispatcher*)
20 (defrecord Theme [fore-color back-color border-color font])
22 (defn default-theme []
23 (Theme. Color/BLACK Color/WHITE Color/BLUE (Font. "Sans" Font/PLAIN 12)))
25 (def *theme* (default-theme))
27 (defrecord Location [x y])
28 (defrecord Size [width height])
29 (defrecord Bounds [x y width height])
31 (defprotocol Layer
32 "Basic UI element."
33 (render! [this])
34 (size [this]))
36 ;; TODO: modifiers
37 (defrecord MouseEvent [id when x y x-on-screen y-on-screen button])
39 (defprotocol EventDispatcher
40 (listen! [this ^Component component]
41 "Listen for events on the specified AWT Component.")
42 (create-dispatcher [this handle handlers]
43 "Returns new event dispatcher associated with the specified event
44 handlers (an event-id -> handler-fn map). Handle is used to
45 match the contexts between commits.")
46 (commit [this]
47 "Apply the registered handlers for event processing."))
49 (defprotocol Anchored
50 "Provide anchor point for Layers. Used by viewport."
51 (anchor [this h-align v-align]
52 "Anchor point: [x y], h-align could be :left, :center or :right,
53 v-align is :top, :center or :bottom"))
55 ;; Default implementation of Anchored for any Layer.
56 (extend-protocol Anchored
57 kryshen.indyvon.core.Layer
58 (anchor [this h-align v-align]
59 (if (and (= h-align :left)
60 (= v-align :top))
61 (Location. 0 0)
62 (let [size (size this)]
63 (Location.
64 (case h-align
65 :top 0
66 :center (/ (:width size) 2)
67 :right (:width size))
68 (case v-align
69 :left 0
70 :center (/ (:height size) 2)
71 :bottom (:height size)))))))
73 (defn- ^Graphics2D make-graphics [^Graphics2D graphics x y w h]
74 (.create graphics x y w h))
76 (defn- ^Graphics2D apply-theme [^Graphics2D graphics theme]
77 (doto graphics
78 (.setColor (:fore-color theme))
79 (.setFont (:font theme))))
81 (defn intersect
82 ([b1 b2]
83 (let [x1 (:x b1)
84 y1 (:y b1)
85 x2 (:x b2)
86 y2 (:y b2)]
87 (intersect x1 y1 (+ x1 (:width b1)) (+ y1 (:height b1))
88 x2 y2 (+ x2 (:width b2)) (+ y2 (:height b2)))))
89 ([x11 y11 x12 y12, x21 y21 x22 y22]
90 (let [x1 (max x11 x21)
91 y1 (max y11 y21)
92 x2 (min x12 x22)
93 y2 (min y12 y22)]
94 (Bounds. x1 y1 (- x2 x1) (- y2 y1)))))
96 (defn- ^Graphics2D create-graphics
97 ([]
98 (create-graphics 0 0 (:width *bounds*) (:height *bounds*)))
99 ([x y w h]
100 (apply-theme (.create *graphics* x y w h) *theme*)))
102 (defn with-translate* [x y w h f & args]
103 (let [graphics (create-graphics x y w h)
104 bounds (Bounds. (+ x (:x *bounds*))
105 (+ y (:y *bounds*))
106 w h)]
107 (try
108 (apply with-bindings* {#'*bounds* bounds
109 #'*clip* (intersect bounds *clip*)
110 #'*graphics* graphics}
111 f args)
112 (finally
113 (.dispose graphics)))))
115 (defmacro with-translate [x y w h & body]
116 `(with-translate* ~x ~y ~w ~h (fn [] ~@body)))
118 (defn with-handlers* [handle handlers f & args]
119 (apply with-bindings*
120 {#'*event-dispatcher*
121 (create-dispatcher *event-dispatcher* handle handlers)}
122 f args))
124 (defmacro with-handlers
125 "specs => (:event-id name & handler-body)*
127 Execute form with the specified event handlers."
128 [handle form & specs]
129 `(with-handlers* ~handle
130 ~(reduce (fn [m spec]
131 (assoc m (first spec)
132 `(fn [~(second spec)]
133 ~@(nnext spec)))) {}
134 specs)
135 (fn [] ~form)))
137 (defn- geometry-vec [geometry]
138 (if (vector? geometry)
139 geometry
140 [(:x geometry) (:y geometry) (:width geometry) (:height geometry)]))
142 (defn draw!
143 ([layer]
144 (let [graphics (create-graphics)]
145 (try
146 (with-bindings* {#'*graphics* graphics} render! layer)
147 (finally
148 (.dispose graphics)))))
149 ([layer x y]
150 (let [size (size layer)]
151 (draw! layer x y (:width size) (:height size))))
152 ([layer x y width height]
153 (with-translate* x y width height render! layer)))
155 ;;
156 ;; EventDispatcher implementation
157 ;;
159 (def awt-events
160 {java.awt.event.MouseEvent/MOUSE_CLICKED :mouse-clicked
161 java.awt.event.MouseEvent/MOUSE_DRAGGED :mouse-dragged
162 java.awt.event.MouseEvent/MOUSE_ENTERED :mouse-entered
163 java.awt.event.MouseEvent/MOUSE_EXITED :mouse-exited
164 java.awt.event.MouseEvent/MOUSE_MOVED :mouse-moved
165 java.awt.event.MouseEvent/MOUSE_PRESSED :mouse-pressed
166 java.awt.event.MouseEvent/MOUSE_RELEASED :mouse-released})
168 (defrecord DispatcherNode [handle handlers parent bounds bindings]
169 EventDispatcher
170 (listen! [this component]
171 (listen! parent component))
172 (create-dispatcher [this handle handlers]
173 (create-dispatcher parent handle handlers))
174 (commit [this]
175 (commit parent)))
177 (defn- make-node [handle handlers]
178 (DispatcherNode. handle handlers *event-dispatcher* *clip*
179 (get-thread-bindings)))
181 (defn- assoc-cons [m key val]
182 (assoc m key (cons val (get m key))))
184 (defn- add-node [tree node]
185 (assoc-cons tree (:parent node) node))
187 (defn- inside?
188 ([x y bounds]
189 (inside? x y (:x bounds) (:y bounds)
190 (:width bounds) (:height bounds)))
191 ([px py x y w h]
192 (and (>= px x)
193 (>= py y)
194 (< px (+ x w))
195 (< py (+ y h)))))
197 (defn- under-cursor
198 "Returns a sequence of child nodes under cursor."
199 [x y tree node]
200 (some #(if (inside? x y (:bounds %))
201 (conj (under-cursor x y tree %) %))
202 (get tree node)))
204 (defn- remove-all [coll1 coll2 pred]
205 (filter #(not (some (partial pred %) coll2)) coll1))
207 (defn- translate-mouse-event [^java.awt.event.MouseEvent event x y id]
208 (MouseEvent. id (.getWhen event)
209 (- (.getX event) x) (- (.getY event) y)
210 (.getXOnScreen event) (.getYOnScreen event)
211 (.getButton event)))
213 (defn- translate-and-dispatch
214 ([nodes ^java.awt.event.MouseEvent event]
215 (translate-and-dispatch nodes event (awt-events (.getID event))))
216 ([nodes event id]
217 (doseq [node nodes]
218 (when-let [handler (get (:handlers node) id)]
219 (with-bindings* (:bindings node)
220 handler
221 (translate-mouse-event event
222 (-> node :bounds :x) (-> node :bounds :y) id))))
223 id))
225 (defn- dispatch-mouse-motion*
226 "Dispatches mouse motion events. Returns a new set of nodes which
227 currently are under cursor."
228 [hovered tree root ^java.awt.event.MouseEvent event]
229 (let [x (.getX event)
230 y (.getY event)
231 hovered2 (under-cursor x y tree root)
232 pred #(= (:handle %1) (:handle %2))
233 exited (remove-all hovered hovered2 pred)
234 entered (remove-all hovered2 hovered pred)
235 moved (remove-all hovered2 entered pred)]
236 (translate-and-dispatch exited event :mouse-exited)
237 (translate-and-dispatch entered event :mouse-entered)
238 (translate-and-dispatch moved event :mouse-moved)
239 hovered2))
241 (defn- dispatch-mouse-motion
242 [hovered-ref tree root event]
243 (dosync
244 (alter hovered-ref dispatch-mouse-motion* tree root event)))
246 (defn- dispatch-mouse-button*
247 "Dispatches mouse button events. Returns a new set of nodes which
248 currently are picked with a pressed button."
249 [picked hovered event]
250 (if (= (translate-and-dispatch hovered event) :mouse-pressed)
251 hovered
252 nil))
254 (defn- dispatch-mouse-button
255 [picked-ref hovered-ref event]
256 (dosync
257 (alter picked-ref dispatch-mouse-button* @hovered-ref event)))
259 (defn root-event-dispatcher []
260 (let [tree-r (ref {}) ; register
261 tree (ref {}) ; dispatch
262 hovered (ref '())
263 picked (ref '())]
264 (reify
265 EventDispatcher
266 (listen! [this component]
267 (doto component
268 (.addMouseListener this)
269 (.addMouseMotionListener this)))
270 (create-dispatcher [this handle handlers]
271 (let [node (make-node handle handlers)]
272 (dosync (alter tree-r add-node node))
273 node))
274 (commit [this]
275 (dosync (ref-set tree @tree-r)
276 (ref-set tree-r {})))
277 MouseListener
278 (mouseEntered [this event]
279 (dispatch-mouse-motion hovered @tree this event))
280 (mouseExited [this event]
281 (dispatch-mouse-motion hovered @tree this event))
282 (mouseClicked [this event]
283 (dispatch-mouse-button picked hovered event))
284 (mousePressed [this event]
285 (dispatch-mouse-button picked hovered event))
286 (mouseReleased [this event]
287 (dispatch-mouse-button picked hovered event))
288 MouseMotionListener
289 (mouseDragged [this event]
290 (translate-and-dispatch @picked event))
291 (mouseMoved [this event]
292 (dispatch-mouse-motion hovered @tree this event)))))
294 ;;
295 ;; ИДЕИ:
296 ;;
297 ;; Контекст: биндинги или запись?
298 ;;
299 ;; Установка обработчиков (в контексте слоя):
300 ;;
301 ;; (listen
302 ;; (:mouse-entered e
303 ;; ...)
304 ;; (:mouse-exited e
305 ;; ...))
306 ;;
307 ;; Не надо IMGUI.
308 ;; Построение сцены путем декорирования слоев:
309 ;;
310 ;; (listener
311 ;; (:action e (println e))
312 ;; (:mouse-dragged e (println e))
313 ;; (theme :font "Helvetica-14"
314 ;; (vbox
315 ;; (button (text-layer "Button 1"))
316 ;; (button (text-layer "Button 2")))))
317 ;;