Mercurial > hg > indyvon
view src/indyvon/core_new.clj @ 27:61bc04f94d61
Yet another approach at event dispatching (unfinished).
| author | Mikhail Kryshen <mikhail@kryshen.net> |
|---|---|
| date | Sun, 04 Jul 2010 06:03:48 +0400 |
| parents | |
| children |
line source
1 ;; Copyright (C) 2010 Mikhail Kryshen <mikhail@kryshen.net>
2 ;;
3 ;; This file is part of Indyvon.
4 ;;
6 (ns indyvon.core_new
7 (:import (java.awt Color Font)
8 (java.awt.event MouseListener MouseMotionListener)))
10 (defrecord Location [x y])
11 (defrecord Size [width height])
12 (defrecord Bounds [x y width height])
14 (def *graphics*)
15 (def *font-context*)
16 (def *bounds*)
17 (def *theme*)
18 (def *target*)
19 (def *update*)
20 (def *event-dispatcher*)
21 (def *path*)
23 (defprotocol Layer
24 "Basic UI element."
25 (render! [this opts])
26 (size [this opts]))
28 (defn layer? [x]
29 (satisfies? Layer x))
31 (defprotocol EventDispatcher
32 (listen! [this component])
33 (register [this handle-path])
34 (handler [this handle-path event-id f])
35 (commit [this]))
37 ;; TODO: modifiers
38 (defrecord MouseEvent [id when x y x-on-screen y-on-screen button])
40 (defn with-translate* [x y w h f & args]
41 (let [graphics (.create *graphics* x y w h)]
42 (try
43 (apply with-bindings* {#'*bounds* (Bounds. (+ x (:x *bounds*))
44 (+ y (:y *bounds*))
45 w h)
46 #'*graphics* graphics}
47 f args)
48 (finally
49 (.dispose graphics)))))
51 (defn with-handle* [handle f & args]
52 (let [path (cons handle *path*)]
53 (register *event-dispatcher* path)
54 (apply with-bindings* {#'*path* path} f args)))
56 (defn- geometry-vec [geometry]
57 (if (vector? geometry)
58 geometry
59 [(:x geometry) (:y geometry) (:width geometry) (:height geometry)]))
61 (defn draw! [layer geometry & args]
62 "Draw a layer. Geometry is either a map or vector [x y] or
63 [x y width height]."
64 (let [[x y w h] (geometry-vec geometry)
65 size (if-not (and w h) (size layer args))
66 w (or w (:width size))
67 h (or h (:height size))]
68 (with-translate* x y w h render! layer args)))
70 (defn draw-root! [layer width height graphics event-dispatcher]
71 (with-bindings* {#'*path* nil
72 #'*graphics* graphics
73 #'*event-dispatcher* event-dispatcher
74 #'*bounds* (Bounds. 0 0 width height)}
75 render! layer))
77 ;;
78 ;; EventDispatcher
79 ;;
81 (def awt-events
82 {java.awt.event.MouseEvent/MOUSE_CLICKED :mouse-clicked
83 java.awt.event.MouseEvent/MOUSE_DRAGGED :mouse-dragged
84 java.awt.event.MouseEvent/MOUSE_ENTERED :mouse-entered
85 java.awt.event.MouseEvent/MOUSE_EXITED :mouse-exited
86 java.awt.event.MouseEvent/MOUSE_MOVED :mouse-moved
87 java.awt.event.MouseEvent/MOUSE_PRESSED :mouse-pressed
88 java.awt.event.MouseEvent/MOUSE_RELEASED :mouse-released})
90 (defrecord DispatcherNode [id bounds children handlers])
92 (defn- add-child [node child]
93 (assoc node :children (cons child (:children node))))
95 (defn- add-path [tree path]
96 (let [parent-path (next path)
97 parent-node (get tree parent-path)
98 node (DispatcherNode. path *bounds* nil
99 (get-in tree [path :handlers]))]
100 (assoc tree
101 parent-path (add-child parent-node node)
102 path node)))
104 (defn add-handler [tree path event-id f]
105 (let [keys [path :handlers event-id]]
106 (assoc-in tree keys (cons f (get-in tree keys)))))
108 (defn- inside?
109 ([x y bounds]
110 (inside? x y (:x bounds) (:y bounds)
111 (:width bounds) (:height bounds)))
112 ([px py x y w h]
113 (and (>= px x)
114 (>= py y)
115 (< px (+ x w))
116 (< py (+ y h)))))
118 (defn- under-cursor
119 "Returns a sequence of nodes under cursor."
120 ([tree x y]
121 (under-cursor tree x y nil))
122 ([tree x y node]
123 (some #(if (inside? x y (:bounds %))
124 (conj (under-cursor tree x y %) %))
125 (get tree (:children node)))))
127 (defn- remove-all [coll1 coll2 pred]
128 (filter #(not (some (partial pred %) coll2)) coll1))
130 (defn- translate-mouse-event
131 [event x y id]
132 (MouseEvent. id (.getWhen event)
133 (- (.getX event) x) (- (.getY event) y)
134 (.getXOnScreen event) (.getYOnScreen event)
135 (.getButton event)))
137 (defn- translate-and-dispatch
138 ([nodes event]
139 (translate-and-dispatch nodes event (awt-events (.getID event))))
140 ([nodes event id]
141 (doseq [node nodes
142 :let [bounds (:bounds node)
143 event (translate-mouse-event event
144 (:x bounds) (:y bounds) id)]
145 handler (get (:handlers node) id)]
146 ;; TODO restore more of the original context.
147 (with-bindings* {#'*bounds* bounds} handler event))
148 id))
150 (defn- dispatch-mouse-motion*
151 "Dispatches mouse motion events. Returns a new set of nodes which
152 currently are under cursor."
153 [hovered tree event]
154 (let [x (.getX event)
155 y (.getY event)
156 hovered2 (under-cursor tree x y)
157 pred #(= (:id %1) (:id %2))
158 exited (remove-all hovered hovered2 pred)
159 entered (remove-all hovered2 hovered pred)
160 moved (remove-all hovered2 entered pred)]
161 (translate-and-dispatch exited event :mouse-exited)
162 (translate-and-dispatch entered event :mouse-entered)
163 (translate-and-dispatch moved event :mouse-moved)
164 hovered2))
166 (defn- dispatch-mouse-motion
167 [hovered-ref tree event]
168 (dosync
169 (alter hovered-ref dispatch-mouse-motion* tree event)))
171 (defn- dispatch-mouse-button*
172 "Dispatches mouse button events. Returns a new set of nodes which
173 currently are picked with a pressed button."
174 [picked hovered event]
175 (if (= (translate-and-dispatch hovered event) :mouse-pressed)
176 hovered
177 nil))
179 (defn- dispatch-mouse-button
180 [picked-ref hovered-ref event]
181 (dosync
182 (alter picked-ref dispatch-mouse-button* @hovered-ref event)))
184 (defn make-event-dispatcher []
185 (let [root-node (DispatcherNode. nil nil nil nil)
186 tree-i {nil root-node} ; initial
187 tree-r (ref tree-i) ; register
188 tree (ref tree-i) ; dispatch
189 hovered (ref '())
190 picked (ref '())]
191 (reify
192 EventDispatcher
193 (listen! [this component]
194 (doto component
195 (.addMouseListener this)
196 (.addMouseMotionListener this)))
197 (register [this path]
198 (dosync (alter tree-r add-path path)))
199 (handler [this path event-id f]
200 (dosync (alter tree-r add-handler path event-id f)))
201 (commit [this]
202 (dosync (ref-set tree @tree-r)
203 (ref-set tree-r tree-i)))
204 MouseListener
205 (mouseEntered [this event]
206 (dispatch-mouse-motion hovered @tree event))
207 (mouseExited [this event]
208 (dispatch-mouse-motion hovered @tree event))
209 (mouseClicked [this event]
210 (dispatch-mouse-button picked hovered event))
211 (mousePressed [this event]
212 (dispatch-mouse-button picked hovered event))
213 (mouseReleased [this event]
214 (dispatch-mouse-button picked hovered event))
215 MouseMotionListener
216 (mouseDragged [this event]
217 (translate-and-dispatch @picked event))
218 (mouseMoved [this event]
219 (dispatch-mouse-motion hovered @tree event)))))
221 ;; (with-handle :button1
222 ;; (draw! button [5 5 100 200] "Cick Me!"))
224 ;; (when-event :action :button1
225 ;; ...)
227 ;; (handle-event :mouse-entered :button1
228 ;; ...)