Mercurial > hg > indyvon
view src/indyvon/core.clj @ 27:61bc04f94d61
Yet another approach at event dispatching (unfinished).
| author | Mikhail Kryshen <mikhail@kryshen.net> |
|---|---|
| date | Sun, 04 Jul 2010 06:03:48 +0400 |
| parents | 1237f7555029 |
| children | 828795987d4c |
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 (def *context*)
12 (def *graphics*)
14 (defrecord Size [width height])
15 (defrecord Bounds [x y width height])
17 (def *font-context*)
18 (def *bounds*)
19 (def *theme*)
20 (def *target*)
21 (def *update*)
22 (def *event-dispatcher*)
24 (defprotocol Layer
25 "Basic UI element."
26 (render! [this context graphics])
27 (size [this context]))
29 ;; TODO: modifiers
30 (defrecord MouseEvent [id when x y x-on-screen y-on-screen button])
32 (defprotocol MouseHandler
33 "Layers that also satisfy this protocol will recieve mouse events."
34 (handle-mouse [this context event]))
36 (defprotocol EventDispatcher
37 (listen! [this component])
38 (register [this context])
39 (commit [this])
40 (hovered? [this layer])
41 (picked? [this layer]))
43 (defprotocol Anchored
44 "Provide anchor point for Layers. Used by viewport."
45 (anchor [this context h-align v-align]
46 "Anchor point: [x y], h-align could be :left, :center
47 or :right, v-align is :top, :center or :bottom"))
49 ;; Default implementation of Anchored for any Layer.
50 (extend-protocol Anchored
51 indyvon.core.Layer
52 (anchor [this context h-align v-align]
53 (if (and (= h-align :left)
54 (= v-align :top))
55 [0 0]
56 (let [size (size this context)]
57 [(case h-align
58 :top 0
59 :center (/ (size 0) 2)
60 :right (size 0))
61 (case v-align
62 :left 0
63 :center (/ (size 1) 2)
64 :bottom (size 1))]))))
66 (defrecord Theme [fore-color back-color border-color font])
68 (defn default-theme []
69 (Theme. Color/BLACK Color/WHITE Color/BLUE (Font. "Sans" Font/PLAIN 12)))
71 (defrecord LayerContext
72 [handle ; Identifies context for dispatching mouse
73 ; entered/exited and mainaining keyboard focus.
74 parent ; Parent context.
75 x y width height ; Geometry.
76 update-fn ; Call to request repaint.
77 dispatcher ; Event dispatcher.
78 font-context ; An instance of java.awt.font.FontRenderContext.
79 theme ; An instance of Theme.
80 target ; Component.
81 handlers]) ; Map: event-id -> handler fn.
83 (defn default-context []
84 (LayerContext. nil nil 0 0 0 0 nil nil nil (default-theme) nil nil))
86 (defn update [context]
87 ((:update-fn context)))
89 (defn- make-graphics [graphics x y w h clip]
90 (if clip
91 (.create graphics x y w h)
92 (doto (.create graphics)
93 (.translate x y))))
95 (defn- apply-theme [graphics theme]
96 (doto graphics
97 (.setColor (:fore-color theme))
98 (.setFont (:font theme))))
100 ;; (defn with-context* [opts fn & args]
101 ;; (let [context (apply assoc *context*
102 ;; :parent *context*
103 ;; :handlers nil
104 ;; opts)
105 ;; graphics (make-graphics *graphics* x y w h false)
106 ;; graphics (apply-theme graphics (:theme context))]
107 ;; (try
108 ;; (register (:dispatcher context) context)
109 ;; (with-bindings* {#'*context* context
110 ;; #'*graphics* graphics}
111 ;; fn args)
112 ;; (finally
113 ;; (.dispose graphics)))))
115 ;; (defmacro with-context [opts & body]
116 ;; `(with-context* ~opts #(~@body)))
118 (defn draw!
119 "Render layer in a new graphics context."
120 ([layer context graphics]
121 (draw! layer context graphics
122 0 0 (:width context) (:height context)))
123 ([layer context graphics x y]
124 (draw! layer context graphics x y true))
125 ([layer context graphics x y clip]
126 (let [s (size layer context)]
127 (draw! layer context graphics
128 x y (s 0) (s 1) clip)))
129 ([layer context graphics x y w h]
130 (draw! layer context graphics
131 x y w h true))
132 ([layer context graphics x y w h clip]
133 (let [context (assoc context
134 :handle layer
135 :parent context
136 :x (+ (:x context) x)
137 :y (+ (:y context) y)
138 :width w
139 :height h)
140 graphics (make-graphics graphics x y w h clip)
141 graphics (apply-theme graphics (:theme context))]
142 (try
143 (register (:dispatcher context) context)
144 (render! layer context graphics)
145 (finally
146 (.dispose graphics))))))
148 ;;
149 ;; EventDispatcher implementation
150 ;;
152 (def awt-events
153 {java.awt.event.MouseEvent/MOUSE_CLICKED :mouse-clicked
154 java.awt.event.MouseEvent/MOUSE_DRAGGED :mouse-dragged
155 java.awt.event.MouseEvent/MOUSE_ENTERED :mouse-entered
156 java.awt.event.MouseEvent/MOUSE_EXITED :mouse-exited
157 java.awt.event.MouseEvent/MOUSE_MOVED :mouse-moved
158 java.awt.event.MouseEvent/MOUSE_PRESSED :mouse-pressed
159 java.awt.event.MouseEvent/MOUSE_RELEASED :mouse-released})
161 (defn- registered-parent
162 "Returns first context parent registered for event processing."
163 [context-tree context]
164 (let [parent (:parent context)]
165 (cond
166 (nil? parent) nil
167 (contains? context-tree parent) parent
168 :default (recur context-tree parent))))
170 (defn- add-context
171 [context-tree context]
172 (let [parent (registered-parent context-tree context)]
173 (assoc context-tree parent (cons context (context-tree parent))
174 context nil)))
176 (defn- inside?
177 ([x y context]
178 (inside? x y (:x context) (:y context)
179 (:width context) (:height context)))
180 ([px py x y w h]
181 (and (>= px x)
182 (>= py y)
183 (< px (+ x w))
184 (< py (+ y h)))))
186 (defn- under-cursor
187 "Returns a sequence of contexts under cursor."
188 ([context-tree x y]
189 (under-cursor context-tree x y nil))
190 ([context-tree x y context]
191 (some #(if (inside? x y %)
192 (conj (under-cursor context-tree x y %) %))
193 (context-tree context))))
195 (defn- remove-all [coll1 coll2 pred]
196 (filter #(not (some (partial pred %) coll2)) coll1))
198 (defn- translate-mouse-event
199 [event x y id]
200 (MouseEvent. id (.getWhen event)
201 (- (.getX event) x) (- (.getY event) y)
202 (.getXOnScreen event) (.getYOnScreen event)
203 (.getButton event)))
205 (defn- translate-and-dispatch
206 ([contexts event]
207 (translate-and-dispatch contexts event (awt-events (.getID event))))
208 ([contexts event id]
209 (doseq [context contexts]
210 (if-let [handler (get (:handlers context) id)]
211 (handler context (translate-mouse-event
212 event (:x context) (:y context) id))))
213 id))
215 (defn- context-id [context]
216 (loop [context context
217 id nil]
218 (if context
219 (recur (:parent context) (cons (:handle context) id))
220 id)))
222 (defn- dispatch-mouse-motion*
223 "Dispatches mouse motion events. Returns a new set of contexts which
224 currently are under cursor."
225 [hovered context-tree event]
226 (let [x (.getX event)
227 y (.getY event)
228 hovered2 (under-cursor context-tree x y)
229 pred #(= (context-id %1) (context-id %2))
230 exited (remove-all hovered hovered2 pred)
231 entered (remove-all hovered2 hovered pred)
232 moved (remove-all hovered2 entered pred)]
233 (translate-and-dispatch exited event :mouse-exited)
234 (translate-and-dispatch entered event :mouse-entered)
235 (translate-and-dispatch moved event :mouse-moved)
236 hovered2))
238 (defn- dispatch-mouse-motion
239 [hovered-ref context-tree event]
240 (dosync
241 (alter hovered-ref dispatch-mouse-motion* context-tree event)))
243 (defn- dispatch-mouse-button*
244 "Dispatches mouse button events. Returns a new set of contexts which
245 currently are picked with a pressed button."
246 [picked hovered event]
247 (if (= (translate-and-dispatch hovered event) :mouse-pressed)
248 hovered
249 nil))
251 (defn- dispatch-mouse-button
252 [picked-ref hovered-ref event]
253 (dosync
254 (alter picked-ref dispatch-mouse-button* @hovered-ref event)))
256 (defn make-event-dispatcher []
257 (let [context-tree-r (ref {}) ; register
258 context-tree (ref {}) ; dispatch
259 hovered (ref '())
260 picked (ref '())]
261 (reify
262 EventDispatcher
263 (listen! [this component]
264 (doto component
265 (.addMouseListener this)
266 (.addMouseMotionListener this)))
267 (register [this context]
268 (if (:handlers context)
269 (dosync (alter context-tree-r add-context context))))
270 (commit [this]
271 (dosync (ref-set context-tree @context-tree-r)
272 (ref-set context-tree-r {})))
273 (picked? [this layer] false)
274 (hovered? [this layer] false)
275 MouseListener
276 (mouseEntered [this event]
277 (dispatch-mouse-motion hovered @context-tree event))
278 (mouseExited [this event]
279 (dispatch-mouse-motion hovered @context-tree event))
280 (mouseClicked [this event]
281 (dispatch-mouse-button picked hovered event))
282 (mousePressed [this event]
283 (dispatch-mouse-button picked hovered event))
284 (mouseReleased [this event]
285 (dispatch-mouse-button picked hovered event))
286 MouseMotionListener
287 (mouseDragged [this event]
288 (translate-and-dispatch @picked event))
289 (mouseMoved [this event]
290 (dispatch-mouse-motion hovered @context-tree event)))))