Mercurial > hg > indyvon
view src/indyvon/event.clj @ 12:cd8a378414d1
Support mouse button events.
| author | Mikhail Kryshen <mikhail@kryshen.net> |
|---|---|
| date | Mon, 14 Jun 2010 05:04:03 +0400 |
| parents | 9af27ccccfac |
| children | 0a2fafca72d8 |
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)))
11 (defmulti handle-layer-event
12 (fn [layer context event]
13 [layer (.getID event)]))
15 (defmethod handle-layer-event :default [layer context event])
17 (defprotocol EventDispatcher
18 (listen! [this component])
19 (register [this context])
20 (commit [this])
21 (hovered? [this layer])
22 (picked? [this layer]))
24 (defn register-context [context]
25 (register (:dispatcher context) context))
27 (defn- registered-parent
28 "Returns first context parent registered for event processing."
29 [context-tree context]
30 (let [parent (:parent context)]
31 (cond
32 (nil? parent) nil
33 (contains? context-tree parent) parent
34 :default (recur context-tree parent))))
36 (defn- add-context
37 [context-tree context]
38 (let [parent (registered-parent context-tree context)]
39 (assoc context-tree parent (conj (context-tree parent) context)
40 context nil)))
42 (defn- inside?
43 ([x y context]
44 (inside? x y (:x context) (:y context)
45 (:width context) (:height context)))
46 ([px py x y w h]
47 (and (>= px x)
48 (>= py y)
49 (< px (+ x w))
50 (< py (+ y h)))))
52 (defn- under-cursor
53 "Returns a sequence of contexts under cursor."
54 ([context-tree x y]
55 (under-cursor context-tree x y nil))
56 ([context-tree x y context]
57 (some #(if (inside? x y %)
58 (conj (under-cursor context-tree x y %) %))
59 (context-tree context))))
61 (defn- remove-all [coll1 coll2 pred]
62 (filter #(not (some (partial pred %) coll2)) coll1))
64 (defn- translate-mouse-event
65 [event x y id]
66 (proxy [MouseEvent] [(.getComponent event)
67 id
68 (.getWhen event)
69 (.getModifiers event)
70 (- (.getX event) x)
71 (- (.getY event) y)
72 (.getClickCount event)
73 (.isPopupTrigger event)]
74 (getXOnScreen []
75 (.getXOnScreen event))
76 (getYOnScreen []
77 (.getYOnScreen event))))
79 (defn- translate-and-dispatch
80 ([contexts event]
81 (translate-and-dispatch contexts event (.getID event)))
82 ([contexts event id]
83 (doseq [c contexts]
84 (handle-layer-event
85 (:layer c)
86 c
87 (translate-mouse-event event (:x c) (:y c) id)))))
89 (defn- dispatch-mouse-motion*
90 "Dispatches mouse motion events. Returns a new set of contexts which
91 currently are under cursor."
92 [hovered context-tree event]
93 (let [x (.getX event)
94 y (.getY event)
95 hovered2 (under-cursor context-tree x y)
96 pred #(= (:layer %1) (:layer %2))
97 exited (remove-all hovered hovered2 pred)
98 entered (remove-all hovered2 hovered pred)
99 moved (remove-all hovered2 entered pred)]
100 (translate-and-dispatch exited event MouseEvent/MOUSE_EXITED)
101 (translate-and-dispatch entered event MouseEvent/MOUSE_ENTERED)
102 (translate-and-dispatch moved event MouseEvent/MOUSE_MOVED)
103 hovered2))
105 (defn- dispatch-mouse-motion
106 [hovered-ref context-tree event]
107 (dosync
108 (alter hovered-ref dispatch-mouse-motion* context-tree event)))
110 (defn- dispatch-mouse-button*
111 "Dispatches mouse button events. Returns a new set of contexts which
112 currently are picked with a pressed button."
113 [picked hovered context-tree event]
114 (translate-and-dispatch hovered event)
115 (if (= (.getID event) MouseEvent/MOUSE_PRESSED)
116 hovered
117 nil))
119 (defn- dispatch-mouse-button
120 [picked-ref hovered-ref context-tree event]
121 (dosync
122 (alter picked-ref dispatch-mouse-button*
123 @hovered-ref context-tree event)))
125 (defn make-event-dispatcher []
126 (let [context-tree-r (ref {}) ; register
127 context-tree (ref {}) ; dispatch
128 hovered (ref '())
129 picked (ref '())]
130 (reify
131 EventDispatcher
132 (listen! [this component]
133 (doto component
134 (.addMouseListener this)
135 (.addMouseMotionListener this)))
136 (register [this context]
137 (dosync (alter context-tree-r add-context context)))
138 (commit [this]
139 (dosync (ref-set context-tree @context-tree-r)
140 (ref-set context-tree-r {})))
141 (picked? [this layer] false)
142 (hovered? [this layer] false)
143 MouseListener
144 (mouseEntered [this event]
145 (dispatch-mouse-motion hovered context-tree event))
146 (mouseExited [this event]
147 (dispatch-mouse-motion hovered context-tree event))
148 (mouseClicked [this event]
149 (dispatch-mouse-button picked hovered context-tree event))
150 (mousePressed [this event]
151 (dispatch-mouse-button picked hovered context-tree event))
152 (mouseReleased [this event]
153 (dispatch-mouse-button picked hovered context-tree event))
154 MouseMotionListener
155 (mouseDragged [this event]
156 (translate-and-dispatch @picked event))
157 (mouseMoved [this event]
158 (dispatch-mouse-motion hovered context-tree event)))))