Mercurial > hg > indyvon
view src/indyvon/core.clj @ 26:1237f7555029
Rearranged namespaces.
Mouse events represented by a record.
Added alignment args to anchor.
| author | Mikhail Kryshen <mikhail@kryshen.net> |
|---|---|
| date | Mon, 21 Jun 2010 04:00:45 +0400 |
| parents | 07ee065cbb3e |
| children | 61bc04f94d61 4cb70c5a6e0d |
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 ;; TODO: modifiers
17 (defrecord MouseEvent [id when x y x-on-screen y-on-screen button])
19 (defprotocol MouseHandler
20 "Layers that also satisfy this protocol will recieve mouse events."
21 (handle-mouse [this context event]))
23 (defprotocol EventDispatcher
24 (listen! [this component])
25 (register [this context])
26 (commit [this])
27 (hovered? [this layer])
28 (picked? [this layer]))
30 (defprotocol Anchored
31 "Provide anchor point for Layers. Used by viewport."
32 (anchor [this context h-align v-align]
33 "Anchor point: [x y], h-align could be :left, :center
34 or :right, v-align is :top, :center or :bottom"))
36 ;; Default implementation of Anchored for any Layer.
37 (extend-protocol Anchored
38 indyvon.core.Layer
39 (anchor [this context h-align v-align]
40 (if (and (= h-align :left)
41 (= v-align :top))
42 [0 0]
43 (let [size (size this context)]
44 [(case h-align
45 :top 0
46 :center (/ (size 0) 2)
47 :right (size 0))
48 (case v-align
49 :left 0
50 :center (/ (size 1) 2)
51 :bottom (size 1))]))))
53 (defrecord Theme [fore-color back-color border-color font])
55 (defn default-theme []
56 (Theme. Color/BLACK Color/WHITE Color/BLUE (Font. "Sans" Font/PLAIN 12)))
58 (defrecord LayerContext [layer parent x y width height update-fn
59 dispatcher font-context theme target])
61 (defn default-context []
62 (LayerContext. nil nil 0 0 0 0 nil nil nil (default-theme) nil))
64 (defn update [context]
65 ((:update-fn context)))
67 (defn- make-graphics [graphics x y w h clip]
68 (if clip
69 (.create graphics x y w h)
70 (doto (.create graphics)
71 (.translate x y))))
73 (defn- apply-theme [graphics theme]
74 (doto graphics
75 (.setColor (:fore-color theme))
76 (.setFont (:font theme))))
78 (defn draw!
79 "Render layer in a new graphics context."
80 ([layer context graphics]
81 (draw! layer context graphics
82 0 0 (:width context) (:height context)))
83 ([layer context graphics x y]
84 (draw! layer context graphics x y true))
85 ([layer context graphics x y clip]
86 (let [s (size layer context)]
87 (draw! layer context graphics
88 x y (s 0) (s 1) clip)))
89 ([layer context graphics x y w h]
90 (draw! layer context graphics
91 x y w h true))
92 ([layer context graphics x y w h clip]
93 (let [context (assoc context
94 :layer layer
95 :parent context
96 :x (+ (:x context) x)
97 :y (+ (:y context) y)
98 :width w
99 :height h)
100 graphics (make-graphics graphics x y w h clip)
101 graphics (apply-theme graphics (:theme context))]
102 (try
103 (register (:dispatcher context) context)
104 (render! layer context graphics)
105 (finally
106 (.dispose graphics))))))
108 ;;
109 ;; EventDispatcher implementation
110 ;;
112 (def awt-events
113 {java.awt.event.MouseEvent/MOUSE_CLICKED :mouse-clicked
114 java.awt.event.MouseEvent/MOUSE_DRAGGED :mouse-dragged
115 java.awt.event.MouseEvent/MOUSE_ENTERED :mouse-entered
116 java.awt.event.MouseEvent/MOUSE_EXITED :mouse-exited
117 java.awt.event.MouseEvent/MOUSE_MOVED :mouse-moved
118 java.awt.event.MouseEvent/MOUSE_PRESSED :mouse-pressed
119 java.awt.event.MouseEvent/MOUSE_RELEASED :mouse-released})
121 (defn- registered-parent
122 "Returns first context parent registered for event processing."
123 [context-tree context]
124 (let [parent (:parent context)]
125 (cond
126 (nil? parent) nil
127 (contains? context-tree parent) parent
128 :default (recur context-tree parent))))
130 (defn- add-context
131 [context-tree context]
132 (let [parent (registered-parent context-tree context)]
133 (assoc context-tree parent (cons context (context-tree parent))
134 context nil)))
136 (defn- inside?
137 ([x y context]
138 (inside? x y (:x context) (:y context)
139 (:width context) (:height context)))
140 ([px py x y w h]
141 (and (>= px x)
142 (>= py y)
143 (< px (+ x w))
144 (< py (+ y h)))))
146 (defn- under-cursor
147 "Returns a sequence of contexts under cursor."
148 ([context-tree x y]
149 (under-cursor context-tree x y nil))
150 ([context-tree x y context]
151 (some #(if (inside? x y %)
152 (conj (under-cursor context-tree x y %) %))
153 (context-tree context))))
155 (defn- remove-all [coll1 coll2 pred]
156 (filter #(not (some (partial pred %) coll2)) coll1))
158 ;; (defn- translate-mouse-event
159 ;; [event x y id]
160 ;; (proxy [MouseEvent] [(.getComponent event)
161 ;; id
162 ;; (.getWhen event)
163 ;; (.getModifiers event)
164 ;; (- (.getX event) x)
165 ;; (- (.getY event) y)
166 ;; (.getClickCount event)
167 ;; (.isPopupTrigger event)]
168 ;; (getXOnScreen [] (.getXOnScreen event))
169 ;; (getYOnScreen [] (.getYOnScreen event))))
171 (defn- translate-mouse-event
172 [event x y id]
173 (MouseEvent. id (.getWhen event)
174 (- (.getX event) x) (- (.getY event) y)
175 (.getXOnScreen event) (.getYOnScreen event)
176 (.getButton event)))
178 (defn- translate-and-dispatch
179 ([contexts event]
180 (translate-and-dispatch contexts event (awt-events (.getID event))))
181 ([contexts event id]
182 (doseq [context contexts]
183 (handle-mouse
184 (:layer context) context
185 (translate-mouse-event event (:x context) (:y context) id)))
186 id))
188 (defn- dispatch-mouse-motion*
189 "Dispatches mouse motion events. Returns a new set of contexts which
190 currently are under cursor."
191 [hovered context-tree event]
192 (let [x (.getX event)
193 y (.getY event)
194 hovered2 (under-cursor context-tree x y)
195 pred #(= (:layer %1) (:layer %2))
196 exited (remove-all hovered hovered2 pred)
197 entered (remove-all hovered2 hovered pred)
198 moved (remove-all hovered2 entered pred)]
199 (translate-and-dispatch exited event :mouse-exited)
200 (translate-and-dispatch entered event :mouse-entered)
201 (translate-and-dispatch moved event :mouse-moved)
202 hovered2))
204 (defn- dispatch-mouse-motion
205 [hovered-ref context-tree event]
206 (dosync
207 (alter hovered-ref dispatch-mouse-motion* context-tree event)))
209 (defn- dispatch-mouse-button*
210 "Dispatches mouse button events. Returns a new set of contexts which
211 currently are picked with a pressed button."
212 [picked hovered event]
213 (if (= (translate-and-dispatch hovered event) :mouse-pressed)
214 hovered
215 nil))
217 (defn- dispatch-mouse-button
218 [picked-ref hovered-ref event]
219 (dosync
220 (alter picked-ref dispatch-mouse-button* @hovered-ref event)))
222 (defn make-event-dispatcher []
223 (let [context-tree-r (ref {}) ; register
224 context-tree (ref {}) ; dispatch
225 hovered (ref '())
226 picked (ref '())]
227 (reify
228 EventDispatcher
229 (listen! [this component]
230 (doto component
231 (.addMouseListener this)
232 (.addMouseMotionListener this)))
233 (register [this context]
234 (when (satisfies? MouseHandler (:layer context))
235 (dosync (alter context-tree-r add-context context))))
236 (commit [this]
237 (dosync (ref-set context-tree @context-tree-r)
238 (ref-set context-tree-r {})))
239 (picked? [this layer] false)
240 (hovered? [this layer] false)
241 MouseListener
242 (mouseEntered [this event]
243 (dispatch-mouse-motion hovered @context-tree event))
244 (mouseExited [this event]
245 (dispatch-mouse-motion hovered @context-tree event))
246 (mouseClicked [this event]
247 (dispatch-mouse-button picked hovered event))
248 (mousePressed [this event]
249 (dispatch-mouse-button picked hovered event))
250 (mouseReleased [this event]
251 (dispatch-mouse-button picked hovered event))
252 MouseMotionListener
253 (mouseDragged [this event]
254 (translate-and-dispatch @picked event))
255 (mouseMoved [this event]
256 (dispatch-mouse-motion hovered @context-tree event)))))