Mercurial > hg > indyvon
view src/net/kryshen/indyvon/core.clj @ 74:a823dd0c2736
LGPL3
| author | Mikhail Kryshen <mikhail@kryshen.net> |
|---|---|
| date | Mon, 30 Aug 2010 20:04:21 +0400 |
| parents | 0465aaf01664 |
| children | ddfde9cce39a |
line source
1 ;;
2 ;; Copyright 2010 Mikhail Kryshen <mikhail@kryshen.net>
3 ;;
4 ;; This file is part of Indyvon.
5 ;;
6 ;; Indyvon is free software: you can redistribute it and/or modify it
7 ;; under the terms of the GNU Lesser General Public License version 3
8 ;; only, as published by the Free Software Foundation.
9 ;;
10 ;; Indyvon is distributed in the hope that it will be useful, but
11 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
12 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13 ;; Lesser General Public License for more details.
14 ;;
15 ;; You should have received a copy of the GNU Lesser General Public
16 ;; License along with Indyvon. If not, see
17 ;; <http://www.gnu.org/licenses/>.
18 ;;
20 (ns net.kryshen.indyvon.core
21 (:import
22 (java.awt Graphics2D RenderingHints Component Color Font AWTEvent Shape)
23 (java.awt.geom AffineTransform Point2D$Double Rectangle2D$Double Area)
24 (java.awt.event MouseListener MouseMotionListener)
25 (java.awt.font FontRenderContext)))
27 ;;
28 ;; Layer context
29 ;;
31 (def ^Graphics2D *graphics*)
33 (def ^FontRenderContext *font-context*)
35 (def ^{:tag Component
36 :doc "Target AWT component, may be nil if drawing off-screen."}
37 *target*)
39 (def ^{:doc "Width of the rendering area."}
40 *width*)
42 (def ^{:doc "Height of the rendering area."}
43 *height*)
45 (def ^Shape *clip*)
47 (def *root*)
49 (def *event-dispatcher*)
51 (def ^{:tag AffineTransform
52 :doc "Initial transform associated with the graphics context."}
53 *initial-transform*)
55 (def ^{:tag AffineTransform
56 :doc "Inversion of the initial transform associated with
57 the graphics context."}
58 *inverse-initial-transform*)
60 (defrecord Theme [fore-color back-color alt-back-color border-color font])
62 ;; REMIND: use system colors, see java.awt.SystemColor.
63 (defn default-theme []
64 (Theme. Color/BLACK Color/WHITE Color/LIGHT_GRAY
65 Color/BLUE (Font. "Sans" Font/PLAIN 12)))
67 (def *theme* (default-theme))
69 (defrecord Location [x y])
70 (defrecord Size [width height])
71 (defrecord Bounds [x y width height])
73 ;;
74 ;; Core protocols and types
75 ;;
77 (defprotocol Layer
78 "Basic UI element."
79 (render! [this])
80 (layer-size [this]))
82 ;; TODO: modifiers
83 (defrecord MouseEvent [id when x y x-on-screen y-on-screen button])
85 (defprotocol EventDispatcher
86 (listen! [this ^Component component]
87 "Listen for events on the specified AWT Component.")
88 (create-dispatcher [this handle handlers]
89 "Returns new event dispatcher associated with the specified event
90 handlers (an event-id -> handler-fn map). Handle is used to
91 match the contexts between commits.")
92 (commit [this]
93 "Apply the registered handlers for event processing."))
95 (defprotocol Anchored
96 "Provide anchor point for Layers. Used by viewport."
97 (anchor [this h-align v-align]
98 "Anchor point: [x y], h-align could be :left, :center or :right,
99 v-align is :top, :center or :bottom"))
101 (defn default-anchor [layer h-align v-align]
102 (if (and (= h-align :left)
103 (= v-align :top))
104 (Location. 0 0)
105 (let [size (layer-size layer)]
106 (Location.
107 (case h-align
108 :top 0
109 :center (/ (:width size) 2)
110 :right (:width size))
111 (case v-align
112 :left 0
113 :center (/ (:height size) 2)
114 :bottom (:height size))))))
116 ;; Default implementation of Anchored for any Layer.
117 (extend-protocol Anchored
118 net.kryshen.indyvon.core.Layer
119 (anchor [this h-align v-align]
120 (default-anchor this h-align v-align)))
122 (defn- assoc-cons [m key val]
123 (->> (get m key) (cons val) (assoc m key)))
125 (defn- assoc-in-cons [m keys val]
126 (->> (get-in m keys) (cons val) (assoc-in m keys)))
128 ;;
129 ;; Observers
130 ;;
132 (def observers (atom nil))
134 ;; TODO: groups should be weakly referenced.
135 (defn add-observer
136 "Add observer fn for the target to the specified group."
137 [group target f]
138 (swap! observers assoc-in-cons [group target] f)
139 nil)
141 (defn remove-observer-group
142 "Remove group of observers."
143 [group]
144 (swap! observers dissoc group)
145 nil)
147 (defn- replace-observer-group*
148 [observers old-id new-id]
149 (let [group (get observers old-id)]
150 (assoc (dissoc observers old-id)
151 new-id group)))
153 (defn- replace-observer-group
154 [old-id new-id]
155 (swap! observers replace-observer-group* old-id new-id))
157 (defn update
158 "Notify observers."
159 [target & args]
160 (doseq [f (reduce #(concat %1 (get %2 target)) nil (vals @observers))]
161 (apply f target args)))
163 (defn add-context-observer
164 "Observer registered with this function will be automatically
165 removed after the next frame rendering is complete."
166 [target f]
167 (let [root *root*]
168 (add-observer root target f)))
170 (defn repaint-on-update
171 "Trigger repaint of the current scene when the target updates."
172 [target]
173 (let [root *root*]
174 (if (not= root target)
175 (add-observer root target (fn [_] (update root))))))
177 (defn repaint
178 "Repaint the current scene."
179 []
180 (update *root*))
182 ;;
183 ;; Rendering
184 ;;
186 (defn- relative-transform
187 "AffineTransform: layer context -> awt component."
188 []
189 (let [tr (.getTransform *graphics*)]
190 (.preConcatenate tr *inverse-initial-transform*)
191 tr))
193 (defn- inverse-relative-transform
194 "AffineTransform: awt component -> layer context."
195 []
196 (let [tr (.getTransform *graphics*)]
197 (.invert tr) ; absolute -> layer
198 (.concatenate tr *initial-transform*) ; component -> absolute
199 tr))
201 (defn- clip
202 "Intersect clipping area with the specified shape or bounds.
203 Returns new clip (Shape or nil if empty)."
204 ([x y w h]
205 (clip (Rectangle2D$Double. x y w h)))
206 ([shape]
207 (let [a1 (Area. shape)
208 a2 (if (instance? Area *clip*) *clip* (Area. *clip*))]
209 (.transform a1 (relative-transform))
210 (.intersect a1 a2)
211 (if (.isEmpty a1)
212 nil
213 a1))))
215 (defn- ^Graphics2D apply-theme
216 "Set graphics' color and font to match theme.
217 Modifies and returns the first argument."
218 ([]
219 (apply-theme *graphics* *theme*))
220 ([^Graphics2D graphics theme]
221 (doto graphics
222 (.setColor (:fore-color theme))
223 (.setFont (:font theme)))))
225 (defn- ^Graphics2D create-graphics
226 ([]
227 (create-graphics 0 0 *width* *height*))
228 ([x y w h]
229 (apply-theme (.create *graphics* x y w h) *theme*)))
231 (defn with-bounds*
232 [x y w h f & args]
233 (when-let [clip (clip x y w h)]
234 (let [graphics (create-graphics x y w h)]
235 (try
236 (binding [*width* w
237 *height* h
238 *clip* clip
239 *graphics* graphics]
240 (apply f args))
241 (finally
242 (.dispose graphics))))))
244 (defmacro with-bounds
245 [x y w h & body]
246 `(with-bounds* ~x ~y ~w ~h (fn [] ~@body)))
248 (defn with-handlers*
249 [handle handlers f & args]
250 (binding
251 [*event-dispatcher* (create-dispatcher
252 *event-dispatcher* handle handlers)]
253 (apply f args)))
255 (defmacro with-handlers
256 "specs => (:event-id name & handler-body)*
258 Execute form with the specified event handlers."
259 [handle form & specs]
260 `(with-handlers* ~handle
261 ~(reduce (fn [m spec]
262 (assoc m (first spec)
263 `(fn [~(second spec)]
264 ~@(nnext spec)))) {}
265 specs)
266 (fn [] ~form)))
268 (defmacro with-theme
269 [theme & body]
270 `(binding [*theme* (merge *theme* ~theme)]
271 ~@body))
273 (defmacro with-color
274 [color-or-keyword & body]
275 (let [color-form (if (keyword? color-or-keyword)
276 `(~color-or-keyword *theme*)
277 color-or-keyword)]
278 `(let [color# ~color-form
279 old-color# (.getColor *graphics*)]
280 (try
281 (.setColor *graphics* color#)
282 ~@body
283 (finally
284 (.setColor *graphics* old-color#))))))
286 ;; TODO: constructor for AffineTransform.
287 ;; (transform :scale 0.3 0.5
288 ;; :translate 5 10
289 ;; :rotate (/ Math/PI 2))
291 (defmacro with-transform [transform & body]
292 `(let [old-t# (.getTransform *graphics*)]
293 (try
294 (.transform *graphics* ~transform)
295 ~@body
296 (finally
297 (.setTransform *graphics* old-t#)))))
299 (defmacro with-rotate [theta ax ay & body]
300 `(let [transform# (AffineTransform/getRotateInstance ~theta ~ax ~ay)]
301 (with-transform transform# ~@body)))
303 (defn draw!
304 "Draws layer."
305 ([layer]
306 (let [graphics (create-graphics)]
307 (try
308 (binding [*graphics* graphics]
309 (render! layer))
310 (finally
311 (.dispose graphics)))))
312 ([layer x y]
313 (let [size (layer-size layer)]
314 (draw! layer x y (:width size) (:height size))))
315 ([layer x y width height]
316 (with-bounds* x y width height render! layer)))
318 (defn draw-anchored!
319 "Draws layer. Location is relative to the layer's anchor point for
320 the specified alignment."
321 ([layer h-align v-align x y]
322 (let [anchor (anchor layer h-align v-align)]
323 (draw! layer (- x (:x anchor)) (- y (:y anchor)))))
324 ([layer h-align v-align x y w h]
325 (let [anchor (anchor layer h-align v-align)]
326 (draw! layer (- x (:x anchor)) (- y (:y anchor)) w h))))
328 (defn draw-root!
329 "Draws the root layer."
330 ([layer graphics width height event-dispatcher]
331 (draw-root! layer graphics width height event-dispatcher nil))
332 ([layer ^Graphics2D graphics width height event-dispatcher target]
333 (binding [*root* layer
334 *target* target
335 *graphics* graphics
336 *font-context* (.getFontRenderContext graphics)
337 *initial-transform* (.getTransform graphics)
338 *inverse-initial-transform*
339 (-> graphics .getTransform .createInverse)
340 *event-dispatcher* event-dispatcher
341 *width* width
342 *height* height
343 *clip* (Rectangle2D$Double. 0 0 width height)]
344 ;; (.setRenderingHint graphics
345 ;; RenderingHints/KEY_INTERPOLATION
346 ;; RenderingHints/VALUE_INTERPOLATION_BILINEAR)
347 ;; (.setRenderingHint graphics
348 ;; RenderingHints/KEY_ALPHA_INTERPOLATION
349 ;; RenderingHints/VALUE_ALPHA_INTERPOLATION_QUALITY)
350 ;; (.setRenderingHint graphics
351 ;; RenderingHints/KEY_ANTIALIASING
352 ;; RenderingHints/VALUE_ANTIALIAS_ON)
353 (apply-theme)
354 (with-color (:back-color *theme*)
355 (.fillRect graphics 0 0 width height))
356 (let [tmp-group (Object.)]
357 ;; Keep current context observers until the rendering is complete.
358 ;; Some observers may be invoked twice if they appear in both
359 ;; groups until tmp-group is removed.
360 (replace-observer-group layer tmp-group)
361 (try
362 (render! layer)
363 (finally
364 (remove-observer-group tmp-group)
365 (commit event-dispatcher)))))))
367 (defn root-size
368 ([layer font-context]
369 (root-size layer font-context nil))
370 ([layer font-context target]
371 (binding [*root* layer
372 *target* target
373 *font-context* font-context]
374 (layer-size layer))))
376 ;;
377 ;; EventDispatcher implementation
378 ;;
380 (def awt-events
381 {java.awt.event.MouseEvent/MOUSE_CLICKED :mouse-clicked
382 java.awt.event.MouseEvent/MOUSE_DRAGGED :mouse-dragged
383 java.awt.event.MouseEvent/MOUSE_ENTERED :mouse-entered
384 java.awt.event.MouseEvent/MOUSE_EXITED :mouse-exited
385 java.awt.event.MouseEvent/MOUSE_MOVED :mouse-moved
386 java.awt.event.MouseEvent/MOUSE_PRESSED :mouse-pressed
387 java.awt.event.MouseEvent/MOUSE_RELEASED :mouse-released})
389 (def dummy-event-dispatcher
390 (reify
391 EventDispatcher
392 (listen! [this component])
393 (create-dispatcher [this handle handlers] this)
394 (commit [this])))
396 (defrecord DispatcherNode [handle handlers parent
397 ^Shape clip ^AffineTransform transform
398 bindings]
399 EventDispatcher
400 (listen! [this component]
401 (listen! parent component))
402 (create-dispatcher [this handle handlers]
403 (create-dispatcher parent handle handlers))
404 (commit [this]
405 (commit parent)))
407 (defn- make-node [handle handlers]
408 (DispatcherNode. handle handlers *event-dispatcher* *clip*
409 (inverse-relative-transform)
410 (get-thread-bindings)))
412 (defn- add-node [tree node]
413 (assoc-cons tree (:parent node) node))
415 (defn- under-cursor
416 "Returns a vector of child nodes under cursor."
417 [x y tree node]
418 (some #(if (.contains ^Shape (:clip %) x y)
419 (conj (vec (under-cursor x y tree %)) %))
420 (get tree node)))
422 (defn- remove-all [coll1 coll2 pred]
423 (filter #(not (some (partial pred %) coll2)) coll1))
425 (defn- transform [^AffineTransform tr x y]
426 (let [p (Point2D$Double. x y)]
427 (.transform tr p p)
428 [(.x p) (.y p)]))
430 (defn- translate-mouse-event [^java.awt.event.MouseEvent event
431 ^AffineTransform tr id]
432 (let [[x y] (transform tr (.getX event) (.getY event))]
433 (MouseEvent. id (.getWhen event) x y
434 (.getXOnScreen event) (.getYOnScreen event)
435 (.getButton event))))
437 (defn- translate-and-dispatch
438 ([nodes first-only ^java.awt.event.MouseEvent event]
439 (translate-and-dispatch nodes first-only
440 event (awt-events (.getID event))))
441 ([nodes first-only event id]
442 (if-let [node (first nodes)]
443 (if-let [handler (get (:handlers node) id)]
444 (do
445 (with-bindings* (:bindings node)
446 handler
447 (translate-mouse-event event (:transform node) id))
448 (if-not first-only
449 (recur (rest nodes) false event id)))
450 (recur (rest nodes) first-only event id)))))
452 (defn- dispatch-mouse-motion
453 "Dispatches mouse motion events."
454 [hovered-ref tree root ^java.awt.event.MouseEvent event]
455 (let [x (.getX event)
456 y (.getY event)
457 [hovered hovered2] (dosync
458 [@hovered-ref
459 (ref-set hovered-ref
460 (under-cursor x y tree root))])
461 pred #(= (:handle %1) (:handle %2))
462 exited (remove-all hovered hovered2 pred)
463 entered (remove-all hovered2 hovered pred)
464 moved (remove-all hovered2 entered pred)]
465 (translate-and-dispatch exited false event :mouse-exited)
466 (translate-and-dispatch entered false event :mouse-entered)
467 (translate-and-dispatch moved true event :mouse-moved)))
469 (defn- dispatch-mouse-button
470 [picked-ref hovered-ref ^java.awt.event.MouseEvent event]
471 (let [id (awt-events (.getID event))
472 hovered (if (= id :mouse-pressed)
473 (dosync (ref-set picked-ref @hovered-ref))
474 @hovered-ref)]
475 (translate-and-dispatch hovered true event id)))
477 (defn root-event-dispatcher []
478 (let [tree-r (ref {}) ; register
479 tree (ref {}) ; dispatch
480 hovered (ref '())
481 picked (ref '())]
482 (reify
483 EventDispatcher
484 (listen! [this component]
485 (doto component
486 (.addMouseListener this)
487 (.addMouseMotionListener this)))
488 (create-dispatcher [this handle handlers]
489 (let [node (make-node handle handlers)]
490 (dosync (alter tree-r add-node node))
491 node))
492 (commit [this]
493 (dosync (ref-set tree @tree-r)
494 (ref-set tree-r {})))
495 MouseListener
496 (mouseEntered [this event]
497 (dispatch-mouse-motion hovered @tree this event))
498 (mouseExited [this event]
499 (dispatch-mouse-motion hovered @tree this event))
500 (mouseClicked [this event]
501 (dispatch-mouse-button picked hovered event))
502 (mousePressed [this event]
503 (dispatch-mouse-button picked hovered event))
504 (mouseReleased [this event]
505 (translate-and-dispatch @picked true event))
506 ;;(dispatch-mouse-button picked hovered event))
507 MouseMotionListener
508 (mouseDragged [this event]
509 (translate-and-dispatch @picked true event))
510 (mouseMoved [this event]
511 (dispatch-mouse-motion hovered @tree this event)))))
513 ;;
514 ;; ИДЕИ:
515 ;;
516 ;; Контекст: биндинги или запись?
517 ;;
518 ;; Установка обработчиков (в контексте слоя):
519 ;;
520 ;; (listen
521 ;; (:mouse-entered e
522 ;; ...)
523 ;; (:mouse-exited e
524 ;; ...))
525 ;;
526 ;; Не надо IMGUI.
527 ;; Построение сцены путем декорирования слоев:
528 ;;
529 ;; (listener
530 ;; (:action e (println e))
531 ;; (:mouse-dragged e (println e))
532 ;; (theme :font "Helvetica-14"
533 ;; (vbox
534 ;; (button (text-layer "Button 1"))
535 ;; (button (text-layer "Button 2")))))
536 ;;