Mercurial > hg > indyvon
view src/indyvon/core.clj @ 31:8ac3a21955db
DispatcherNode implements EventDispatcher.
| author | Mikhail Kryshen <mikhail@kryshen.net> |
|---|---|
| date | Wed, 07 Jul 2010 04:14:21 +0400 |
| parents | a8821f4b5ade |
| children | 0b3757d263db |
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 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]
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- make-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- apply-theme [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 (draw! layer context graphics
85 0 0 (:width context) (:height context)))
86 ([layer context graphics x y]
87 (draw! layer context graphics x y true))
88 ([layer context graphics x y clip]
89 (let [s (size layer context)]
90 (draw! layer context graphics
91 x y (:width s) (:height s) clip)))
92 ([layer context graphics x y w h]
93 (draw! layer context graphics
94 x y w h true))
95 ([layer context graphics x y w h clip]
96 (let [context (assoc context
97 :layer layer
98 :parent context
99 :x (+ (:x context) x)
100 :y (+ (:y context) y)
101 :width w
102 :height h)
103 graphics (make-graphics graphics x y w h clip)
104 graphics (apply-theme graphics (:theme context))]
105 (try
106 (render! layer context graphics)
107 (finally
108 (.dispose graphics))))))
110 (defmacro handlers [handle bindings & specs]
111 "bindings => binding-form context
112 specs => (:event-id name & handler-body)* form
114 Execute form with the specified event handlers."
115 (let [[binding context] bindings
116 context (or context binding)]
117 `(let [context# ~context
118 ~binding
119 (assoc context# :event-dispatcher
120 (create-dispatcher (:event-dispatcher context#)
121 context# handle
122 ~(reduce (fn [m spec]
123 (assoc m (first spec)
124 `(fn [~(second spec)]
125 ~@(nnext spec)))) {}
126 (butlast specs))))]
127 ~(last specs))))
129 ;;
130 ;; EventDispatcher implementation
131 ;;
133 (def awt-events
134 {java.awt.event.MouseEvent/MOUSE_CLICKED :mouse-clicked
135 java.awt.event.MouseEvent/MOUSE_DRAGGED :mouse-dragged
136 java.awt.event.MouseEvent/MOUSE_ENTERED :mouse-entered
137 java.awt.event.MouseEvent/MOUSE_EXITED :mouse-exited
138 java.awt.event.MouseEvent/MOUSE_MOVED :mouse-moved
139 java.awt.event.MouseEvent/MOUSE_PRESSED :mouse-pressed
140 java.awt.event.MouseEvent/MOUSE_RELEASED :mouse-released})
142 (defrecord DispatcherNode [handle handlers parent x y width height]
143 EventDispatcher
144 (listen! [this component]
145 (listen! parent component))
146 (create-dispatcher [this context handle handlers]
147 (create-dispatcher parent context handle handlers))
148 (commit [this]
149 (commit parent)))
151 (defn- make-node [parent c handle handlers]
152 (DispatcherNode. handle handlers parent
153 (:x c) (:y c) (:width c) (:height c)))
155 (defn- assoc-cons [m key val]
156 (assoc m key (cons val (get m key))))
158 (defn- add-node [tree node]
159 (assoc-cons tree (:parent node) node))
161 (defn- inside?
162 ([x y node]
163 (inside? x y (:x node) (:y node)
164 (:width node) (:height node)))
165 ([px py x y w h]
166 (and (>= px x)
167 (>= py y)
168 (< px (+ x w))
169 (< py (+ y h)))))
171 (defn- under-cursor
172 "Returns a sequence of child nodes under cursor."
173 ([x y tree]
174 (under-cursor x y tree nil))
175 ([x y tree node]
176 (some #(if (inside? x y %)
177 (conj (under-cursor x y %) %))
178 (get tree node))))
180 (defn- remove-all [coll1 coll2 pred]
181 (filter #(not (some (partial pred %) coll2)) coll1))
183 (defn- translate-mouse-event
184 [event x y id]
185 (MouseEvent. id (.getWhen event)
186 (- (.getX event) x) (- (.getY event) y)
187 (.getXOnScreen event) (.getYOnScreen event)
188 (.getButton event)))
190 (defn- translate-and-dispatch
191 ([nodes event]
192 (translate-and-dispatch nodes event (awt-events (.getID event))))
193 ([nodes event id]
194 (doseq [node nodes]
195 (when-let [handler (get (:handlers node) id)]
196 (handler
197 (translate-mouse-event event (:x node) (:y node) id))))
198 id))
200 (defn- dispatch-mouse-motion*
201 "Dispatches mouse motion events. Returns a new set of nodes which
202 currently are under cursor."
203 [hovered tree event]
204 (let [x (.getX event)
205 y (.getY event)
206 hovered2 (under-cursor x y tree)
207 pred #(= (:handle %1) (:handle %2))
208 exited (remove-all hovered hovered2 pred)
209 entered (remove-all hovered2 hovered pred)
210 moved (remove-all hovered2 entered pred)]
211 (translate-and-dispatch exited event :mouse-exited)
212 (translate-and-dispatch entered event :mouse-entered)
213 (translate-and-dispatch moved event :mouse-moved)
214 hovered2))
216 (defn- dispatch-mouse-motion
217 [hovered-ref tree event]
218 (dosync
219 (alter hovered-ref dispatch-mouse-motion* tree event)))
221 (defn- dispatch-mouse-button*
222 "Dispatches mouse button events. Returns a new set of nodes which
223 currently are picked with a pressed button."
224 [picked hovered event]
225 (if (= (translate-and-dispatch hovered event) :mouse-pressed)
226 hovered
227 nil))
229 (defn- dispatch-mouse-button
230 [picked-ref hovered-ref event]
231 (dosync
232 (alter picked-ref dispatch-mouse-button* @hovered-ref event)))
234 (defn root-event-dispatcher []
235 (let [tree-r (ref {}) ; register
236 tree (ref {}) ; dispatch
237 hovered (ref '())
238 picked (ref '())]
239 (reify
240 EventDispatcher
241 (listen! [this component]
242 (doto component
243 (.addMouseListener this)
244 (.addMouseMotionListener this)))
245 (create-dispatcher [this context handle handlers]
246 (let [node (make-node this context handle handlers)]
247 (dosync (alter tree-r add-node node))
248 node))
249 (commit [this]
250 (dosync (ref-set tree @tree-r)
251 (ref-set tree-r {})))
252 MouseListener
253 (mouseEntered [this event]
254 (dispatch-mouse-motion hovered @tree event))
255 (mouseExited [this event]
256 (dispatch-mouse-motion hovered @tree event))
257 (mouseClicked [this event]
258 (dispatch-mouse-button picked hovered event))
259 (mousePressed [this event]
260 (dispatch-mouse-button picked hovered event))
261 (mouseReleased [this event]
262 (dispatch-mouse-button picked hovered event))
263 MouseMotionListener
264 (mouseDragged [this event]
265 (translate-and-dispatch @picked event))
266 (mouseMoved [this event]
267 (dispatch-mouse-motion hovered @tree event)))))
269 ;;
270 ;; ИДЕИ:
271 ;;
272 ;; Контекст: биндинги или запись?
273 ;;
274 ;; Установка обработчиков (в контексте слоя):
275 ;;
276 ;; (listen
277 ;; (:mouse-entered e
278 ;; ...)
279 ;; (:mouse-exited e
280 ;; ...))
281 ;;
282 ;; Не надо IMGUI.
283 ;; Построение сцены путем декорирования слоев:
284 ;;
285 ;; (listener
286 ;; (:action e (println e))
287 ;; (:mouse-dragged e (println e))
288 ;; (theme :font "Helvetica-14"
289 ;; (vbox
290 ;; (button (text-layer "Button 1"))
291 ;; (button (text-layer "Button 2")))))
292 ;;