Mercurial > hg > indyvon
view src/indyvon/core.clj @ 32:0b3757d263db
Fixed event dispatcher.
Added type hints.
| author | Mikhail Kryshen <mikhail@kryshen.net> |
|---|---|
| date | Wed, 07 Jul 2010 05:57:49 +0400 |
| parents | 8ac3a21955db |
| children | 439f6ecee119 |
line source
1 ;;
2 ;; Copyright (C) 2010 Mikhail Kryshen <mikhail@kryshen.net>
3 ;;
4 ;; This file is part of Indyvon.
5 ;;
7 (ns indyvon.core
8 (:import (java.awt Graphics Component Color Font)
9 (java.awt.event MouseListener MouseMotionListener)))
11 (defprotocol Layer
12 "Basic UI element."
13 (render! [this context graphics])
14 (size [this context]))
16 (defrecord Location [x y])
17 (defrecord Size [width height])
19 ;; TODO: modifiers
20 (defrecord MouseEvent [id when x y x-on-screen y-on-screen button])
22 (defprotocol EventDispatcher
23 (listen! [this ^Component component]
24 "Listen for events on the specified AWT Component.")
25 (create-dispatcher [this context handle handlers]
26 "Returns new event dispatcher associated with the specified event
27 handlers (an event-id -> handler-fn map). Handle is used to
28 match the contexts between commits.")
29 (commit [this]
30 "Apply the registered handlers for event processing."))
32 (defprotocol Anchored
33 "Provide anchor point for Layers. Used by viewport."
34 (anchor [this context h-align v-align]
35 "Anchor point: [x y], h-align could be :left, :center or :right,
36 v-align is :top, :center or :bottom"))
38 ;; Default implementation of Anchored for any Layer.
39 (extend-protocol Anchored
40 indyvon.core.Layer
41 (anchor [this context h-align v-align]
42 (if (and (= h-align :left)
43 (= v-align :top))
44 (Location. 0 0)
45 (let [size (size this context)]
46 (Location.
47 (case h-align
48 :top 0
49 :center (/ (:width size) 2)
50 :right (:width size))
51 (case v-align
52 :left 0
53 :center (/ (:height size) 2)
54 :bottom (:height size)))))))
56 (defrecord Theme [fore-color back-color border-color font])
58 (defn default-theme []
59 (Theme. Color/BLACK Color/WHITE Color/BLUE (Font. "Sans" Font/PLAIN 12)))
61 (defrecord LayerContext [x y width height update-fn font-context
62 theme target event-dispatcher])
64 (defn default-context []
65 (LayerContext. 0 0 0 0 nil nil (default-theme) nil nil))
67 (defn update [context]
68 ((:update-fn context)))
70 (defn- ^Graphics make-graphics [^Graphics graphics x y w h clip]
71 (if clip
72 (.create graphics x y w h)
73 (doto (.create graphics)
74 (.translate x y))))
76 (defn- ^Graphics apply-theme [^Graphics graphics theme]
77 (doto graphics
78 (.setColor (:fore-color theme))
79 (.setFont (:font theme))))
81 (defn draw!
82 "Render layer in a new graphics context."
83 ([layer context graphics]
84 (render! layer context graphics))
85 ([layer context graphics x y]
86 (draw! layer context graphics x y true))
87 ([layer context graphics x y clip]
88 (let [s (size layer context)]
89 (draw! layer context graphics
90 x y (:width s) (:height s) clip)))
91 ([layer context graphics x y w h]
92 (draw! layer context graphics
93 x y w h true))
94 ([layer context graphics x y w h clip]
95 (let [context (assoc context
96 :layer layer
97 :parent context
98 :x (+ (:x context) x)
99 :y (+ (:y context) y)
100 :width w
101 :height h)
102 graphics (make-graphics graphics x y w h clip)
103 graphics (apply-theme graphics (:theme context))]
104 (try
105 (render! layer context graphics)
106 (finally
107 (.dispose graphics))))))
109 (defn add-handlers [context handle handlers]
110 "Returns new context with the specified event handlers."
111 (assoc context
112 :event-dispatcher
113 (create-dispatcher (:event-dispatcher context) context
114 handle handlers)))
116 (defmacro let-handlers [handle bindings & specs]
117 "bindings => [binding-form context] or [context-symbol]
118 specs => (:event-id name & handler-body)* form
120 Execute form with the specified event handlers."
121 (let [[binding context] bindings
122 context (or context binding)]
123 `(let [context# ~context
124 ~binding
125 (add-handlers context# ~handle
126 ~(reduce (fn [m spec]
127 (assoc m (first spec)
128 `(fn [~(second spec)]
129 ~@(nnext spec)))) {}
130 (butlast specs)))]
131 ~(last specs))))
133 ;;
134 ;; EventDispatcher implementation
135 ;;
137 (def awt-events
138 {java.awt.event.MouseEvent/MOUSE_CLICKED :mouse-clicked
139 java.awt.event.MouseEvent/MOUSE_DRAGGED :mouse-dragged
140 java.awt.event.MouseEvent/MOUSE_ENTERED :mouse-entered
141 java.awt.event.MouseEvent/MOUSE_EXITED :mouse-exited
142 java.awt.event.MouseEvent/MOUSE_MOVED :mouse-moved
143 java.awt.event.MouseEvent/MOUSE_PRESSED :mouse-pressed
144 java.awt.event.MouseEvent/MOUSE_RELEASED :mouse-released})
146 (defrecord DispatcherNode [handle handlers parent x y width height]
147 EventDispatcher
148 (listen! [this component]
149 (listen! parent component))
150 (create-dispatcher [this context handle handlers]
151 (create-dispatcher parent context handle handlers))
152 (commit [this]
153 (commit parent)))
155 (defn- make-node [c handle handlers]
156 (DispatcherNode. handle handlers (:event-dispatcher c)
157 (:x c) (:y c) (:width c) (:height c)))
159 (defn- assoc-cons [m key val]
160 (assoc m key (cons val (get m key))))
162 (defn- add-node [tree node]
163 (assoc-cons tree (:parent node) node))
165 (defn- inside?
166 ([x y node]
167 (inside? x y (:x node) (:y node)
168 (:width node) (:height node)))
169 ([px py x y w h]
170 (and (>= px x)
171 (>= py y)
172 (< px (+ x w))
173 (< py (+ y h)))))
175 (defn- under-cursor
176 "Returns a sequence of child nodes under cursor."
177 [x y tree node]
178 (some #(if (inside? x y %)
179 (conj (under-cursor x y tree %) %))
180 (get tree node)))
182 (defn- remove-all [coll1 coll2 pred]
183 (filter #(not (some (partial pred %) coll2)) coll1))
185 (defn- translate-mouse-event [^java.awt.event.MouseEvent event x y id]
186 (MouseEvent. id (.getWhen event)
187 (- (.getX event) x) (- (.getY event) y)
188 (.getXOnScreen event) (.getYOnScreen event)
189 (.getButton event)))
191 (defn- translate-and-dispatch
192 ([nodes ^java.awt.event.MouseEvent event]
193 (translate-and-dispatch nodes event (awt-events (.getID event))))
194 ([nodes event id]
195 (doseq [node nodes]
196 (when-let [handler (get (:handlers node) id)]
197 (handler
198 (translate-mouse-event event (:x node) (:y node) id))))
199 id))
201 (defn- dispatch-mouse-motion*
202 "Dispatches mouse motion events. Returns a new set of nodes which
203 currently are under cursor."
204 [hovered tree root ^java.awt.event.MouseEvent event]
205 (let [x (.getX event)
206 y (.getY event)
207 hovered2 (under-cursor x y tree root)
208 pred #(= (:handle %1) (:handle %2))
209 exited (remove-all hovered hovered2 pred)
210 entered (remove-all hovered2 hovered pred)
211 moved (remove-all hovered2 entered pred)]
212 (translate-and-dispatch exited event :mouse-exited)
213 (translate-and-dispatch entered event :mouse-entered)
214 (translate-and-dispatch moved event :mouse-moved)
215 hovered2))
217 (defn- dispatch-mouse-motion
218 [hovered-ref tree root event]
219 (dosync
220 (alter hovered-ref dispatch-mouse-motion* tree root event)))
222 (defn- dispatch-mouse-button*
223 "Dispatches mouse button events. Returns a new set of nodes which
224 currently are picked with a pressed button."
225 [picked hovered event]
226 (if (= (translate-and-dispatch hovered event) :mouse-pressed)
227 hovered
228 nil))
230 (defn- dispatch-mouse-button
231 [picked-ref hovered-ref event]
232 (dosync
233 (alter picked-ref dispatch-mouse-button* @hovered-ref event)))
235 (defn root-event-dispatcher []
236 (let [tree-r (ref {}) ; register
237 tree (ref {}) ; dispatch
238 hovered (ref '())
239 picked (ref '())]
240 (reify
241 EventDispatcher
242 (listen! [this component]
243 (doto component
244 (.addMouseListener this)
245 (.addMouseMotionListener this)))
246 (create-dispatcher [this context handle handlers]
247 (let [node (make-node context handle handlers)]
248 (dosync (alter tree-r add-node node))
249 node))
250 (commit [this]
251 (dosync (ref-set tree @tree-r)
252 (ref-set tree-r {})))
253 MouseListener
254 (mouseEntered [this event]
255 (dispatch-mouse-motion hovered @tree this event))
256 (mouseExited [this event]
257 (dispatch-mouse-motion hovered @tree this event))
258 (mouseClicked [this event]
259 (dispatch-mouse-button picked hovered event))
260 (mousePressed [this event]
261 (dispatch-mouse-button picked hovered event))
262 (mouseReleased [this event]
263 (dispatch-mouse-button picked hovered event))
264 MouseMotionListener
265 (mouseDragged [this event]
266 (translate-and-dispatch @picked event))
267 (mouseMoved [this event]
268 (dispatch-mouse-motion hovered @tree this event)))))
270 ;;
271 ;; ИДЕИ:
272 ;;
273 ;; Контекст: биндинги или запись?
274 ;;
275 ;; Установка обработчиков (в контексте слоя):
276 ;;
277 ;; (listen
278 ;; (:mouse-entered e
279 ;; ...)
280 ;; (:mouse-exited e
281 ;; ...))
282 ;;
283 ;; Не надо IMGUI.
284 ;; Построение сцены путем декорирования слоев:
285 ;;
286 ;; (listener
287 ;; (:action e (println e))
288 ;; (:mouse-dragged e (println e))
289 ;; (theme :font "Helvetica-14"
290 ;; (vbox
291 ;; (button (text-layer "Button 1"))
292 ;; (button (text-layer "Button 2")))))
293 ;;