Mercurial > hg > indyvon
view src/indyvon/core.clj @ 28:828795987d4c
Some ideas.
| author | Mikhail Kryshen <mikhail@kryshen.net> |
|---|---|
| date | Mon, 05 Jul 2010 06:11:42 +0400 |
| parents | 61bc04f94d61 |
| 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 Color Font)
9 (java.awt.event MouseListener MouseMotionListener)))
11 (defrecord Location [x y])
12 (defrecord Size [width height])
13 (defrecord Bounds [x y width height])
15 (def *graphics*)
16 (def *font-context*)
17 (def *bounds*)
18 (def *target*)
19 (def *update*)
20 (def *event-dispatcher*)
21 (def *path*)
23 (defrecord Theme [fore-color back-color border-color font])
25 (defn- default-theme []
26 (Theme. Color/BLACK Color/WHITE Color/BLUE (Font. "Sans" Font/PLAIN 12)))
28 (def *theme* (default-theme))
30 (defprotocol Layer
31 "Basic UI element."
32 (render! [this opts])
33 (size [this opts]))
35 (defn layer? [x]
36 (satisfies? Layer x))
38 (defprotocol EventDispatcher
39 (listen! [this component])
40 (register [this handle-path])
41 (handler [this handle-path event-id f])
42 (commit [this]))
44 ;; TODO: modifiers
45 (defrecord MouseEvent [id when x y x-on-screen y-on-screen button])
47 (defn- apply-theme [graphics]
48 (doto graphics
49 (.setColor (:fore-color *theme*))
50 (.setFont (:font *theme*))))
52 (defn with-translate* [x y w h f & args]
53 (let [graphics (apply-theme (.create *graphics* x y w h))]
54 (try
55 (apply with-bindings* {#'*bounds* (Bounds. (+ x (:x *bounds*))
56 (+ y (:y *bounds*))
57 w h)
58 #'*graphics* graphics}
59 f args)
60 (finally
61 (.dispose graphics)))))
63 (defmacro with-translate [x y w h & body]
64 `(with-translate* ~x ~y ~w ~h (fn [] ~@body)))
66 (defn with-handle* [handle f & args]
67 (let [path (cons handle *path*)]
68 (register *event-dispatcher* path)
69 (apply with-bindings* {#'*path* path} f args)))
71 (defmacro with-handle [handle & body]
72 `(with-handle* ~handle (fn [] ~@body)))
74 (defn handle-event* [event-id f & args]
75 (let [f (if args #(f % args) f)]
76 (handler *event-dispatcher* *path* event-id f)))
78 (defmacro handle-event [event-id name & body]
79 `(handle-event* ~event-id (fn [~name] ~@body)))
81 (defn- geometry-vec [geometry]
82 (if (vector? geometry)
83 geometry
84 [(:x geometry) (:y geometry) (:width geometry) (:height geometry)]))
86 (defn draw! [layer geometry & args]
87 "Draw a layer. Geometry is either a map or vector [x y] or
88 [x y width height]."
89 (let [[x y w h] (geometry-vec geometry)
90 size (if-not (and w h) (size layer args))
91 w (or w (:width size))
92 h (or h (:height size))]
93 (with-translate* x y w h render! layer args)))
95 ;;
96 ;; EventDispatcher
97 ;;
99 (def awt-events
100 {java.awt.event.MouseEvent/MOUSE_CLICKED :mouse-clicked
101 java.awt.event.MouseEvent/MOUSE_DRAGGED :mouse-dragged
102 java.awt.event.MouseEvent/MOUSE_ENTERED :mouse-entered
103 java.awt.event.MouseEvent/MOUSE_EXITED :mouse-exited
104 java.awt.event.MouseEvent/MOUSE_MOVED :mouse-moved
105 java.awt.event.MouseEvent/MOUSE_PRESSED :mouse-pressed
106 java.awt.event.MouseEvent/MOUSE_RELEASED :mouse-released})
108 (defrecord DispatcherNode [id bounds children handlers])
110 (defn- add-child [node child]
111 (assoc node :children (cons child (:children node))))
113 (defn- add-path [tree path]
114 (let [parent-path (next path)
115 parent-node (get tree parent-path)
116 node (DispatcherNode. path *bounds* nil
117 (get-in tree [path :handlers]))]
118 (assoc tree
119 parent-path (add-child parent-node node)
120 path node)))
122 (defn add-handler [tree path event-id f]
123 (let [keys [path :handlers event-id]]
124 (assoc-in tree keys (cons f (get-in tree keys)))))
126 (defn- inside?
127 ([x y bounds]
128 (inside? x y (:x bounds) (:y bounds)
129 (:width bounds) (:height bounds)))
130 ([px py x y w h]
131 (and (>= px x)
132 (>= py y)
133 (< px (+ x w))
134 (< py (+ y h)))))
136 (defn- under-cursor
137 "Returns a sequence of nodes under cursor."
138 ([tree x y]
139 (under-cursor tree x y nil))
140 ([tree x y node]
141 (some #(if (inside? x y (:bounds %))
142 (conj (under-cursor tree x y %) %))
143 (get tree (:children node)))))
145 (defn- remove-all [coll1 coll2 pred]
146 (filter #(not (some (partial pred %) coll2)) coll1))
148 (defn- translate-mouse-event
149 [event x y id]
150 (MouseEvent. id (.getWhen event)
151 (- (.getX event) x) (- (.getY event) y)
152 (.getXOnScreen event) (.getYOnScreen event)
153 (.getButton event)))
155 (defn- translate-and-dispatch
156 ([nodes event]
157 (translate-and-dispatch nodes event (awt-events (.getID event))))
158 ([nodes event id]
159 (doseq [node nodes
160 :let [bounds (:bounds node)
161 event (translate-mouse-event event
162 (:x bounds) (:y bounds) id)]
163 handler (get (:handlers node) id)]
164 ;; TODO restore more of the original context.
165 (with-bindings* {#'*bounds* bounds} handler event))
166 id))
168 (defn- dispatch-mouse-motion*
169 "Dispatches mouse motion events. Returns a new set of nodes which
170 currently are under cursor."
171 [hovered tree event]
172 (let [x (.getX event)
173 y (.getY event)
174 hovered2 (under-cursor tree x y)
175 pred #(= (:id %1) (:id %2))
176 exited (remove-all hovered hovered2 pred)
177 entered (remove-all hovered2 hovered pred)
178 moved (remove-all hovered2 entered pred)]
179 (translate-and-dispatch exited event :mouse-exited)
180 (translate-and-dispatch entered event :mouse-entered)
181 (translate-and-dispatch moved event :mouse-moved)
182 hovered2))
184 (defn- dispatch-mouse-motion
185 [hovered-ref tree event]
186 (dosync
187 (alter hovered-ref dispatch-mouse-motion* tree event)))
189 (defn- dispatch-mouse-button*
190 "Dispatches mouse button events. Returns a new set of nodes which
191 currently are picked with a pressed button."
192 [picked hovered event]
193 (if (= (translate-and-dispatch hovered event) :mouse-pressed)
194 hovered
195 nil))
197 (defn- dispatch-mouse-button
198 [picked-ref hovered-ref event]
199 (dosync
200 (alter picked-ref dispatch-mouse-button* @hovered-ref event)))
202 (defn make-event-dispatcher []
203 (let [root-node (DispatcherNode. nil nil nil nil)
204 tree-i {nil root-node} ; initial
205 tree-r (ref tree-i) ; register
206 tree (ref tree-i) ; dispatch
207 hovered (ref '())
208 picked (ref '())]
209 (reify
210 EventDispatcher
211 (listen! [this component]
212 (doto component
213 (.addMouseListener this)
214 (.addMouseMotionListener this)))
215 (register [this path]
216 (dosync (alter tree-r add-path path)))
217 (handler [this path event-id f]
218 (dosync (alter tree-r add-handler path event-id f)))
219 (commit [this]
220 (dosync (ref-set tree @tree-r)
221 (ref-set tree-r tree-i)))
222 MouseListener
223 (mouseEntered [this event]
224 (dispatch-mouse-motion hovered @tree event))
225 (mouseExited [this event]
226 (dispatch-mouse-motion hovered @tree event))
227 (mouseClicked [this event]
228 (dispatch-mouse-button picked hovered event))
229 (mousePressed [this event]
230 (dispatch-mouse-button picked hovered event))
231 (mouseReleased [this event]
232 (dispatch-mouse-button picked hovered event))
233 MouseMotionListener
234 (mouseDragged [this event]
235 (translate-and-dispatch @picked event))
236 (mouseMoved [this event]
237 (dispatch-mouse-motion hovered @tree event)))))
239 ;;
240 ;; ИДЕИ:
241 ;;
242 ;; Контекст: биндинги или запись?
243 ;;
244 ;; Установка обработчиков (в контексте слоя):
245 ;;
246 ;; (listen
247 ;; (:mouse-entered e
248 ;; ...)
249 ;; (:mouse-exited e
250 ;; ...))
251 ;;
252 ;; Не надо IMGUI.
253 ;; Построение сцены путем декорирования слоев:
254 ;;
255 ;; (listener
256 ;; (:action e (println e))
257 ;; (:mouse-dragged e (println e))
258 ;; (theme :font "Helvetica-14"
259 ;; (vbox
260 ;; (button (text-layer "Button 1"))
261 ;; (button (text-layer "Button 2")))))
262 ;;