Mercurial > hg > indyvon
view src/indyvon/event.clj @ 19:43f0d78057a9
New event dispatching code that uses weak references to allow listened layers to be garbage-collected.
| author | Mikhail Kryshen <mikhail@kryshen.net> |
|---|---|
| date | Thu, 17 Jun 2010 20:59:22 +0400 |
| parents | 0a2fafca72d8 |
| children | a70609bad3a4 |
line source
1 ;;
2 ;; Copyright (C) 2010 Mikhail Kryshen <mikhail@kryshen.net>
3 ;;
4 ;; This file is part of Indyvon.
5 ;;
7 (ns indyvon.event
8 (:use indyvon.core)
9 (:import (java.awt.event MouseEvent MouseListener MouseMotionListener)
10 java.lang.ref.WeakReference))
12 ;; map event-id -> [layer-weak-ref1 fn1, layer-weak-ref2 fn2...]
13 (def listeners-map (ref {}))
15 (defn- assoc-conj [map key & vals]
16 (assoc map key (apply conj (vec (get map key)) vals)))
18 (defn add-listener
19 "The supplied function will be invoked with context, event and
20 additional args when an event with the specified id occurs on the
21 specified layer."
22 [layer event-id f & args]
23 (let [f (if args #(apply f %1 %2 args) f)]
24 (dosync
25 (alter listeners-map assoc-conj event-id (WeakReference. layer) f))
26 nil))
28 (defn- listeners
29 "Returns list of listener fns for event and target-layer. Listeners
30 for garbage-collected layers are removed."
31 [event-id target-layer]
32 (dosync
33 (loop [ref-vec (@listeners-map event-id) cleared-ref-vec [] listeners []]
34 (if-let [layer-ref (first ref-vec)]
35 (if-let [layer (.get layer-ref)]
36 (let [lfn (second ref-vec)]
37 (recur (nnext ref-vec)
38 (conj cleared-ref-vec layer-ref lfn)
39 (if (= layer target-layer)
40 (conj listeners lfn)
41 listeners)))
42 (recur (nnext ref-vec) cleared-ref-vec listeners))
43 (do
44 (alter listeners-map assoc event-id cleared-ref-vec)
45 listeners)))))
47 (defn dispatch-event [context event]
48 (doseq [listener (listeners (.getID event) (:layer context))]
49 (listener context event)))
51 (defprotocol EventDispatcher
52 (listen! [this component])
53 (register [this context])
54 (commit [this])
55 (hovered? [this layer])
56 (picked? [this layer]))
58 (defn register-context [context]
59 (register (:dispatcher context) context))
61 (defn- registered-parent
62 "Returns first context parent registered for event processing."
63 [context-tree context]
64 (let [parent (:parent context)]
65 (cond
66 (nil? parent) nil
67 (contains? context-tree parent) parent
68 :default (recur context-tree parent))))
70 (defn- add-context
71 [context-tree context]
72 (let [parent (registered-parent context-tree context)]
73 (assoc context-tree parent (conj (context-tree parent) context)
74 context nil)))
76 (defn- inside?
77 ([x y context]
78 (inside? x y (:x context) (:y context)
79 (:width context) (:height context)))
80 ([px py x y w h]
81 (and (>= px x)
82 (>= py y)
83 (< px (+ x w))
84 (< py (+ y h)))))
86 (defn- under-cursor
87 "Returns a sequence of contexts under cursor."
88 ([context-tree x y]
89 (under-cursor context-tree x y nil))
90 ([context-tree x y context]
91 (some #(if (inside? x y %)
92 (conj (under-cursor context-tree x y %) %))
93 (context-tree context))))
95 (defn- remove-all [coll1 coll2 pred]
96 (filter #(not (some (partial pred %) coll2)) coll1))
98 (defn- translate-mouse-event
99 [event x y id]
100 (proxy [MouseEvent] [(.getComponent event)
101 id
102 (.getWhen event)
103 (.getModifiers event)
104 (- (.getX event) x)
105 (- (.getY event) y)
106 (.getClickCount event)
107 (.isPopupTrigger event)]
108 (getXOnScreen [] (.getXOnScreen event))
109 (getYOnScreen [] (.getYOnScreen event))))
111 (defn- translate-and-dispatch
112 ([contexts event]
113 (translate-and-dispatch contexts event (.getID event)))
114 ([contexts event id]
115 (doseq [context contexts]
116 (dispatch-event
117 context
118 (translate-mouse-event event (:x context) (:y context) id)))))
120 (defn- dispatch-mouse-motion*
121 "Dispatches mouse motion events. Returns a new set of contexts which
122 currently are under cursor."
123 [hovered context-tree event]
124 (let [x (.getX event)
125 y (.getY event)
126 hovered2 (under-cursor context-tree x y)
127 pred #(= (:layer %1) (:layer %2))
128 exited (remove-all hovered hovered2 pred)
129 entered (remove-all hovered2 hovered pred)
130 moved (remove-all hovered2 entered pred)]
131 (translate-and-dispatch exited event MouseEvent/MOUSE_EXITED)
132 (translate-and-dispatch entered event MouseEvent/MOUSE_ENTERED)
133 (translate-and-dispatch moved event MouseEvent/MOUSE_MOVED)
134 hovered2))
136 (defn- dispatch-mouse-motion
137 [hovered-ref context-tree event]
138 (dosync
139 (alter hovered-ref dispatch-mouse-motion* context-tree event)))
141 (defn- dispatch-mouse-button*
142 "Dispatches mouse button events. Returns a new set of contexts which
143 currently are picked with a pressed button."
144 [picked hovered context-tree event]
145 (translate-and-dispatch hovered event)
146 (if (= (.getID event) MouseEvent/MOUSE_PRESSED)
147 hovered
148 nil))
150 (defn- dispatch-mouse-button
151 [picked-ref hovered-ref context-tree event]
152 (dosync
153 (alter picked-ref dispatch-mouse-button*
154 @hovered-ref context-tree event)))
156 (defn make-event-dispatcher []
157 (let [context-tree-r (ref {}) ; register
158 context-tree (ref {}) ; dispatch
159 hovered (ref '())
160 picked (ref '())]
161 (reify
162 EventDispatcher
163 (listen! [this component]
164 (doto component
165 (.addMouseListener this)
166 (.addMouseMotionListener this)))
167 (register [this context]
168 (dosync (alter context-tree-r add-context context)))
169 (commit [this]
170 (dosync (ref-set context-tree @context-tree-r)
171 (ref-set context-tree-r {})))
172 (picked? [this layer] false)
173 (hovered? [this layer] false)
174 MouseListener
175 (mouseEntered [this event]
176 (dispatch-mouse-motion hovered context-tree event))
177 (mouseExited [this event]
178 (dispatch-mouse-motion hovered context-tree event))
179 (mouseClicked [this event]
180 (dispatch-mouse-button picked hovered context-tree event))
181 (mousePressed [this event]
182 (dispatch-mouse-button picked hovered context-tree event))
183 (mouseReleased [this event]
184 (dispatch-mouse-button picked hovered context-tree event))
185 MouseMotionListener
186 (mouseDragged [this event]
187 (translate-and-dispatch @picked event))
188 (mouseMoved [this event]
189 (dispatch-mouse-motion hovered context-tree event)))))