Mercurial > hg > indyvon
view src/kryshen/indyvon/core.clj @ 36:5413b188d112
Rename namespaces: indyvon to kryshen.indyvon.
| author | Mikhail Kryshen <mikhail@kryshen.net> |
|---|---|
| date | Thu, 08 Jul 2010 07:03:24 +0400 |
| parents | |
| children | d2fb660ca49f |
line source
1 ;;
2 ;; Copyright (C) 2010 Mikhail Kryshen <mikhail@kryshen.net>
3 ;;
4 ;; This file is part of Indyvon.
5 ;;
7 (ns kryshen.indyvon.core
8 (:import (java.awt Graphics2D Component Color Font)
9 (java.awt.event MouseListener MouseMotionListener)
10 (java.awt.font FontRenderContext)))
12 (def ^Graphics2D *graphics*)
13 (def ^FontRenderContext *font-context*)
14 (def ^Component *target*)
15 (def *bounds*)
16 (def *clip*)
17 (def *update*)
18 (def *event-dispatcher*)
20 (defrecord Theme [fore-color back-color border-color font])
22 (defn default-theme []
23 (Theme. Color/BLACK Color/WHITE Color/BLUE (Font. "Sans" Font/PLAIN 12)))
25 (def *theme* (default-theme))
27 (defrecord Location [x y])
28 (defrecord Size [width height])
29 (defrecord Bounds [x y width height])
31 (defprotocol Layer
32 "Basic UI element."
33 (render! [this opts])
34 (size [this opts]))
36 ;; TODO: modifiers
37 (defrecord MouseEvent [id when x y x-on-screen y-on-screen button])
39 (defprotocol EventDispatcher
40 (listen! [this ^Component component]
41 "Listen for events on the specified AWT Component.")
42 (create-dispatcher [this handle handlers]
43 "Returns new event dispatcher associated with the specified event
44 handlers (an event-id -> handler-fn map). Handle is used to
45 match the contexts between commits.")
46 (commit [this]
47 "Apply the registered handlers for event processing."))
49 (defprotocol Anchored
50 "Provide anchor point for Layers. Used by viewport."
51 (anchor [this h-align v-align opts]
52 "Anchor point: [x y], h-align could be :left, :center or :right,
53 v-align is :top, :center or :bottom"))
55 ;; Default implementation of Anchored for any Layer.
56 (extend-protocol Anchored
57 kryshen.indyvon.core.Layer
58 (anchor [this h-align v-align opts]
59 (if (and (= h-align :left)
60 (= v-align :top))
61 (Location. 0 0)
62 (let [size (size this opts)]
63 (Location.
64 (case h-align
65 :top 0
66 :center (/ (:width size) 2)
67 :right (:width size))
68 (case v-align
69 :left 0
70 :center (/ (:height size) 2)
71 :bottom (:height size)))))))
73 (defn- ^Graphics2D make-graphics [^Graphics2D graphics x y w h]
74 (.create graphics x y w h))
76 (defn- ^Graphics2D apply-theme [^Graphics2D graphics theme]
77 (doto graphics
78 (.setColor (:fore-color theme))
79 (.setFont (:font theme))))
81 (defn intersect [b1 b2]
82 (let [x11 (:x b1)
83 y11 (:y b1)
84 x12 (+ x11 (:width b1))
85 y12 (+ y11 (:height b1))
86 x21 (:x b2)
87 y21 (:y b2)
88 x22 (+ x21 (:width b2))
89 y22 (+ y21 (:height b2))
90 x1 (max x11 x21)
91 y1 (max y11 y21)
92 x2 (min x12 x22)
93 y2 (min y12 y22)]
94 (Bounds. x1 y1 (- x2 x1) (- y2 y1))))
96 (defn with-translate* [x y w h f & args]
97 (let [graphics (apply-theme (.create *graphics* x y w h) *theme*)
98 bounds (Bounds. (+ x (:x *bounds*))
99 (+ y (:y *bounds*))
100 w h)]
101 (try
102 (apply with-bindings* {#'*bounds* bounds
103 #'*clip* (intersect bounds *clip*)
104 #'*graphics* graphics}
105 f args)
106 (finally
107 (.dispose graphics)))))
109 (defmacro with-translate [x y w h & body]
110 `(with-translate* ~x ~y ~w ~h (fn [] ~@body)))
114 (defn with-handlers* [handle handlers f & args]
115 (apply with-bindings*
116 {#'*event-dispatcher*
117 (create-dispatcher *event-dispatcher* handle handlers)}
118 f args))
120 (defmacro with-handlers
121 "specs => (:event-id name & handler-body)*
123 Execute form with the specified event handlers."
124 [handle form & specs]
125 `(with-handlers* ~handle
126 ~(reduce (fn [m spec]
127 (assoc m (first spec)
128 `(fn [~(second spec)]
129 ~@(nnext spec)))) {}
130 specs)
131 (fn [] ~form)))
133 (defn- geometry-vec [geometry]
134 (if (vector? geometry)
135 geometry
136 [(:x geometry) (:y geometry) (:width geometry) (:height geometry)]))
138 (defn draw!
139 "Draw a layer. Geometry is either a map or vector [x y] or
140 [x y width height]."
141 [layer geometry & args]
142 (let [[x y w h] (geometry-vec geometry)
143 size (if-not (and w h) (size layer args))
144 w (or w (:width size))
145 h (or h (:height size))]
146 (with-translate* x y w h render! layer args)))
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 (defrecord DispatcherNode [handle handlers parent bounds bindings]
162 EventDispatcher
163 (listen! [this component]
164 (listen! parent component))
165 (create-dispatcher [this handle handlers]
166 (create-dispatcher parent handle handlers))
167 (commit [this]
168 (commit parent)))
170 (defn- make-node [handle handlers]
171 (DispatcherNode. handle handlers *event-dispatcher* *clip*
172 (get-thread-bindings)))
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 (with-bindings* (:bindings node)
213 handler
214 (translate-mouse-event event
215 (-> node :bounds :x) (-> node :bounds :y) id))))
216 id))
218 (defn- dispatch-mouse-motion*
219 "Dispatches mouse motion events. Returns a new set of nodes which
220 currently are under cursor."
221 [hovered tree root ^java.awt.event.MouseEvent event]
222 (let [x (.getX event)
223 y (.getY event)
224 hovered2 (under-cursor x y tree root)
225 pred #(= (:handle %1) (:handle %2))
226 exited (remove-all hovered hovered2 pred)
227 entered (remove-all hovered2 hovered pred)
228 moved (remove-all hovered2 entered pred)]
229 (translate-and-dispatch exited event :mouse-exited)
230 (translate-and-dispatch entered event :mouse-entered)
231 (translate-and-dispatch moved event :mouse-moved)
232 hovered2))
234 (defn- dispatch-mouse-motion
235 [hovered-ref tree root event]
236 (dosync
237 (alter hovered-ref dispatch-mouse-motion* tree root event)))
239 (defn- dispatch-mouse-button*
240 "Dispatches mouse button events. Returns a new set of nodes which
241 currently are picked with a pressed button."
242 [picked hovered event]
243 (if (= (translate-and-dispatch hovered event) :mouse-pressed)
244 hovered
245 nil))
247 (defn- dispatch-mouse-button
248 [picked-ref hovered-ref event]
249 (dosync
250 (alter picked-ref dispatch-mouse-button* @hovered-ref event)))
252 (defn root-event-dispatcher []
253 (let [tree-r (ref {}) ; register
254 tree (ref {}) ; dispatch
255 hovered (ref '())
256 picked (ref '())]
257 (reify
258 EventDispatcher
259 (listen! [this component]
260 (doto component
261 (.addMouseListener this)
262 (.addMouseMotionListener this)))
263 (create-dispatcher [this handle handlers]
264 (let [node (make-node handle handlers)]
265 (dosync (alter tree-r add-node node))
266 node))
267 (commit [this]
268 (dosync (ref-set tree @tree-r)
269 (ref-set tree-r {})))
270 MouseListener
271 (mouseEntered [this event]
272 (dispatch-mouse-motion hovered @tree this event))
273 (mouseExited [this event]
274 (dispatch-mouse-motion hovered @tree this event))
275 (mouseClicked [this event]
276 (dispatch-mouse-button picked hovered event))
277 (mousePressed [this event]
278 (dispatch-mouse-button picked hovered event))
279 (mouseReleased [this event]
280 (dispatch-mouse-button picked hovered event))
281 MouseMotionListener
282 (mouseDragged [this event]
283 (translate-and-dispatch @picked event))
284 (mouseMoved [this event]
285 (dispatch-mouse-motion hovered @tree this event)))))
287 ;;
288 ;; ИДЕИ:
289 ;;
290 ;; Контекст: биндинги или запись?
291 ;;
292 ;; Установка обработчиков (в контексте слоя):
293 ;;
294 ;; (listen
295 ;; (:mouse-entered e
296 ;; ...)
297 ;; (:mouse-exited e
298 ;; ...))
299 ;;
300 ;; Не надо IMGUI.
301 ;; Построение сцены путем декорирования слоев:
302 ;;
303 ;; (listener
304 ;; (:action e (println e))
305 ;; (:mouse-dragged e (println e))
306 ;; (theme :font "Helvetica-14"
307 ;; (vbox
308 ;; (button (text-layer "Button 1"))
309 ;; (button (text-layer "Button 2")))))
310 ;;