Mercurial > hg > indyvon

view src/indyvon/core.clj @ 7:f6d10a68b01d

find changesets by author, revision, files, or words in the commit message
Find layer contexts under mouse cursor.
author Mikhail Kryshen <mikhail@kryshen.net>
date Fri, 11 Jun 2010 22:58:23 +0400
parents 5a858158cd9e
children c53ec3052ae7
line source
1 (ns indyvon.core
2 (:import (java.awt Dimension Point Component Graphics2D AWTEvent)
3 (java.awt.event MouseAdapter MouseMotionAdapter
4 MouseListener MouseMotionListener)))
5
6 (defprotocol Layer
7 (render! [this context graphics])
8 (size [this context])
9 (anchor [this context]))
10
11 (defrecord LayerContext [layer parent x y width height update-fn dispatcher])
12
13 (defn default-context []
14 (LayerContext. nil nil 0 0 0 0 nil nil))
15
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)))
28
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))))
34
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 :x (+ (:x context) x)
57 :y (+ (:y context) y)
58 :width w
59 :height h)
60 graphics)
61 (finally
62 (.dispose graphics))))))
63
64 ;;
65 ;; Event handling
66 ;;
67
68 (defmulti handle-layer-event
69 (fn [layer context event]
70 [layer (.getID event)]))
71
72 (defmethod handle-layer-event :default [layer context event])
73
74 (defprotocol EventDispatcher
75 (register [this context])
76 (commit [this])
77 (hovered? [this layer])
78 (picked? [this layer]))
79
80 (defn- assoc-conj [vmap key val]
81 "Add val to the sequence associated with key in vmap."
82 (assoc vmap key (conj (get vmap key) val)))
83
84 (defn- registered-parent
85 "Returns first context parent registered for event processing."
86 [context-tree context]
87 (let [parent (:parent context)]
88 (cond
89 (nil? parent) nil
90 (contains? context-tree parent) parent
91 :default (recur context-tree parent))))
92
93 (defn- inside?
94 ([x y context]
95 (inside? x y (:x context) (:y context)
96 (:width context) (:height context)))
97 ([px py x y w h]
98 (and (>= px x)
99 (>= py y)
100 (< px (+ x w))
101 (< py (+ y h)))))
102
103 (defn- under-cursor
104 "Returns a sequence of contexts under cursor."
105 ([context-tree x y]
106 (under-cursor context-tree x y nil))
107 ([context-tree x y context]
108 (some #(if (inside? x y %)
109 (conj (under-cursor context-tree x y %) %))
110 (context-tree context))))
111
112 (defn make-event-dispatcher []
113 (let [context-tree-r (ref {}) ; register
114 context-tree (ref {}) ; dispatch
115 hovered (ref [])
116 picked (ref [])]
117 (reify
118 EventDispatcher
119 (register [this context]
120 (dosync
121 (alter context-tree-r assoc-conj
122 (registered-parent 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 (mouseExited [this event])
132 (mousePressed [this event])
133 (mouseReleased [this event])
134 MouseMotionListener
135 (mouseDragged [this event])
136 (mouseMoved [this event]))))
137
138 ;;
139 ;; Connection to AWT.
140 ;;
141
142 (defn- make-update-fn [component]
143 (fn [] (.repaint component)))
144
145 (defn make-component
146 ([layer]
147 (make-component layer (make-event-dispatcher)))
148 ([layer event-dispatcher]
149 (doto
150 (proxy [Component] []
151 (update [g] (.paint this g))
152 (paint [g]
153 (let [size (.getSize this)
154 width (.width size)
155 height (.height size)
156 context (assoc (default-context)
157 :update-fn (make-update-fn this))]
158 (render-layer! context layer g 0 0 width height false)))
159 (getPreferredSize []
160 (let [s (size layer nil)] ;; TODO: supply context
161 (Dimension. (s 0) (s 1))))
162 (processEvent [event]))
163 ;; No way to call protected final evenbleEvents even in gen-class,
164 ;; have to use the following hack:
165 (.addMouseListener (proxy [MouseAdapter] []))
166 (.addMouseMotionListener (proxy [MouseMotionAdapter] [])))))
167
168 (comment
169 (do
170 (def frame (java.awt.Frame. "Test"))
171 (def layer
172 (reify-layer
173 (render! [this]
174 (.fillRect *graphics* 10 10 40 40))
175 (size [this] [100 100])))
176 (doto frame
177 (.addWindowListener
178 (proxy [java.awt.event.WindowAdapter] []
179 (windowClosing [event] (.dispose frame))))
180 (.add (make-component layer))
181 (.pack)
182 (.setVisible true))
183 )
184 )