view src/indyvon/core.clj @ 33:439f6ecee119

Include graphics into context. Event dispatcher respects clipping.
author Mikhail Kryshen <mikhail@kryshen.net>
date Wed, 07 Jul 2010 07:17:08 +0400
parents 0b3757d263db
children 6975b9a71eec
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 Graphics2D Component Color Font)
9 (java.awt.event MouseListener MouseMotionListener)))
11 (defprotocol Layer
12 "Basic UI element."
13 (render! [this context])
14 (size [this context]))
16 (defrecord Location [x y])
17 (defrecord Size [width height])
18 (defrecord Bounds [x y width height])
20 ;; TODO: modifiers
21 (defrecord MouseEvent [id when x y x-on-screen y-on-screen button])
23 (defprotocol EventDispatcher
24 (listen! [this ^Component component]
25 "Listen for events on the specified AWT Component.")
26 (create-dispatcher [this context handle handlers]
27 "Returns new event dispatcher associated with the specified event
28 handlers (an event-id -> handler-fn map). Handle is used to
29 match the contexts between commits.")
30 (commit [this]
31 "Apply the registered handlers for event processing."))
33 (defprotocol Anchored
34 "Provide anchor point for Layers. Used by viewport."
35 (anchor [this context h-align v-align]
36 "Anchor point: [x y], h-align could be :left, :center or :right,
37 v-align is :top, :center or :bottom"))
39 ;; Default implementation of Anchored for any Layer.
40 (extend-protocol Anchored
41 indyvon.core.Layer
42 (anchor [this context h-align v-align]
43 (if (and (= h-align :left)
44 (= v-align :top))
45 (Location. 0 0)
46 (let [size (size this context)]
47 (Location.
48 (case h-align
49 :top 0
50 :center (/ (:width size) 2)
51 :right (:width size))
52 (case v-align
53 :left 0
54 :center (/ (:height size) 2)
55 :bottom (:height size)))))))
57 (defrecord Theme [fore-color back-color border-color font])
59 (defn default-theme []
60 (Theme. Color/BLACK Color/WHITE Color/BLUE (Font. "Sans" Font/PLAIN 12)))
62 (defrecord LayerContext [x y width height clip
63 update-fn font-context theme
64 target event-dispatcher])
66 (defn default-context []
67 (LayerContext. 0 0 0 0 nil nil nil (default-theme) nil nil))
69 (defn update [context]
70 ((:update-fn context)))
72 (defn ^Graphics2D graphics
73 "Get AWT Graphics2D from context."
74 [context]
75 (:graphics context))
77 (defn- ^Graphics2D make-graphics [^Graphics2D graphics x y w h]
78 (.create graphics x y w h))
80 (defn- ^Graphics2D apply-theme [^Graphics2D graphics theme]
81 (doto graphics
82 (.setColor (:fore-color theme))
83 (.setFont (:font theme))))
85 (defn intersect [bounds x y w h]
86 (let [x12 (+ x w)
87 y12 (+ y h)
88 x21 (:x bounds)
89 y21 (:y bounds)
90 x22 (+ x21 (:width bounds))
91 y22 (+ y21 (:height bounds))
92 x1 (max x x21)
93 y1 (max y y21)
94 x2 (min x12 x22)
95 y2 (min y12 y22)]
96 (Bounds. x1 y1 (- x2 x1) (- y2 y1))))
98 (defn translate [context x y w h]
99 (let [ax (+ (:x context) x)
100 ay (+ (:y context) y)]
101 (assoc context
102 :x (+ (:x context) x)
103 :y (+ (:y context) y)
104 :width w
105 :height h
106 :clip (intersect (:clip context) ax ay w h)
107 :graphics (apply-theme
108 (make-graphics (:graphics context) x y w h)
109 (:theme context)))))
111 (defn draw!
112 "Render layer in a new graphics context."
113 ([layer context]
114 (render! layer context))
115 ([layer context x y]
116 (let [s (size layer context)]
117 (draw! layer context x y (:width s) (:height s))))
118 ([layer context x y w h]
119 (let [context (translate context x y w h)]
120 (try
121 (render! layer context)
122 (finally
123 (.dispose (:graphics context)))))))
125 (defn add-handlers [context handle handlers]
126 "Returns new context with the specified event handlers."
127 (assoc context
128 :event-dispatcher
129 (create-dispatcher (:event-dispatcher context) context
130 handle handlers)))
132 (defmacro let-handlers [handle bindings form & specs]
133 "bindings => [binding-form context] or [context-symbol]
134 specs => (:event-id name & handler-body)*
136 Execute form with the specified event handlers."
137 (let [[binding context] bindings
138 context (or context binding)]
139 `(let [context# ~context
140 ~binding
141 (add-handlers context# ~handle
142 ~(reduce (fn [m spec]
143 (assoc m (first spec)
144 `(fn [~(second spec)]
145 ~@(nnext spec)))) {}
146 specs))]
147 ~form)))
149 ;;
150 ;; EventDispatcher implementation
151 ;;
153 (def awt-events
154 {java.awt.event.MouseEvent/MOUSE_CLICKED :mouse-clicked
155 java.awt.event.MouseEvent/MOUSE_DRAGGED :mouse-dragged
156 java.awt.event.MouseEvent/MOUSE_ENTERED :mouse-entered
157 java.awt.event.MouseEvent/MOUSE_EXITED :mouse-exited
158 java.awt.event.MouseEvent/MOUSE_MOVED :mouse-moved
159 java.awt.event.MouseEvent/MOUSE_PRESSED :mouse-pressed
160 java.awt.event.MouseEvent/MOUSE_RELEASED :mouse-released})
162 (defrecord DispatcherNode [handle handlers parent bounds]
163 EventDispatcher
164 (listen! [this component]
165 (listen! parent component))
166 (create-dispatcher [this context handle handlers]
167 (create-dispatcher parent context handle handlers))
168 (commit [this]
169 (commit parent)))
171 (defn- make-node [c handle handlers]
172 (DispatcherNode. handle handlers (:event-dispatcher c) (:clip c)))
174 (defn- assoc-cons [m key val]
175 (assoc m key (cons val (get m key))))
177 (defn- add-node [tree node]
178 (assoc-cons tree (:parent node) node))
180 (defn- inside?
181 ([x y bounds]
182 (inside? x y (:x bounds) (:y bounds)
183 (:width bounds) (:height bounds)))
184 ([px py x y w h]
185 (and (>= px x)
186 (>= py y)
187 (< px (+ x w))
188 (< py (+ y h)))))
190 (defn- under-cursor
191 "Returns a sequence of child nodes under cursor."
192 [x y tree node]
193 (some #(if (inside? x y (:bounds %))
194 (conj (under-cursor x y tree %) %))
195 (get tree node)))
197 (defn- remove-all [coll1 coll2 pred]
198 (filter #(not (some (partial pred %) coll2)) coll1))
200 (defn- translate-mouse-event [^java.awt.event.MouseEvent event x y id]
201 (MouseEvent. id (.getWhen event)
202 (- (.getX event) x) (- (.getY event) y)
203 (.getXOnScreen event) (.getYOnScreen event)
204 (.getButton event)))
206 (defn- translate-and-dispatch
207 ([nodes ^java.awt.event.MouseEvent event]
208 (translate-and-dispatch nodes event (awt-events (.getID event))))
209 ([nodes event id]
210 (doseq [node nodes]
211 (when-let [handler (get (:handlers node) id)]
212 (handler
213 (translate-mouse-event event
214 (-> node :bounds :x) (-> node :bounds :y) id))))
215 id))
217 (defn- dispatch-mouse-motion*
218 "Dispatches mouse motion events. Returns a new set of nodes which
219 currently are under cursor."
220 [hovered tree root ^java.awt.event.MouseEvent event]
221 (let [x (.getX event)
222 y (.getY event)
223 hovered2 (under-cursor x y tree root)
224 pred #(= (:handle %1) (:handle %2))
225 exited (remove-all hovered hovered2 pred)
226 entered (remove-all hovered2 hovered pred)
227 moved (remove-all hovered2 entered pred)]
228 (translate-and-dispatch exited event :mouse-exited)
229 (translate-and-dispatch entered event :mouse-entered)
230 (translate-and-dispatch moved event :mouse-moved)
231 hovered2))
233 (defn- dispatch-mouse-motion
234 [hovered-ref tree root event]
235 (dosync
236 (alter hovered-ref dispatch-mouse-motion* tree root event)))
238 (defn- dispatch-mouse-button*
239 "Dispatches mouse button events. Returns a new set of nodes which
240 currently are picked with a pressed button."
241 [picked hovered event]
242 (if (= (translate-and-dispatch hovered event) :mouse-pressed)
243 hovered
244 nil))
246 (defn- dispatch-mouse-button
247 [picked-ref hovered-ref event]
248 (dosync
249 (alter picked-ref dispatch-mouse-button* @hovered-ref event)))
251 (defn root-event-dispatcher []
252 (let [tree-r (ref {}) ; register
253 tree (ref {}) ; dispatch
254 hovered (ref '())
255 picked (ref '())]
256 (reify
257 EventDispatcher
258 (listen! [this component]
259 (doto component
260 (.addMouseListener this)
261 (.addMouseMotionListener this)))
262 (create-dispatcher [this context handle handlers]
263 (let [node (make-node context handle handlers)]
264 (dosync (alter tree-r add-node node))
265 node))
266 (commit [this]
267 (dosync (ref-set tree @tree-r)
268 (ref-set tree-r {})))
269 MouseListener
270 (mouseEntered [this event]
271 (dispatch-mouse-motion hovered @tree this event))
272 (mouseExited [this event]
273 (dispatch-mouse-motion hovered @tree this event))
274 (mouseClicked [this event]
275 (dispatch-mouse-button picked hovered event))
276 (mousePressed [this event]
277 (dispatch-mouse-button picked hovered event))
278 (mouseReleased [this event]
279 (dispatch-mouse-button picked hovered event))
280 MouseMotionListener
281 (mouseDragged [this event]
282 (translate-and-dispatch @picked event))
283 (mouseMoved [this event]
284 (dispatch-mouse-motion hovered @tree this event)))))
286 ;;
287 ;; ИДЕИ:
288 ;;
289 ;; Контекст: биндинги или запись?
290 ;;
291 ;; Установка обработчиков (в контексте слоя):
292 ;;
293 ;; (listen
294 ;; (:mouse-entered e
295 ;; ...)
296 ;; (:mouse-exited e
297 ;; ...))
298 ;;
299 ;; Не надо IMGUI.
300 ;; Построение сцены путем декорирования слоев:
301 ;;
302 ;; (listener
303 ;; (:action e (println e))
304 ;; (:mouse-dragged e (println e))
305 ;; (theme :font "Helvetica-14"
306 ;; (vbox
307 ;; (button (text-layer "Button 1"))
308 ;; (button (text-layer "Button 2")))))
309 ;;