view src/indyvon/core.clj @ 29:4cb70c5a6e0d

Event handlers are registered using listen macro instead of implementing a protocol.
author Mikhail Kryshen <mikhail@kryshen.net>
date Tue, 06 Jul 2010 06:05:28 +0400
parents 1237f7555029
children a8821f4b5ade
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 (register [this context handlers])
25 (commit [this]))
27 (defprotocol Anchored
28 "Provide anchor point for Layers. Used by viewport."
29 (anchor [this context h-align v-align]
30 "Anchor point: [x y], h-align could be :left, :center
31 or :right, v-align is :top, :center or :bottom"))
33 ;; Default implementation of Anchored for any Layer.
34 (extend-protocol Anchored
35 indyvon.core.Layer
36 (anchor [this context h-align v-align]
37 (if (and (= h-align :left)
38 (= v-align :top))
39 (Location. 0 0)
40 (let [size (size this context)]
41 (Location.
42 (case h-align
43 :top 0
44 :center (/ (:width size) 2)
45 :right (:width size))
46 (case v-align
47 :left 0
48 :center (/ (:height size) 2)
49 :bottom (:height size)))))))
51 (defrecord Theme [fore-color back-color border-color font])
53 (defn default-theme []
54 (Theme. Color/BLACK Color/WHITE Color/BLUE (Font. "Sans" Font/PLAIN 12)))
56 (defrecord LayerContext [layer parent x y width height update-fn
57 dispatcher font-context theme target])
59 (defn default-context []
60 (LayerContext. nil nil 0 0 0 0 nil nil nil (default-theme) nil))
62 (defn update [context]
63 ((:update-fn context)))
65 (defn- make-graphics [graphics x y w h clip]
66 (if clip
67 (.create graphics x y w h)
68 (doto (.create graphics)
69 (.translate x y))))
71 (defn- apply-theme [graphics theme]
72 (doto graphics
73 (.setColor (:fore-color theme))
74 (.setFont (:font theme))))
76 (defn draw!
77 "Render layer in a new graphics context."
78 ([layer context graphics]
79 (draw! layer context graphics
80 0 0 (:width context) (:height context)))
81 ([layer context graphics x y]
82 (draw! layer context graphics x y true))
83 ([layer context graphics x y clip]
84 (let [s (size layer context)]
85 (draw! layer context graphics
86 x y (:width s) (:height s) clip)))
87 ([layer context graphics x y w h]
88 (draw! layer context graphics
89 x y w h true))
90 ([layer context graphics x y w h clip]
91 (let [context (assoc context
92 :layer layer
93 :parent context
94 :x (+ (:x context) x)
95 :y (+ (:y context) y)
96 :width w
97 :height h)
98 graphics (make-graphics graphics x y w h clip)
99 graphics (apply-theme graphics (:theme context))]
100 (try
101 (render! layer context graphics)
102 (finally
103 (.dispose graphics))))))
105 (defn listen* [context & handlers]
106 (register (:dispatcher context) context (apply array-map handlers)))
108 ;; (listen context
109 ;; (:mouse-entered e (println e))
110 ;; (:mouse-exited e (println e)))
111 (defmacro listen [context & specs]
112 `(register (:dispatcher ~context) ~context
113 ~(reduce #(assoc %1
114 (first %2)
115 `(fn [~(second %2)] ~@(nnext %2)))
116 {} specs)))
118 ;;
119 ;; EventDispatcher implementation
120 ;;
122 (def awt-events
123 {java.awt.event.MouseEvent/MOUSE_CLICKED :mouse-clicked
124 java.awt.event.MouseEvent/MOUSE_DRAGGED :mouse-dragged
125 java.awt.event.MouseEvent/MOUSE_ENTERED :mouse-entered
126 java.awt.event.MouseEvent/MOUSE_EXITED :mouse-exited
127 java.awt.event.MouseEvent/MOUSE_MOVED :mouse-moved
128 java.awt.event.MouseEvent/MOUSE_PRESSED :mouse-pressed
129 java.awt.event.MouseEvent/MOUSE_RELEASED :mouse-released})
131 (defrecord DispatcherNode [layer x y width height handlers children])
133 (defrecord DispatcherRootNode [children])
135 (defn- make-node [c handlers]
136 (DispatcherNode. (:layer c) (:x c) (:y c) (:width c) (:height c)
137 handlers nil))
139 (defn- add-child [node child]
140 (assoc node :children (cons child (:children node))))
142 (defn- registered-parent
143 "Returns first context parent registered for event processing."
144 [tree context]
145 (let [parent (:parent context)]
146 (cond
147 (nil? parent) nil
148 (contains? tree parent) parent
149 :default (recur tree parent))))
151 (defn- add-context
152 [tree context handlers]
153 (let [parent (registered-parent tree context)
154 node (make-node context handlers)]
155 (assoc tree
156 parent (add-child (tree parent) node)
157 context node)))
159 (defn- inside?
160 ([x y node]
161 (inside? x y (:x node) (:y node)
162 (:width node) (:height node)))
163 ([px py x y w h]
164 (and (>= px x)
165 (>= py y)
166 (< px (+ x w))
167 (< py (+ y h)))))
169 (defn- under-cursor
170 "Returns a sequence of child nodes under cursor."
171 [x y node]
172 (some #(if (inside? x y %)
173 (conj (under-cursor x y %) %))
174 (:children node)))
176 (defn- remove-all [coll1 coll2 pred]
177 (filter #(not (some (partial pred %) coll2)) coll1))
179 (defn- translate-mouse-event
180 [event x y id]
181 (MouseEvent. id (.getWhen event)
182 (- (.getX event) x) (- (.getY event) y)
183 (.getXOnScreen event) (.getYOnScreen event)
184 (.getButton event)))
186 (defn- translate-and-dispatch
187 ([nodes event]
188 (translate-and-dispatch nodes event (awt-events (.getID event))))
189 ([nodes event id]
190 (doseq [node nodes]
191 (when-let [handler (get (:handlers node) id)]
192 (handler
193 (translate-mouse-event event (:x node) (:y node) id))))
194 id))
196 (defn- dispatch-mouse-motion*
197 "Dispatches mouse motion events. Returns a new set of nodes which
198 currently are under cursor."
199 [hovered tree event]
200 (let [x (.getX event)
201 y (.getY event)
202 hovered2 (under-cursor x y (get tree nil))
203 pred #(= (:layer %1) (:layer %2))
204 exited (remove-all hovered hovered2 pred)
205 entered (remove-all hovered2 hovered pred)
206 moved (remove-all hovered2 entered pred)]
207 (translate-and-dispatch exited event :mouse-exited)
208 (translate-and-dispatch entered event :mouse-entered)
209 (translate-and-dispatch moved event :mouse-moved)
210 hovered2))
212 (defn- dispatch-mouse-motion
213 [hovered-ref tree event]
214 (dosync
215 (alter hovered-ref dispatch-mouse-motion* tree event)))
217 (defn- dispatch-mouse-button*
218 "Dispatches mouse button events. Returns a new set of nodes which
219 currently are picked with a pressed button."
220 [picked hovered event]
221 (if (= (translate-and-dispatch hovered event) :mouse-pressed)
222 hovered
223 nil))
225 (defn- dispatch-mouse-button
226 [picked-ref hovered-ref event]
227 (dosync
228 (alter picked-ref dispatch-mouse-button* @hovered-ref event)))
230 (defn make-event-dispatcher []
231 (let [tree-i {nil (DispatcherRootNode. nil)} ; initial
232 tree-r (ref tree-i) ; register
233 tree (ref tree-i) ; dispatch
234 hovered (ref '())
235 picked (ref '())]
236 (reify
237 EventDispatcher
238 (listen! [this component]
239 (doto component
240 (.addMouseListener this)
241 (.addMouseMotionListener this)))
242 (register [this context handlers]
243 (dosync (alter tree-r add-context context handlers)))
244 (commit [this]
245 (dosync (ref-set tree @tree-r)
246 (ref-set tree-r tree-i)))
247 MouseListener
248 (mouseEntered [this event]
249 (dispatch-mouse-motion hovered @tree event))
250 (mouseExited [this event]
251 (dispatch-mouse-motion hovered @tree event))
252 (mouseClicked [this event]
253 (dispatch-mouse-button picked hovered event))
254 (mousePressed [this event]
255 (dispatch-mouse-button picked hovered event))
256 (mouseReleased [this event]
257 (dispatch-mouse-button picked hovered event))
258 MouseMotionListener
259 (mouseDragged [this event]
260 (translate-and-dispatch @picked event))
261 (mouseMoved [this event]
262 (dispatch-mouse-motion hovered @tree event)))))
264 ;;
265 ;; ИДЕИ:
266 ;;
267 ;; Контекст: биндинги или запись?
268 ;;
269 ;; Установка обработчиков (в контексте слоя):
270 ;;
271 ;; (listen
272 ;; (:mouse-entered e
273 ;; ...)
274 ;; (:mouse-exited e
275 ;; ...))
276 ;;
277 ;; Не надо IMGUI.
278 ;; Построение сцены путем декорирования слоев:
279 ;;
280 ;; (listener
281 ;; (:action e (println e))
282 ;; (:mouse-dragged e (println e))
283 ;; (theme :font "Helvetica-14"
284 ;; (vbox
285 ;; (button (text-layer "Button 1"))
286 ;; (button (text-layer "Button 2")))))
287 ;;