Mercurial > hg > indyvon
view src/indyvon/event.clj @ 14:0a2fafca72d8
Border layer decorator.
Font render context.
Manual identation for reify and proxy.
| author | Mikhail Kryshen <mikhail@kryshen.net> |
|---|---|
| date | Tue, 15 Jun 2010 04:35:57 +0400 |
| parents | cd8a378414d1 |
| children | 43f0d78057a9 |
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 [] (.getXOnScreen event))
75 (getYOnScreen [] (.getYOnScreen event))))
77 (defn- translate-and-dispatch
78 ([contexts event]
79 (translate-and-dispatch contexts event (.getID event)))
80 ([contexts event id]
81 (doseq [c contexts]
82 (handle-layer-event
83 (:layer c)
84 c
85 (translate-mouse-event event (:x c) (:y c) id)))))
87 (defn- dispatch-mouse-motion*
88 "Dispatches mouse motion events. Returns a new set of contexts which
89 currently are under cursor."
90 [hovered context-tree event]
91 (let [x (.getX event)
92 y (.getY event)
93 hovered2 (under-cursor context-tree x y)
94 pred #(= (:layer %1) (:layer %2))
95 exited (remove-all hovered hovered2 pred)
96 entered (remove-all hovered2 hovered pred)
97 moved (remove-all hovered2 entered pred)]
98 (translate-and-dispatch exited event MouseEvent/MOUSE_EXITED)
99 (translate-and-dispatch entered event MouseEvent/MOUSE_ENTERED)
100 (translate-and-dispatch moved event MouseEvent/MOUSE_MOVED)
101 hovered2))
103 (defn- dispatch-mouse-motion
104 [hovered-ref context-tree event]
105 (dosync
106 (alter hovered-ref dispatch-mouse-motion* context-tree event)))
108 (defn- dispatch-mouse-button*
109 "Dispatches mouse button events. Returns a new set of contexts which
110 currently are picked with a pressed button."
111 [picked hovered context-tree event]
112 (translate-and-dispatch hovered event)
113 (if (= (.getID event) MouseEvent/MOUSE_PRESSED)
114 hovered
115 nil))
117 (defn- dispatch-mouse-button
118 [picked-ref hovered-ref context-tree event]
119 (dosync
120 (alter picked-ref dispatch-mouse-button*
121 @hovered-ref context-tree event)))
123 (defn make-event-dispatcher []
124 (let [context-tree-r (ref {}) ; register
125 context-tree (ref {}) ; dispatch
126 hovered (ref '())
127 picked (ref '())]
128 (reify
129 EventDispatcher
130 (listen! [this component]
131 (doto component
132 (.addMouseListener this)
133 (.addMouseMotionListener this)))
134 (register [this context]
135 (dosync (alter context-tree-r add-context context)))
136 (commit [this]
137 (dosync (ref-set context-tree @context-tree-r)
138 (ref-set context-tree-r {})))
139 (picked? [this layer] false)
140 (hovered? [this layer] false)
141 MouseListener
142 (mouseEntered [this event]
143 (dispatch-mouse-motion hovered context-tree event))
144 (mouseExited [this event]
145 (dispatch-mouse-motion hovered context-tree event))
146 (mouseClicked [this event]
147 (dispatch-mouse-button picked hovered context-tree event))
148 (mousePressed [this event]
149 (dispatch-mouse-button picked hovered context-tree event))
150 (mouseReleased [this event]
151 (dispatch-mouse-button picked hovered context-tree event))
152 MouseMotionListener
153 (mouseDragged [this event]
154 (translate-and-dispatch @picked event))
155 (mouseMoved [this event]
156 (dispatch-mouse-motion hovered context-tree event)))))