Mercurial > hg > indyvon

view src/indyvon/event.clj @ 10:9af27ccccfac

find changesets by author, revision, files, or words in the commit message
Separated namespaces.
author Mikhail Kryshen <mikhail@kryshen.net>
date Sun, 13 Jun 2010 04:57:14 +0400
parents
children cd8a378414d1
line source
1 ;;
2 ;; Copyright (C) 2010 Mikhail Kryshen <mikhail@kryshen.net>
3 ;;
4 ;; This file is part of Indyvon.
5 ;;
6
7 (ns indyvon.event
8 (:use indyvon.core)
9 (:import (java.awt.event MouseEvent MouseListener MouseMotionListener)))
10
11 (defmulti handle-layer-event
12 (fn [layer context event]
13 [layer (.getID event)]))
14
15 (defmethod handle-layer-event :default [layer context event])
16
17 (defprotocol EventDispatcher
18 (listen! [this component])
19 (register [this context])
20 (commit [this])
21 (hovered? [this layer])
22 (picked? [this layer]))
23
24 (defn register-context [context]
25 (register (:dispatcher context) context))
26
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))))
35
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)))
41
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)))))
51
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))))
60
61 (defn- remove-all [coll1 coll2 pred]
62 (filter #(not (some (partial pred %) coll2)) coll1))
63
64 (defn- translate-mouse-event
65 [#^MouseEvent 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))))
78
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)))))
88
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 #^MouseEvent 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))
104
105 (defn- dispatch-mouse-motion
106 [hovered-ref context-tree #^MouseEvent event]
107 (dosync
108 (alter hovered-ref dispatch-mouse-motion* context-tree event)))
109
110 (defn make-event-dispatcher []
111 (let [context-tree-r (ref {}) ; register
112 context-tree (ref {}) ; dispatch
113 hovered (ref '())
114 picked (ref '())]
115 (reify
116 EventDispatcher
117 (listen! [this component]
118 (doto component
119 (.addMouseListener this)
120 (.addMouseMotionListener this)))
121 (register [this context]
122 (dosync (alter context-tree-r add-context context)))
123 (commit [this]
124 (dosync (ref-set context-tree @context-tree-r)
125 (ref-set context-tree-r {})))
126 (picked? [this layer] false)
127 (hovered? [this layer] false)
128 MouseListener
129 (mouseClicked [this event])
130 (mouseEntered [this event]
131 (dispatch-mouse-motion hovered context-tree event))
132 (mouseExited [this event]
133 (dispatch-mouse-motion hovered context-tree event))
134 (mousePressed [this event])
135 (mouseReleased [this event])
136 MouseMotionListener
137 (mouseDragged [this event]
138 (translate-and-dispatch @picked event))
139 (mouseMoved [this event]
140 (dispatch-mouse-motion hovered context-tree event)))))
141