view src/indyvon/core.clj @ 6:5a858158cd9e

Tree structure for event dispatching.
author Mikhail Kryshen <mikhail@kryshen.net>
date Fri, 11 Jun 2010 04:31:27 +0400
parents 74f1f265c3d9
children f6d10a68b01d
line source
1 (ns indyvon.core
2 (:import (java.awt Dimension Point Component Graphics2D AWTEvent)
3 (java.awt.event MouseAdapter MouseMotionAdapter
4 MouseListener MouseMotionListener)))
6 (defprotocol Layer
7 (render! [this context graphics])
8 (size [this context])
9 (anchor [this context]))
11 (defrecord LayerContext [layer parent rx ry width height update-fn dispatcher])
13 (defn default-context []
14 (LayerContext. nil nil 0 0 0 0 nil nil))
16 (defmacro reify-layer [& fns]
17 (let [method-map {'size [['_ '_] [0 0]]
18 'anchor [['_ '_] [0 0]]}
19 method-map (loop [fns fns
20 mm method-map]
21 (if-let [form (first fns)]
22 (recur (next fns)
23 (conj mm [(first form) (next form)]))
24 mm))
25 methods (for [m method-map]
26 (cons (first m) (second m)))]
27 `(reify Layer ~@methods)))
29 (defn- make-graphics [g x y w h clip]
30 (if clip
31 (.create g x y w h)
32 (doto (.create g)
33 (.translate x y))))
35 (defn render-layer!
36 "Render layer in a new graphics context."
37 ([context layer graphics]
38 (render-layer! context layer graphics
39 0 0 (:width context) (:height context)))
40 ([context layer graphics x y]
41 (render-layer! context layer graphics x y true))
42 ([context layer graphics x y clip]
43 (let [s (size layer context)]
44 (render-layer! context layer graphics
45 x y (.width s) (.height s) clip)))
46 ([context layer graphics x y w h]
47 (render-layer! context layer graphics
48 x y w h true))
49 ([context layer graphics x y w h clip]
50 (let [graphics (make-graphics graphics x y w h clip)]
51 (try
52 (render! layer
53 (assoc context
54 :layer layer
55 :parent context
56 :rx (+ (:rx context) x)
57 :ry (+ (:ry context) y)
58 :width w
59 :height h)
60 graphics)
61 (finally
62 (.dispose graphics))))))
64 ;;
65 ;; Event handling
66 ;;
68 (defmulti handle-layer-event
69 (fn [layer context event]
70 [layer (.getID event)]))
72 (defmethod handle-layer-event :default [layer context event])
74 (defprotocol EventDispatcher
75 (register [this context])
76 (commit [this]))
78 (defn- assoc-conj [vmap key val]
79 "Add val to the sequence associated with key in vmap."
80 (assoc vmap key (conj (get vmap key) val)))
82 (defn- registered-parent
83 "Returns first context parent registered for event processing."
84 [context-tree context]
85 (let [parent (:parent context)]
86 (cond
87 (nil? parent) nil
88 (contains? context-tree parent) parent
89 :default (recur context-tree parent))))
91 (defn make-event-dispatcher []
92 (let [context-tree-r (ref {}) ; register
93 context-tree (ref {}) ; dispatch
94 hovered (ref [])
95 picked (ref [])]
96 (reify
97 EventDispatcher
98 (register [this context]
99 (dosync
100 (alter context-tree-r assoc-conj
101 (registered-parent context) context)))
102 (commit [this]
103 (dosync (ref-set context-tree @context-tree-r)
104 (ref-set context-tree-r {}))))))
106 ;; (defn make-event-dispatcher []
107 ;; (let [contexts-r (ref []) ; register
108 ;; contexts (ref []) ; dispatch
109 ;; hovered (ref [])
110 ;; picked (ref [])]
111 ;; (reify
112 ;; EventDispatcher
113 ;; (register [this layer]
114 ;; (dosync
115 ;; (alter contexts-r conj
116 ;; (LayerContext. layer *rx* *ry*
117 ;; *width* *height*
118 ;; *update-fn*))))
119 ;; (commit [this]
120 ;; (dosync (ref-set contexts @contexts-r)
121 ;; (ref-set contexts-r [])))
122 ;; (dispatch [this event]
123 ;; (println "dispatch" this event)
124 ;; ;; TODO
125 ;; )
126 ;; MouseListener
127 ;; (mouseClicked [this event])
128 ;; (mouseEntered [this event])
129 ;; (mouseExited [this event])
130 ;; (mousePressed [this event])
131 ;; (mouseReleased [this event])
132 ;; MouseMotionListener
133 ;; (mouseDragged [this event])
134 ;; (mouseMoved [this event]))))
136 ;;
137 ;; Connection to AWT.
138 ;;
140 (defn- make-update-fn [component]
141 (fn [] (.repaint component)))
143 ;; (defn make-component [layer]
144 ;; (proxy [Component] []
145 ;; (update [g] (.paint this g))
146 ;; (paint [g]
147 ;; (let [insets (.getInsets this)
148 ;; top (.top insets)
149 ;; left (.left insets)
150 ;; bottom (.bottom insets)
151 ;; right (.right insets)
152 ;; size (.getSize this)
153 ;; width (- (.width size) left right)
154 ;; height (- (.height size) top bottom)]
155 ;; (binding [*graphics* g
156 ;; *update-fn* (make-update-fn this)]
157 ;; (render-layer! layer top left width height false))))
158 ;; (getPreferredSize []
159 ;; (size layer))))
161 (defn make-component
162 ([layer]
163 (make-component layer (make-event-dispatcher)))
164 ([layer event-dispatcher]
165 (doto
166 (proxy [Component] []
167 (update [g] (.paint this g))
168 (paint [g]
169 (let [size (.getSize this)
170 width (.width size)
171 height (.height size)
172 context (assoc (default-context)
173 :update-fn (make-update-fn this))]
174 (render-layer! context layer g 0 0 width height false)))
175 (getPreferredSize []
176 (let [s (size layer nil)] ;; TODO: supply context
177 (Dimension. (s 0) (s 1))))
178 (processEvent [event]))
179 ;; No way to call protected final evenbleEvents even in gen-class,
180 ;; have to use the following hack:
181 (.addMouseListener (proxy [MouseAdapter] []))
182 (.addMouseMotionListener (proxy [MouseMotionAdapter] [])))))
184 (comment
185 (do
186 (def frame (java.awt.Frame. "Test"))
187 (def layer
188 (reify-layer
189 (render! [this]
190 (.fillRect *graphics* 10 10 40 40))
191 (size [this] [100 100])))
192 (doto frame
193 (.addWindowListener
194 (proxy [java.awt.event.WindowAdapter] []
195 (windowClosing [event] (.dispose frame))))
196 (.add (make-component layer))
197 (.pack)
198 (.setVisible true))
199 )