Mercurial > hg > indyvon

view src/indyvon/event.clj @ 22:dc81033d4122

find changesets by author, revision, files, or words in the commit message
Layers should satisfy MouseHandler protocol to recieve mouse events.
author Mikhail Kryshen <mikhail@kryshen.net>
date Sat, 19 Jun 2010 06:50:24 +0400
parents a70609bad3a4
children
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 java.lang.ref.WeakReference))
11
12 (defn- registered-parent
13 "Returns first context parent registered for event processing."
14 [context-tree context]
15 (let [parent (:parent context)]
16 (cond
17 (nil? parent) nil
18 (contains? context-tree parent) parent
19 :default (recur context-tree parent))))
20
21 (defn- add-context
22 [context-tree context]
23 (let [parent (registered-parent context-tree context)]
24 (assoc context-tree parent (cons context (context-tree parent))
25 context nil)))
26
27 (defn- inside?
28 ([x y context]
29 (inside? x y (:x context) (:y context)
30 (:width context) (:height context)))
31 ([px py x y w h]
32 (and (>= px x)
33 (>= py y)
34 (< px (+ x w))
35 (< py (+ y h)))))
36
37 (defn- under-cursor
38 "Returns a sequence of contexts under cursor."
39 ([context-tree x y]
40 (under-cursor context-tree x y nil))
41 ([context-tree x y context]
42 (some #(if (inside? x y %)
43 (conj (under-cursor context-tree x y %) %))
44 (context-tree context))))
45
46 (defn- remove-all [coll1 coll2 pred]
47 (filter #(not (some (partial pred %) coll2)) coll1))
48
49 (defn- translate-mouse-event
50 [event x y id]
51 (proxy [MouseEvent] [(.getComponent event)
52 id
53 (.getWhen event)
54 (.getModifiers event)
55 (- (.getX event) x)
56 (- (.getY event) y)
57 (.getClickCount event)
58 (.isPopupTrigger event)]
59 (getXOnScreen [] (.getXOnScreen event))
60 (getYOnScreen [] (.getYOnScreen event))))
61
62 (defn- translate-and-dispatch
63 ([contexts event]
64 (translate-and-dispatch contexts event (.getID event)))
65 ([contexts event id]
66 (doseq [context contexts]
67 (handle-mouse
68 (:layer context) context
69 (translate-mouse-event event (:x context) (:y context) id)))))
70
71 (defn- dispatch-mouse-motion*
72 "Dispatches mouse motion events. Returns a new set of contexts which
73 currently are under cursor."
74 [hovered context-tree event]
75 (let [x (.getX event)
76 y (.getY event)
77 hovered2 (under-cursor context-tree x y)
78 pred #(= (:layer %1) (:layer %2))
79 exited (remove-all hovered hovered2 pred)
80 entered (remove-all hovered2 hovered pred)
81 moved (remove-all hovered2 entered pred)]
82 (translate-and-dispatch exited event MouseEvent/MOUSE_EXITED)
83 (translate-and-dispatch entered event MouseEvent/MOUSE_ENTERED)
84 (translate-and-dispatch moved event MouseEvent/MOUSE_MOVED)
85 hovered2))
86
87 (defn- dispatch-mouse-motion
88 [hovered-ref context-tree event]
89 (dosync
90 (alter hovered-ref dispatch-mouse-motion* context-tree event)))
91
92 (defn- dispatch-mouse-button*
93 "Dispatches mouse button events. Returns a new set of contexts which
94 currently are picked with a pressed button."
95 [picked hovered event]
96 (translate-and-dispatch hovered event)
97 (if (= (.getID event) MouseEvent/MOUSE_PRESSED)
98 hovered
99 nil))
100
101 (defn- dispatch-mouse-button
102 [picked-ref hovered-ref event]
103 (dosync
104 (alter picked-ref dispatch-mouse-button* @hovered-ref event)))
105
106 (defn make-event-dispatcher []
107 (let [context-tree-r (ref {}) ; register
108 context-tree (ref {}) ; dispatch
109 hovered (ref '())
110 picked (ref '())]
111 (reify
112 EventDispatcher
113 (listen! [this component]
114 (doto component
115 (.addMouseListener this)
116 (.addMouseMotionListener this)))
117 (register [this context]
118 (when (satisfies? MouseHandler (:layer context))
119 (dosync (alter context-tree-r add-context context))))
120 (commit [this]
121 (dosync (ref-set context-tree @context-tree-r)
122 (ref-set context-tree-r {})))
123 (picked? [this layer] false)
124 (hovered? [this layer] false)
125 MouseListener
126 (mouseEntered [this event]
127 (dispatch-mouse-motion hovered @context-tree event))
128 (mouseExited [this event]
129 (dispatch-mouse-motion hovered @context-tree event))
130 (mouseClicked [this event]
131 (dispatch-mouse-button picked hovered event))
132 (mousePressed [this event]
133 (dispatch-mouse-button picked hovered event))
134 (mouseReleased [this event]
135 (dispatch-mouse-button picked hovered 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)))))