Mercurial > hg > indyvon
view src/indyvon/event.clj @ 21:a70609bad3a4
Simpler event dispatching.
| author | Mikhail Kryshen <mikhail@kryshen.net> |
|---|---|
| date | Sat, 19 Jun 2010 04:27:29 +0400 |
| parents | 43f0d78057a9 |
| children | dc81033d4122 |
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 (defprotocol EventDispatcher
13 (listen! [this component])
14 (register-mouse-handler [this context handler])
15 (commit [this])
16 (hovered? [this layer])
17 (picked? [this layer]))
19 (defn mouse-handler [context handler & args]
20 "The supplied handler function will be invoked with context, event
21 and additional args when mouse event occurs on the context."
22 (let [handler (if args #(apply handler %1 %2 args) handler)]
23 (register-mouse-handler (:dispatcher context) context handler)))
25 (defn- registered-parent
26 "Returns first context parent registered for event processing."
27 [context-tree context]
28 (let [parent (:parent context)]
29 (cond
30 (nil? parent) nil
31 (contains? context-tree parent) parent
32 :default (recur context-tree parent))))
34 (defn- add-context
35 [context-tree context]
36 (let [parent (registered-parent context-tree context)]
37 (assoc context-tree parent (cons context (context-tree parent))
38 context nil)))
40 (defn- inside?
41 ([x y context]
42 (inside? x y (:x context) (:y context)
43 (:width context) (:height context)))
44 ([px py x y w h]
45 (and (>= px x)
46 (>= py y)
47 (< px (+ x w))
48 (< py (+ y h)))))
50 (defn- under-cursor
51 "Returns a sequence of contexts under cursor."
52 ([context-tree x y]
53 (under-cursor context-tree x y nil))
54 ([context-tree x y context]
55 (some #(if (inside? x y %)
56 (conj (under-cursor context-tree x y %) %))
57 (context-tree context))))
59 (defn- remove-all [coll1 coll2 pred]
60 (filter #(not (some (partial pred %) coll2)) coll1))
62 (defn- translate-mouse-event
63 [event x y id]
64 (proxy [MouseEvent] [(.getComponent event)
65 id
66 (.getWhen event)
67 (.getModifiers event)
68 (- (.getX event) x)
69 (- (.getY event) y)
70 (.getClickCount event)
71 (.isPopupTrigger event)]
72 (getXOnScreen [] (.getXOnScreen event))
73 (getYOnScreen [] (.getYOnScreen event))))
75 (defn- dispatch-event [handlers context event]
76 ((handlers context) context event))
78 (defn- translate-and-dispatch
79 ([contexts handlers event]
80 (translate-and-dispatch contexts handlers event (.getID event)))
81 ([contexts handlers event id]
82 (doseq [context contexts]
83 (dispatch-event
84 handlers
85 context
86 (translate-mouse-event event (:x context) (:y context) id)))))
88 (defn- dispatch-mouse-motion*
89 "Dispatches mouse motion events. Returns a new set of contexts which
90 currently are under cursor."
91 [hovered context-tree handlers event]
92 (let [x (.getX event)
93 y (.getY event)
94 hovered2 (under-cursor context-tree x y)
95 pred #(= (:layer %1) (:layer %2))
96 exited (remove-all hovered hovered2 pred)
97 entered (remove-all hovered2 hovered pred)
98 moved (remove-all hovered2 entered pred)]
99 (translate-and-dispatch
100 exited handlers event MouseEvent/MOUSE_EXITED)
101 (translate-and-dispatch
102 entered handlers event MouseEvent/MOUSE_ENTERED)
103 (translate-and-dispatch
104 moved handlers event MouseEvent/MOUSE_MOVED)
105 hovered2))
107 (defn- dispatch-mouse-motion
108 [hovered-ref context-tree handlers event]
109 (dosync
110 (alter hovered-ref dispatch-mouse-motion* context-tree handlers event)))
112 (defn- dispatch-mouse-button*
113 "Dispatches mouse button events. Returns a new set of contexts which
114 currently are picked with a pressed button."
115 [picked hovered handlers event]
116 (translate-and-dispatch hovered handlers event)
117 (if (= (.getID event) MouseEvent/MOUSE_PRESSED)
118 hovered
119 nil))
121 (defn- dispatch-mouse-button
122 [picked-ref hovered-ref handlers event]
123 (dosync
124 (alter picked-ref dispatch-mouse-button*
125 @hovered-ref handlers event)))
127 (defn make-event-dispatcher []
128 (let [context-tree-r (ref {}) ; register
129 handlers-r (ref {}) ;
130 context-tree (ref {}) ; dispatch
131 handlers (ref {}) ;
132 hovered (ref '())
133 picked (ref '())]
134 (reify
135 EventDispatcher
136 (listen! [this component]
137 (doto component
138 (.addMouseListener this)
139 (.addMouseMotionListener this)))
140 (register-mouse-handler [this context handler]
141 (dosync (alter context-tree-r add-context context)
142 (alter handlers-r assoc context handler)))
143 (commit [this]
144 (dosync (ref-set context-tree @context-tree-r)
145 (ref-set context-tree-r {})
146 (ref-set handlers @handlers-r)
147 (ref-set handlers-r {})))
148 (picked? [this layer] false)
149 (hovered? [this layer] false)
150 MouseListener
151 (mouseEntered [this event]
152 (dispatch-mouse-motion hovered context-tree handlers event))
153 (mouseExited [this event]
154 (dispatch-mouse-motion hovered context-tree handlers event))
155 (mouseClicked [this event]
156 (dispatch-mouse-button picked hovered handlers event))
157 (mousePressed [this event]
158 (dispatch-mouse-button picked hovered handlers event))
159 (mouseReleased [this event]
160 (dispatch-mouse-button picked hovered handlers event))
161 MouseMotionListener
162 (mouseDragged [this event]
163 (translate-and-dispatch @picked handlers event))
164 (mouseMoved [this event]
165 (dispatch-mouse-motion hovered context-tree handlers event)))))