view src/indyvon/core.clj @ 30:a8821f4b5ade

Event dispatcher creates new context.
author Mikhail Kryshen <mikhail@kryshen.net>
date Wed, 07 Jul 2010 03:10:22 +0400
parents 4cb70c5a6e0d
children 8ac3a21955db
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 (register [this context handle handlers]
26 "Returns new context associated with the specified event
27 handlers (an event-id -> handler-fn map). Handle is used
28 to 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
36 or :right, 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 dispatcher node])
64 (defn default-context []
65 (LayerContext. 0 0 0 0 nil nil (default-theme) nil 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 (register (:dispatcher context#) context# handle
120 ~(reduce (fn [m spec]
121 (assoc m (first spec)
122 `(fn [~(second spec)]
123 ~@(nnext spec)))) {}
124 (butlast specs)))]
125 ~(last specs))))
127 ;;
128 ;; EventDispatcher implementation
129 ;;
131 (def awt-events
132 {java.awt.event.MouseEvent/MOUSE_CLICKED :mouse-clicked
133 java.awt.event.MouseEvent/MOUSE_DRAGGED :mouse-dragged
134 java.awt.event.MouseEvent/MOUSE_ENTERED :mouse-entered
135 java.awt.event.MouseEvent/MOUSE_EXITED :mouse-exited
136 java.awt.event.MouseEvent/MOUSE_MOVED :mouse-moved
137 java.awt.event.MouseEvent/MOUSE_PRESSED :mouse-pressed
138 java.awt.event.MouseEvent/MOUSE_RELEASED :mouse-released})
140 (defrecord DispatcherNode [handle handlers parent x y width height])
142 (defn- make-node [c handle handlers]
143 (DispatcherNode. handle handlers (:node c)
144 (:x c) (:y c) (:width c) (:height c)))
146 (defn- assoc-cons [m key val]
147 (assoc m key (cons val (get m key))))
149 (defn- add-node [tree node]
150 (assoc-cons tree (:parent node) node))
152 (defn- inside?
153 ([x y node]
154 (inside? x y (:x node) (:y node)
155 (:width node) (:height node)))
156 ([px py x y w h]
157 (and (>= px x)
158 (>= py y)
159 (< px (+ x w))
160 (< py (+ y h)))))
162 (defn- under-cursor
163 "Returns a sequence of child nodes under cursor."
164 ([x y tree]
165 (under-cursor x y tree nil))
166 ([x y tree node]
167 (some #(if (inside? x y %)
168 (conj (under-cursor x y %) %))
169 (get tree node))))
171 (defn- remove-all [coll1 coll2 pred]
172 (filter #(not (some (partial pred %) coll2)) coll1))
174 (defn- translate-mouse-event
175 [event x y id]
176 (MouseEvent. id (.getWhen event)
177 (- (.getX event) x) (- (.getY event) y)
178 (.getXOnScreen event) (.getYOnScreen event)
179 (.getButton event)))
181 (defn- translate-and-dispatch
182 ([nodes event]
183 (translate-and-dispatch nodes event (awt-events (.getID event))))
184 ([nodes event id]
185 (doseq [node nodes]
186 (when-let [handler (get (:handlers node) id)]
187 (handler
188 (translate-mouse-event event (:x node) (:y node) id))))
189 id))
191 (defn- dispatch-mouse-motion*
192 "Dispatches mouse motion events. Returns a new set of nodes which
193 currently are under cursor."
194 [hovered tree event]
195 (let [x (.getX event)
196 y (.getY event)
197 hovered2 (under-cursor x y tree)
198 pred #(= (:handle %1) (:handle %2))
199 exited (remove-all hovered hovered2 pred)
200 entered (remove-all hovered2 hovered pred)
201 moved (remove-all hovered2 entered pred)]
202 (translate-and-dispatch exited event :mouse-exited)
203 (translate-and-dispatch entered event :mouse-entered)
204 (translate-and-dispatch moved event :mouse-moved)
205 hovered2))
207 (defn- dispatch-mouse-motion
208 [hovered-ref tree event]
209 (dosync
210 (alter hovered-ref dispatch-mouse-motion* tree event)))
212 (defn- dispatch-mouse-button*
213 "Dispatches mouse button events. Returns a new set of nodes which
214 currently are picked with a pressed button."
215 [picked hovered event]
216 (if (= (translate-and-dispatch hovered event) :mouse-pressed)
217 hovered
218 nil))
220 (defn- dispatch-mouse-button
221 [picked-ref hovered-ref event]
222 (dosync
223 (alter picked-ref dispatch-mouse-button* @hovered-ref event)))
225 (defn make-event-dispatcher []
226 (let [tree-r (ref {}) ; register
227 tree (ref {}) ; dispatch
228 hovered (ref '())
229 picked (ref '())]
230 (reify
231 EventDispatcher
232 (listen! [this component]
233 (doto component
234 (.addMouseListener this)
235 (.addMouseMotionListener this)))
236 (register [this context handle handlers]
237 (let [node (make-node context handle handlers)]
238 (dosync (alter tree-r add-node node))
239 (assoc context :node node)))
240 (commit [this]
241 (dosync (ref-set tree @tree-r)
242 (ref-set tree-r {})))
243 MouseListener
244 (mouseEntered [this event]
245 (dispatch-mouse-motion hovered @tree event))
246 (mouseExited [this event]
247 (dispatch-mouse-motion hovered @tree event))
248 (mouseClicked [this event]
249 (dispatch-mouse-button picked hovered event))
250 (mousePressed [this event]
251 (dispatch-mouse-button picked hovered event))
252 (mouseReleased [this event]
253 (dispatch-mouse-button picked hovered event))
254 MouseMotionListener
255 (mouseDragged [this event]
256 (translate-and-dispatch @picked event))
257 (mouseMoved [this event]
258 (dispatch-mouse-motion hovered @tree event)))))
260 ;;
261 ;; ИДЕИ:
262 ;;
263 ;; Контекст: биндинги или запись?
264 ;;
265 ;; Установка обработчиков (в контексте слоя):
266 ;;
267 ;; (listen
268 ;; (:mouse-entered e
269 ;; ...)
270 ;; (:mouse-exited e
271 ;; ...))
272 ;;
273 ;; Не надо IMGUI.
274 ;; Построение сцены путем декорирования слоев:
275 ;;
276 ;; (listener
277 ;; (:action e (println e))
278 ;; (:mouse-dragged e (println e))
279 ;; (theme :font "Helvetica-14"
280 ;; (vbox
281 ;; (button (text-layer "Button 1"))
282 ;; (button (text-layer "Button 2")))))
283 ;;