--- a/project.clj	Mon Apr 14 15:37:28 2014 +0400
+++ b/project.clj	Mon Apr 14 20:01:00 2014 +0400
@@ -4,6 +4,6 @@
   :license {:name "GNU LGPL version 3"
             :url "http://www.gnu.org/licenses/lgpl-3.0.html"}
   :warn-on-reflection true
-;  :main net.kryshen.indyvon.demo
+;  :main indyvon.demo
   :dependencies [[org.clojure/clojure "1.6.0"]
                  [com.google.guava/guava "16.0.1"]])

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/indyvon/async.clj	Mon Apr 14 20:01:00 2014 +0400
@@ -0,0 +1,178 @@
+;;
+;; Copyright 2010-2014 Mikhail Kryshen <mikhail@kryshen.net>
+;;
+;; This file is part of Indyvon.
+;;
+;; Indyvon is free software: you can redistribute it and/or modify it
+;; under the terms of the GNU Lesser General Public License version 3
+;; only, as published by the Free Software Foundation.
+;;
+;; Indyvon is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with Indyvon.  If not, see
+;; <http://www.gnu.org/licenses/>.
+;;
+
+(ns indyvon.async
+  "Asynchronous drawing."
+  (:use
+   indyvon.core)
+  (:import
+   java.awt.GraphicsConfiguration
+   (java.awt Image AlphaComposite Transparency)
+   (java.awt.image BufferedImage)
+   (java.util.concurrent ThreadFactory ThreadPoolExecutor
+                         ThreadPoolExecutor$DiscardOldestPolicy
+                         ArrayBlockingQueue TimeUnit)))
+
+(defrecord Buffer [id image readers state])
+;; Buffer states:
+;;   :front, readers > 0
+;;      being copied on screen
+;;   :back
+;;      being rendered to (offscreen)
+;;   :fresh
+;;      most recently updated
+;;   :free
+;;      not in use
+
+(defn- create-image [async-view ^GraphicsConfiguration device-conf]
+  ;; TODO: support different image types.
+  (.createCompatibleImage device-conf
+                          (:width async-view)
+                          (:height async-view)
+                          Transparency/TRANSLUCENT))
+
+(defn- create-buffer [async-view device-conf]
+  (Buffer. (Object.) (create-image async-view device-conf) 0 :free))
+
+(defn- find-buffer
+  "Find a buffer with the one of the specified states given
+   in the order of preference."
+  [buffers & states]
+  (some identity
+    (for [state states]
+      (some #(if (= (:state %) state) % nil) buffers))))
+
+(defn- replace-buffer [buffers buffer]
+  (conj (remove #(= (:id %) (:id buffer)) buffers)
+        buffer))
+
+(defn- take-buffer [al type]
+  (dosync
+   (let [buffers @(:buffers al)
+         b (case type
+             :front (find-buffer buffers :front :fresh :free)
+             :back (find-buffer buffers :free :fresh)
+             (throw (IllegalArgumentException.)))
+         readers (if (= type :front)
+                   (inc (:readers b))
+                   (:readers b))
+         b (assoc b
+             :state type
+             :readers readers)]
+     (alter (:buffers al) replace-buffer b)
+     b)))
+
+(defn- release-buffer [al buffer]
+  (dosync
+   (let [state (:state buffer)
+         readers (if (= state :front)
+                   (dec (:readers buffer))
+                   (:readers buffer))
+         fresh (delay (find-buffer @(:buffers al) :fresh))
+         state (cond
+                (pos? readers) :front
+                (= :back state) :fresh
+                @fresh :free
+                :default :fresh)]
+     (if (and (= state :fresh) @fresh)
+       ;; Change state of the prefiously fresh buffer to :free.
+       (alter (:buffers al)
+              replace-buffer (assoc @fresh
+                               :state :free)))
+     (alter (:buffers al)
+            replace-buffer (assoc buffer
+                             :state state
+                             :readers readers)))))
+
+(defmacro with-buffer
+  {:private true}
+  [al type [name] & body]
+  `(let [al# ~al
+         ~name (take-buffer al# ~type)]
+     (try
+       ~@body
+       (finally
+        (release-buffer al# ~name)))))
+
+(defn- draw-offscreen [async-view]
+  ;;(Thread/sleep 1000)
+  (with-buffer async-view :back [b]
+    (let [g (.createGraphics ^BufferedImage (:image b))]
+      ;; Clear the buffer.
+      (.setComposite g AlphaComposite/Clear)
+      (.fillRect g 0 0 (:width async-view) (:height async-view))
+      (.setComposite g AlphaComposite/Src)
+      (draw-scene! (:scene async-view)
+                   g
+                   (:width async-view)
+                   (:height async-view)))
+    (update async-view)))
+
+(defn- draw-offscreen-async [async-view]
+  (.execute ^ThreadPoolExecutor (:executor async-view)
+            #(draw-offscreen async-view)))
+
+(defrecord AsyncView [scene width height executor buffers]
+  View
+  (render! [view]
+    (repaint-on-update view)
+    (add-context-observer scene (fn [_ _] (draw-offscreen-async view)))
+    (when-not @buffers
+      ;; TODO: dynamic size, recreate buffers when size increases.
+      (let [device-conf (.getDeviceConfiguration *graphics*)
+            new-buffers (repeatedly 2
+                          (partial create-buffer view device-conf))]
+        (dosync
+         (ref-set buffers new-buffers)))
+      (draw-offscreen-async view))
+    (with-buffer view :front [b]
+      (.drawImage *graphics* ^Image (:image b) 0 0 nil)))
+  (geometry [view]
+    (->Size width height)))
+
+(defn- create-thread-factory [priority]
+  (reify
+   ThreadFactory
+   (newThread [_ runnable]
+     (let [thread (Thread. runnable)]
+       (when priority
+         (.setPriority thread priority))
+       (.setDaemon thread true)
+       thread))))
+
+(defn- create-executor [priority]
+  (doto (ThreadPoolExecutor.
+         (int 1) (int 1)
+         (long 0) TimeUnit/SECONDS
+         (ArrayBlockingQueue. 1)
+         (ThreadPoolExecutor$DiscardOldestPolicy.))
+    (.setThreadFactory (create-thread-factory priority))))
+
+(defn async-view 
+  "Creates a View that draws the content asynchronously using an
+   offscreen buffer."
+  ([width height content]
+     (async-view width height nil content))
+  ([width height priority content]
+     ;; TODO: use operational event dispatcher.
+     (->AsyncView (make-scene content)
+                  width
+                  height
+                  (create-executor priority)
+                  (ref nil))))

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/indyvon/component.clj	Mon Apr 14 20:01:00 2014 +0400
@@ -0,0 +1,69 @@
+;;
+;; Copyright 2010-2014 Mikhail Kryshen <mikhail@kryshen.net>
+;;
+;; This file is part of Indyvon.
+;;
+;; Indyvon is free software: you can redistribute it and/or modify it
+;; under the terms of the GNU Lesser General Public License version 3
+;; only, as published by the Free Software Foundation.
+;;
+;; Indyvon is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with Indyvon.  If not, see
+;; <http://www.gnu.org/licenses/>.
+;;
+
+(ns indyvon.component
+  "Integrating Indyvon into AWT and Swing components."
+  (:use
+   indyvon.core)
+  (:import
+   (java.awt Graphics Component Dimension Color)
+   (java.awt.geom Rectangle2D$Double)
+   (javax.swing JFrame JPanel JOptionPane)))
+
+(defn- paint-component [^Component c ^Graphics g scene]
+  (let [w (.getWidth c)
+        h (.getHeight c)]
+    (.setColor g (:back-color *theme*))
+    (.fillRect g 0 0 w h)
+    (draw-scene! scene g w h)))
+
+(defn- preferred-size [^Component c scene]
+  (let [geom (scene-geometry scene)]
+    (Dimension. (width geom) (height geom))))
+
+(defn ^JPanel make-jpanel
+  ([view]
+     (make-jpanel view (root-event-dispatcher)))
+  ([view event-dispatcher]
+     (let [panel (proxy [JPanel] [])
+           scene (make-scene
+                  view event-dispatcher panel
+                  (.getDesktopProperty (java.awt.Toolkit/getDefaultToolkit)
+                                       "awt.font.desktophints"))]
+       (update-proxy
+        panel
+        {"paintComponent" #(paint-component %1 %2 scene)
+         "getPreferredSize" #(preferred-size % scene)})
+       (.setBackground panel (:back-color *theme*))
+       (add-observer panel scene (fn [w _]
+                                   ;; Use the first observer argument
+                                   ;; instead of closing over panel to
+                                   ;; allow the panel and associated
+                                   ;; observer to be gc'd.
+                                   (.repaint ^Component w)))
+       (listen! event-dispatcher panel)
+       panel)))
+
+(defn ^JFrame make-jframe [^String title view]
+  (doto (JFrame. title)
+    (.. (getContentPane) (add (make-jpanel view)))
+    (.pack)))
+
+(defn message [m]
+  (JOptionPane/showMessageDialog (:component *scene*) m))

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/indyvon/core.clj	Mon Apr 14 20:01:00 2014 +0400
@@ -0,0 +1,881 @@
+;;
+;; Copyright 2010-2014 Mikhail Kryshen <mikhail@kryshen.net>
+;;
+;; This file is part of Indyvon.
+;;
+;; Indyvon is free software: you can redistribute it and/or modify it
+;; under the terms of the GNU Lesser General Public License version 3
+;; only, as published by the Free Software Foundation.
+;;
+;; Indyvon is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with Indyvon.  If not, see
+;; <http://www.gnu.org/licenses/>.
+;;
+
+(ns indyvon.core
+  (:import
+   (java.awt Graphics2D RenderingHints Component Color Font Shape
+             Rectangle Cursor EventQueue)
+   (java.awt.geom AffineTransform Point2D$Double Rectangle2D$Double Area)
+   (java.awt.event MouseListener MouseMotionListener
+                   MouseWheelListener MouseWheelEvent)
+   (java.awt.font FontRenderContext)
+   java.util.concurrent.ConcurrentMap
+   com.google.common.collect.MapMaker))
+
+;;
+;; View context
+;;
+
+(def ^:dynamic ^Graphics2D *graphics*)
+
+(def ^:dynamic ^FontRenderContext *font-context*
+  "FontRenderContext to use when Graphics2D is not available."
+  (FontRenderContext.
+   nil
+   RenderingHints/VALUE_TEXT_ANTIALIAS_DEFAULT
+   RenderingHints/VALUE_FRACTIONALMETRICS_DEFAULT))
+
+(def ^:dynamic *width*
+  "Width of the rendering area.")
+
+(def ^:dynamic *height*
+  "Height of the rendering area.")
+
+(def ^:dynamic ^Shape *clip*)
+
+(def ^:dynamic ^Shape *input-clip*
+  "Clipping area used for dispatching pointer events (intersected with
+  *clip*). If nil, *clip* will be used.")
+
+(def ^:dynamic *time*
+  "Timestamp of the current frame (in nanoseconds).")
+
+(def ^:dynamic *scene*
+  "Encloses state that should be retained between repaints.")
+
+(def ^:dynamic *states*
+  "Transient scene states, a map.")
+
+(def ^:dynamic *event-dispatcher*)
+
+(def ^:dynamic ^AffineTransform *initial-transform*
+  "Initial transform associated with the graphics context.")
+
+(def ^:dynamic ^AffineTransform *inverse-initial-transform*
+  "Inversion of the initial transform associated with the graphics
+  context.")
+
+(defrecord Theme [fore-color back-color alt-back-color border-color
+                  shadow-color font])
+
+;; REMIND: use system colors, see java.awt.SystemColor.
+(defn default-theme []
+  (Theme. Color/BLACK
+          Color/WHITE
+          (Color. 0xDD 0xDD 0xDD)
+          (Color. 0 0 0xCC)
+          (Color. 0x44 0x44 0x44)
+          (Font. "Sans" Font/PLAIN 12)))
+
+(def ^:dynamic *theme* (default-theme))
+
+;;
+;; Core protocols and types
+;;
+
+(defprotocol View
+  "Basic UI element."
+  (render! [view]
+    "Draws the view in the current *graphics* context.")
+  (geometry [view]
+    "Returns the preferred Geometry for the view."))
+
+(defprotocol Geometry
+  "Describes geometry of a View.  Prefer using the available
+  implementations (Size, FixedGeometry and NestedGeometry) over
+  extending this protocol directly as it is likely to be changed in
+  the future versions."
+  (width [geom] [geom height])
+  (height [geom] [geom width])
+  (anchor-x [geom h-align width]
+    "Returns the x coordinate of the anchor point for the specified
+     horizontal alignment and width, h-align could be :left, :center
+     or :right.")
+  (anchor-y [geom v-align height]
+    "Returns the y coordinate of the anchor point for the specified
+    vertical alignment and height, v-align could be :top, :center
+    or :bottom."))
+
+(defn- emit-align-xy [align size first center last]
+  `(case ~align
+         ~first 0
+         ~center (/ ~size 2)
+         ~last ~size))
+
+;; Define as macro to avoid unnecessary calculation of width or height.
+(defmacro align-x
+  ([align inner outer]
+     `(align-x ~align (- ~outer ~inner)))
+  ([align width]
+     (emit-align-xy align width :left :center :right)))
+
+(defmacro align-y
+  ([align inner outer]
+     `(align-y ~align (- ~outer ~inner)))
+  ([align height]
+     (emit-align-xy align height :top :center :bottom)))
+
+(defrecord Size [width height]
+  Geometry
+  (width  [_] width)
+  (width [_ _] width)
+  (height [_] height)
+  (height [_ _] height)
+  (anchor-x [_ h-align width]
+    (align-x h-align width))
+  (anchor-y [_ v-align height]
+    (align-y v-align height)))
+
+(defrecord FixedGeometry [ax ay width height]
+  Geometry
+  (width  [_] width)
+  (width [_ _] width)
+  (height [_] height)
+  (height [_ _] height)
+  (anchor-x [_ _ _] ax)
+  (anchor-y [_ _ _] ay))
+
+(defrecord NestedGeometry [geometry top left bottom right]
+  Geometry
+  (width  [_]
+    (+ left right (width geometry)))
+  (width [_ h]
+    (+ left right (width geometry (- h top bottom))))
+  (height [_]
+    (+ top bottom (height geometry)))
+  (height [_ w]
+    (+ top bottom (height geometry (- w left right))))
+  (anchor-x [_ h-align w]
+    (+ left (anchor-x geometry h-align (- w left right))))
+  (anchor-y [_ v-align h]
+    (+ top (anchor-y geometry v-align (- h top bottom)))))
+
+(defrecord ScaledGeometry [geometry sx sy]
+  Geometry
+  (width  [_]
+    (* sx (width geometry)))
+  (width [_ h]
+    (* sx (width geometry (/ h sy))))
+  (height [_]
+    (* sy (height geometry)))
+  (height [_ w]
+    (* sy (height geometry (/ w sx))))
+  (anchor-x [_ h-align w]
+    (* sx (anchor-x geometry h-align (/ w sx))))
+  (anchor-y [_ v-align h]
+    (* sy (anchor-y geometry v-align (/ h sy)))))
+
+;; (defn ^:private to-integer
+;;   ^long [align x]
+;;   (if (integer? x)
+;;     x
+;;     (let [x (double x)]
+;;       (Math/round
+;;        (case align
+;;          (:top :left) (Math/floor x)
+;;          :center x
+;;          (:bottom :right) (Math/ceil x))))))
+
+;; (defrecord IntegerGeometry [geometry]
+;;   Geometry
+;;   (width [_]
+;;     (to-integer :right (width geometry)))
+;;   (width [_ h]
+;;     (to-integer :right (width geometry h)))
+;;   (height [_]
+;;     (to-integer :bottom (height geometry)))
+;;   (height [_ w]
+;;     (to-integer :bottom (height geometry w)))
+;;   (anchor-x [_ h-align w]
+;;     (to-integer h-align (anchor-x geometry h-align w)))
+;;   (anchor-y [_ v-align h]
+;;     (to-integer v-align (anchor-y geometry v-align h))))
+
+;; TODO: modifiers
+(defrecord MouseEvent [id when x y x-on-screen y-on-screen button
+                       wheel-rotation transform component])
+
+;; TODO: KeyEvent
+
+(defprotocol EventDispatcher
+  (listen! [this component]
+     "Listen for events on the specified AWT Component.")
+  (create-dispatcher [this handle handlers]
+     "Returns new event dispatcher associated with the specified event
+      handlers (an event-id -> handler-fn map). Handle is used to
+      match the contexts between commits.")
+  (commit [this]
+     "Apply the registered handlers for event processing.")
+  (handle-picked? [this handle]
+     "Returns true if the specified handle received the :mouse-pressed
+      event and have not yet received :moused-released.")
+  (handle-hovered? [this handle]
+     "Returns true if the specified handle received the :mouse-entered
+      event and have not yet received :mouse-exited."))
+
+(defn- assoc-cons [m key val]
+  (->> (get m key) (cons val) (assoc m key)))
+
+;;
+;; Observers
+;; The mechanism used by views to request repaints
+;;
+
+(def ^ConcurrentMap observers
+     (-> (MapMaker.) (.weakKeys) (.makeMap)))
+
+(defn- cm-replace!
+  "Wrap ConcurrentMap replace method to treat nil value as absent
+   mapping. Use with maps that does not support nil values."
+  [^ConcurrentMap cmap key old new]
+  (if (nil? old)
+    (nil? (.putIfAbsent cmap key new))
+    (.replace cmap key old new)))
+
+(defn- cm-swap!
+  "Atomically swaps the value associated with key in ConcurrentMap
+   to be (apply f current-value args). Returns the new value."
+  [^ConcurrentMap cmap key f & args]
+  (loop []
+    (let [old (.get cmap key)
+          new (apply f old args)]
+      (if (cm-replace! cmap key old new)
+        new
+        (recur)))))
+
+(defn add-observer
+  "Add observer fn for the target. Watcher identifies the group of
+  observers and could be used to remove the group. Watcher is weakly
+  referenced, all associated observers will be removed when the
+  wathcer is removed by gc. The observer fn will be called with
+  watcher and target arguments and any additional arguments specified
+  in update call."
+  [watcher target f]
+  (cm-swap! observers watcher assoc-cons target f)
+  nil)
+
+(defn remove-observers
+  "Remove group of observers associated with the specified watcher."
+  [watcher]
+  (.remove observers watcher)
+  nil)
+
+(defn- replace-observers-watcher
+  [old-watcher new-watcher]
+  (if-let [old (.remove observers old-watcher)]
+    (.put observers new-watcher old))
+  nil)
+
+(defn update
+  "Notify observers."
+  [target & args]
+  (doseq [entry observers
+          f (get (val entry) target)]
+    (apply f (key entry) target args)))
+
+(defn add-context-observer
+  "Observer registered with this function will be automatically
+  removed after the next repaint is complete."
+  [target f]
+  (add-observer *scene* target f))
+
+(defn repaint-on-update
+  "Trigger repaint of the current scene when the target updates."
+  [target]
+  (let [scene *scene*]
+    (if-not (identical? scene target)
+      (add-observer scene target (fn [w _] (update w))))))
+
+(defn repaint
+  "Requests repaint of the current scene. If handle and state are
+  specified, the handle will be associated with the state in the
+  *states* map for the next paint iteration."
+  ([]
+     (update *scene*))
+  ([handle state]
+     (let [scene *scene*]
+       (swap! (:next-state scene) assoc handle state)
+       (update scene))))
+
+;;
+;; Rendering
+;;
+
+(defn ^FontRenderContext font-context
+  "Returns FontRenderContext for the current view context."
+  []
+  (if (bound? (var *graphics*))
+    (.getFontRenderContext *graphics*)
+    *font-context*))
+
+(defn ^AffineTransform relative-transform
+  "Returns AffineTransform: view context -> AWT component."
+  []
+  (let [tr (.getTransform *graphics*)]
+    (.preConcatenate tr *inverse-initial-transform*)
+    tr))
+
+(defn ^AffineTransform inverse-relative-transform
+  "Returns AffineTransform: AWT component -> view context."
+  []
+  (let [tr (.getTransform *graphics*)]
+    (.invert tr)                          ; absolute -> view
+    (.concatenate tr *initial-transform*) ; component -> absolute
+    tr))
+
+(defn transform-point [^AffineTransform tr ^double x ^double y]
+  (let [p (Point2D$Double. x y)]
+    (.transform tr p p)
+    [(.x p) (.y p)]))
+
+(defn inverse-transform-point [^AffineTransform tr ^double x ^double y]
+  (let [p (Point2D$Double. x y)]
+    (.inverseTransform tr p p)
+    [(.x p) (.y p)]))
+
+;; (defn- clip
+;;   "Intersect clipping area with the specified shape or bounds.
+;;    Returns new clip (Shape or nil if empty)."
+;;   ([x y w h]
+;;      (clip (Rectangle2D$Double. x y w h)))
+;;   ([shape]
+;;      (let [a1 (Area. shape)
+;;            a2 (if (instance? Area *clip*) *clip* (Area. *clip*))]
+;;        (.transform a1 (relative-transform))
+;;        (.intersect a1 a2)
+;;        (if (.isEmpty a1)
+;;          nil
+;;          a1))))
+
+;; Use faster clipping calculation provided by Graphics2D.
+(defn- clip
+  "Intersect clipping area with the specified Shape in current
+   transform coordinates. Returns new clip in the AWT component
+   coordinates (Shape or nil if empty)."
+  [^Shape shape]
+  (let [^Graphics2D clip-g (.create *graphics*)]
+    (try
+      (doto clip-g
+        (.setClip shape)
+        (.setTransform *initial-transform*)
+        (.clip *clip*))
+      (if (.isEmpty (.getClipBounds clip-g))
+        nil
+        (.getClip clip-g))
+      (finally
+       (.dispose clip-g)))))
+
+(defn- ^Graphics2D apply-theme
+  "Set graphics' color and font to match theme.
+   Modifies and returns the first argument."
+  ([]
+     (apply-theme *graphics* *theme*))
+  ([^Graphics2D graphics theme]
+     (doto graphics
+       (.setColor (:fore-color theme))
+       (.setFont (:font theme)))))
+
+(defn- ^Graphics2D create-graphics
+  ([]
+     (apply-theme (.create *graphics*) *theme*))
+  ([^long x ^long y ^long w ^long h]
+     (apply-theme (.create *graphics* x y w h) *theme*)))
+
+(defn- with-bounds-noclip*
+  [x y w h f & args]
+  (let [graphics (create-graphics)]
+    (try
+      (.translate graphics (double x) (double y))
+      (binding [*width* w
+                *height* h
+                *input-clip* (Rectangle2D$Double. 0.0 0.0 w h)
+                *graphics* graphics]
+        (apply f args))
+      (finally
+       (.dispose graphics)))))
+
+(defn with-bounds*
+  [x y w h f & args]
+  (let [x (double x)
+        y (double y)
+        bounds (Rectangle2D$Double. x y w h)]
+    (when-let [clip (clip bounds)]
+      (let [^Graphics2D graphics (create-graphics)]
+        (try
+          (.clip graphics bounds)
+          (.translate graphics x y)
+          (binding [*width* w
+                    *height* h
+                    *clip* clip
+                    *input-clip* nil
+                    *graphics* graphics]
+            (apply f args))
+          (finally
+           (.dispose graphics)))))))
+
+(defmacro with-bounds
+  [x y w h & body]
+  `(with-bounds* ~x ~y ~w ~h (fn [] ~@body)))
+
+(defmacro with-theme
+  [theme & body]
+  `(binding [*theme* (merge *theme* ~theme)]
+     ~@body))
+
+(defmacro with-color [color-or-key & body]
+  `(let [color# ~color-or-key
+         color# (get *theme* color# color#)
+         g# *graphics*
+         old-color# (.getColor g#)]
+     (try
+       (.setColor g# color#)
+       ~@body
+       (finally
+         (.setColor g# old-color#)))))
+
+(defmacro with-stroke [stroke & body]
+  `(let [g# *graphics*
+         old-stroke# (.getStroke g#)]
+     (try
+       (.setStroke g# ~stroke)
+       ~@body
+       (finally
+        (.setStroke g# old-stroke#)))))
+
+(defmacro with-hints
+  [hints & body]
+  `(let [h# ~hints
+         g# *graphics*
+         old# (.getRenderingHints g#)]
+     (try
+       (.addRenderingHints g# h#)
+       ~@body
+       (finally
+        (.setRenderingHints g# old#)))))
+
+(defn with-hints* [hints f & args]
+  (with-hints hints
+    (apply f args)))
+
+;; TODO: constructor for AffineTransform.
+;; (transform :scale 0.3 0.5
+;;            :translate 5 10
+;;            :rotate (/ Math/PI 2))
+
+(defmacro with-transform [transform & body]
+  `(let [g# *graphics*
+         old-t# (.getTransform g#)]
+     (try
+       (.transform g# ~transform)
+       ~@body
+       (finally
+        (.setTransform g# old-t#)))))
+
+(defmacro with-rotate [theta ax ay & body]
+  `(let [transform# (AffineTransform/getRotateInstance ~theta ~ax ~ay)]
+     (with-transform transform# ~@body)))
+
+(defmacro with-translate [x y & body]
+  `(let [x# ~x
+         y# ~y
+         g# *graphics*]
+     (try
+       (.translate g# x# y#)
+       ~@body
+       (finally
+        (.translate g# (- x#) (- y#))))))
+
+(defn draw!
+  "Draws the View."
+  ([view]
+     (let [graphics (create-graphics)]
+       (try
+         (binding [*graphics* graphics]
+           (render! view))
+         (finally
+          (.dispose graphics)))))
+  ([x y view]
+     (draw! x y true view))
+  ([x y clip? view]
+     (let [geom (geometry view)]
+       (draw! x y (width geom) (height geom) clip? view)))
+  ([x y width height view]
+     (draw! x y width height true view))
+  ([x y width height clip? view]
+     (if clip?
+       (with-bounds* x y width height render! view)
+       (with-bounds-noclip* x y width height render! view))))
+
+(defn draw-aligned!
+  "Draws the View.  Location is relative to the view's anchor point
+   for the specified alignment."
+  ([h-align v-align x y view]
+     (let [geom (geometry view)
+           w (width geom)
+           h (height geom)]
+       (draw! (- x (anchor-x geom h-align w))
+              (- y (anchor-y geom v-align h))
+              w h
+              view)))
+  ([h-align v-align x y w h view]
+     (let [geom (geometry view)]
+       (draw! (- x (anchor-x geom h-align w))
+              (- y (anchor-y geom v-align h))
+              w h
+              view))))
+
+;;
+;; Event handling.
+;;
+
+(defn with-handlers*
+  [handle handlers f & args]
+  (binding [*event-dispatcher* (create-dispatcher
+                                *event-dispatcher* handle handlers)]
+    (apply f args)))
+
+(defmacro with-handlers
+  "specs => (:event-id name & handler-body)*
+
+  Execute form with the specified event handlers."
+  [handle form & specs]
+  `(with-handlers* ~handle
+     ~(reduce (fn [m spec]
+                (assoc m (first spec)
+                       `(fn [~(second spec)]
+                          ~@(nnext spec)))) {}
+                          specs)
+     (fn [] ~form)))
+
+(defn picked? [handle]
+  (handle-picked? *event-dispatcher* handle))
+
+(defn hovered? [handle]
+  (handle-hovered? *event-dispatcher* handle))
+
+;;
+;; EventDispatcher implementation
+;;
+
+(def awt-events
+     {java.awt.event.MouseEvent/MOUSE_CLICKED  :mouse-clicked
+      java.awt.event.MouseEvent/MOUSE_DRAGGED  :mouse-dragged
+      java.awt.event.MouseEvent/MOUSE_ENTERED  :mouse-entered
+      java.awt.event.MouseEvent/MOUSE_EXITED   :mouse-exited
+      java.awt.event.MouseEvent/MOUSE_MOVED    :mouse-moved
+      java.awt.event.MouseEvent/MOUSE_PRESSED  :mouse-pressed
+      java.awt.event.MouseEvent/MOUSE_RELEASED :mouse-released
+      java.awt.event.MouseEvent/MOUSE_WHEEL    :mouse-wheel})
+
+(def dummy-event-dispatcher
+  (reify EventDispatcher
+    (listen! [_ _])
+    (create-dispatcher [this _ _] this)
+    (commit [_])
+    (handle-picked? [_ _])
+    (handle-hovered? [_ _])))
+
+;; Not using defrecord to avoid unacceptable overhead of recursive
+;; hash code calculation.
+(deftype DispatcherNode [handle handlers parent
+                         ^Shape clip ^AffineTransform transform
+                         bindings]
+  EventDispatcher
+  (listen! [this component]
+    (listen! parent component))
+  (create-dispatcher [this handle handlers]
+    (create-dispatcher parent handle handlers))
+  (commit [this]
+    (commit parent))
+  (handle-picked? [this handle]
+    (handle-picked? parent handle))
+  (handle-hovered? [this handle]
+    (handle-hovered? parent handle)))
+
+(defn- make-node [handle handlers]
+  (let [clip (if *input-clip*
+               (clip *input-clip*)
+               *clip*)
+        bindings (-> (get-thread-bindings)
+                     (dissoc (var *graphics*))
+                     (assoc (var *font-context*) (font-context)))]
+    (DispatcherNode. handle handlers *event-dispatcher* clip
+                     (relative-transform)
+                     bindings)))
+
+(defn- add-node [tree ^DispatcherNode node]
+  (assoc-cons tree (.parent node) node))
+
+(defn- nodes [tree]
+  (apply concat (vals tree)))
+
+(defn- under-cursor
+  "Returns a vector of child nodes under cursor."
+  [node tree ^long x ^long y]
+  (some (fn [^DispatcherNode n]
+          (if (and (.clip n) (.contains ^Shape (.clip n) x y))
+            (conj (vec (under-cursor n tree x y)) n)))
+        (get tree node)))
+
+(defn- translate-mouse-event [^java.awt.event.MouseEvent event
+                              ^AffineTransform tr id]
+  (let [[x y] (inverse-transform-point tr (.getX event) (.getY event))
+        rotation (if (instance? MouseWheelEvent event)
+                   (.getWheelRotation ^MouseWheelEvent event)
+                   nil)]
+    (->MouseEvent id (.getWhen event) x y
+                  (.getXOnScreen event) (.getYOnScreen event)
+                  (.getButton event)
+                  rotation
+                  tr
+                  (.getComponent event))))
+
+(defn- translate-and-dispatch
+  ([nodes first-only ^java.awt.event.MouseEvent event]
+     (translate-and-dispatch nodes first-only
+                             event (awt-events (.getID event))))
+  ([nodes first-only event id]
+     (if-let [^DispatcherNode node (first nodes)]
+       (let [handlers (.handlers node)
+             handler (get handlers id)]
+         (if handler
+           (do
+             (with-bindings* (.bindings node)
+               handler
+               (translate-mouse-event event (.transform node) id))
+             (when-not first-only
+               (recur (rest nodes) false event id)))
+           (when-not (and (= id :mouse-dragged)
+                          (or (contains? handlers :mouse-pressed)
+                              (contains? handlers :mouse-released)))
+             (recur (rest nodes) first-only event id)))))))
+
+(defn- process-mouse-event
+  [dispatcher ^java.awt.event.MouseEvent source-event]
+  (let [{active-ref :active
+         hovered-ref :hovered
+         picked-ref :picked
+         last-ref :last-motion
+         tree-ref :tree} dispatcher
+         pressed (and source-event
+                      (== (.getID source-event)
+                          java.awt.event.MouseEvent/MOUSE_PRESSED))
+         released (and source-event
+                       (== (.getID source-event)
+                           java.awt.event.MouseEvent/MOUSE_RELEASED))
+         ^java.awt.event.MouseEvent last-event @last-ref
+         ^java.awt.event.MouseEvent event (or source-event last-event)]
+    (when event
+      (let [x (.getX event)
+            y (.getY event)
+            active @active-ref
+            active (if (and active
+                            source-event
+                            (== (.getX last-event) x)
+                            (== (.getY last-event) y))
+                     active
+                     (ref-set active-ref
+                              (under-cursor dispatcher @tree-ref x y)))
+            acted (cond
+                   pressed (ref-set picked-ref active)
+                   released (let [picked @picked-ref]
+                              (ref-set picked-ref nil)
+                              picked)
+                   :else active)
+            picked (seq @picked-ref)
+            pred #(= (.handle ^DispatcherNode %1) (.handle ^DispatcherNode %2))
+            hovered (if picked
+                      (filter #(some (partial pred %) picked) active)
+                      active)
+            remove-all (fn [c1 c2]
+                         (filter #(not (some (partial pred %) c2)) c1))
+            old-hovered @hovered-ref
+            exited (remove-all old-hovered hovered)
+            entered (remove-all hovered old-hovered)
+            moved (or picked (remove-all hovered entered))]
+        (ref-set hovered-ref hovered)
+        (ref-set last-ref event)
+        [exited entered moved acted event]))))
+
+(defn- dispatch-mouse-event
+  [dispatcher source-event button?]
+  (when-let [[exited
+              entered
+              moved
+              acted
+              event] (dosync (process-mouse-event dispatcher source-event))]
+    (when button?
+      (translate-and-dispatch acted true event))
+    (translate-and-dispatch exited false event :mouse-exited)
+    (translate-and-dispatch entered false event :mouse-entered)
+    (when-not button?
+      (translate-and-dispatch moved true source-event))))
+
+(defrecord RootEventDispatcher [tree-r  ;; register
+                                tree    ;; dispatch
+                                active  ;; nodes under cursor
+                                hovered ;; mouse entered
+                                picked  ;; mouse pressed
+                                last-motion]
+  EventDispatcher
+  (listen! [dispatcher component]
+    (doto ^Component component
+          (.addMouseListener dispatcher)
+          (.addMouseWheelListener dispatcher)
+          (.addMouseMotionListener dispatcher)))
+  (create-dispatcher [dispatcher handle handlers]
+    (let [node (make-node handle handlers)]
+      (dosync (alter tree-r add-node node))
+      node))
+  (commit [dispatcher]
+    (let [[exited
+           entered
+           _ _
+           event] (dosync
+                   ;; TODO: retain contexts that do
+                   ;; not intersect graphics
+                   ;; clipping area in tree.
+                   (ref-set tree @tree-r)
+                   (ref-set tree-r {})
+                   (process-mouse-event dispatcher nil))]
+      ;; Send mouse entered and exited events if necessary due to
+      ;; updated layout.
+      (translate-and-dispatch exited false event :mouse-exited)
+      (translate-and-dispatch entered false event :mouse-entered)))
+  (handle-picked? [dispatcher handle]
+    (some #(= handle (.handle ^DispatcherNode %)) @picked))
+  (handle-hovered? [dispatcher handle]
+    (some #(= handle (.handle ^DispatcherNode %)) @hovered))
+  MouseListener
+  (mouseEntered [dispatcher event]
+    (dispatch-mouse-event dispatcher event false))
+  (mouseExited [dispatcher event]
+    (dispatch-mouse-event dispatcher event false))
+  (mouseClicked [dispatcher event]
+    (dispatch-mouse-event dispatcher event true))
+  (mousePressed [dispatcher event]
+    (dispatch-mouse-event dispatcher event true))
+  (mouseReleased [dispatcher event]
+    (dispatch-mouse-event dispatcher event true))
+  MouseWheelListener
+  (mouseWheelMoved [dispatcher event]
+    (dispatch-mouse-event dispatcher event true))
+  MouseMotionListener
+  (mouseDragged [dispatcher event]
+    (dispatch-mouse-event dispatcher event false))
+  (mouseMoved [dispatcher event]
+    (dispatch-mouse-event dispatcher event false)))
+
+(defn root-event-dispatcher []
+  (->RootEventDispatcher
+   (ref {}) (ref {})             ;; trees
+   (ref nil) (ref nil) (ref nil) ;; node states
+   (ref nil)))                   ;; last event
+
+;;
+;; Scene
+;;
+
+(defrecord Scene [view
+                  event-dispatcher
+                  component
+                  rendering-hints
+                  next-state])
+
+;; Define rendering hints that affect font metrics to make sure that
+;; Graphics and Scene FontRenderContexts are consistent.
+(def ^:private default-rendering-hints
+  {RenderingHints/KEY_TEXT_ANTIALIASING
+   RenderingHints/VALUE_TEXT_ANTIALIAS_DEFAULT,
+   RenderingHints/KEY_FRACTIONALMETRICS
+   RenderingHints/VALUE_FRACTIONALMETRICS_DEFAULT})
+
+(defn make-scene
+  ([view]
+     (make-scene view dummy-event-dispatcher nil))
+  ([view event-dispatcher]
+     (make-scene view event-dispatcher nil))
+  ([view event-dispatcher ^Component component]
+     (make-scene view event-dispatcher component nil))
+  ([view event-dispatcher ^Component component hints]
+     (let [hints (merge default-rendering-hints hints)]
+       (->Scene view
+                event-dispatcher
+                component
+                hints
+                (atom nil)))))
+
+(defn- get-and-set!
+  "Atomically sets the value of atom to newval and returns the old
+  value."
+  [atom newval]
+  (loop [v @atom]
+    (if (compare-and-set! atom v newval)
+      v
+      (recur @atom))))
+
+(defn draw-scene!
+  [scene ^Graphics2D graphics width height]
+  (.addRenderingHints graphics (:rendering-hints scene))
+  (binding [*states* (get-and-set! (:next-state scene) nil)
+            *scene* scene
+            *graphics* graphics
+            *initial-transform* (.getTransform graphics)
+            *inverse-initial-transform* (-> graphics
+                                            .getTransform
+                                            .createInverse)
+            *event-dispatcher* (:event-dispatcher scene)
+            *width* width
+            *height* height
+            *clip* (Rectangle2D$Double. 0.0 0.0 width height)
+            *input-clip* nil
+            *time* (System/nanoTime)]
+    (apply-theme)
+    (let [tmp-watcher (Object.)]
+      ;; Keep current context observers until the rendering is
+      ;; complete. Some observers may be invoked twice if they
+      ;; appear in both groups until tmp-watcher is removed.
+      (replace-observers-watcher scene tmp-watcher)
+      (try
+        (render! (:view scene))
+        (finally
+         (remove-observers tmp-watcher)
+         (commit (:event-dispatcher scene)))))))
+
+(defn- scene-font-context [scene]
+  (let [hints (:rendering-hints scene)
+        ^Component c (:component scene)
+        t (if c (->> c
+                     .getFont
+                     (.getFontMetrics c)
+                     .getFontRenderContext
+                     .getTransform))]
+    (FontRenderContext.
+     t
+     (get hints RenderingHints/KEY_TEXT_ANTIALIASING)
+     (get hints RenderingHints/KEY_FRACTIONALMETRICS))))      
+
+(defn scene-geometry [scene]
+  (binding [*scene* scene
+            *font-context* (scene-font-context scene)]
+    (geometry (:view scene))))
+
+(defn set-cursor! [^Cursor cursor]
+  (when-let [^Component component (:component *scene*)]
+    (EventQueue/invokeLater #(.setCursor component cursor))))

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/indyvon/demo.clj	Mon Apr 14 20:01:00 2014 +0400
@@ -0,0 +1,223 @@
+;;
+;; Copyright 2010-2014 Mikhail Kryshen <mikhail@kryshen.net>
+;;
+;; This file is part of Indyvon.
+;;
+;; Indyvon is free software: you can redistribute it and/or modify it
+;; under the terms of the GNU Lesser General Public License version 3
+;; only, as published by the Free Software Foundation.
+;;
+;; Indyvon is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with Indyvon.  If not, see
+;; <http://www.gnu.org/licenses/>.
+;;
+
+(ns indyvon.demo
+  "Indyvon demo and experiments."
+  (:gen-class)
+  (:use
+   (indyvon core views viewport component))
+  (:import
+   (java.awt Color)
+   (javax.swing JFrame)))
+
+(defn draw-button!
+  "Draws a button immediately (but uses callback for the action unlike
+   IMGUI)."
+  [id content callback & args]
+  (with-handlers id
+    (let [shadow-offset 2
+          padding 4
+          border-width 1
+          offset (if (picked? id) (/ shadow-offset 2) 0)
+          ^Color color (:alt-back-color *theme*)
+          color (if (hovered? id) (.brighter color) color)
+          width (- *width* shadow-offset)
+          height (- *height* shadow-offset)]
+      (with-color (:shadow-color *theme*)
+        (.fillRect *graphics* shadow-offset shadow-offset width height))
+      (with-color color
+        (.fillRect *graphics* offset offset width height))
+      (draw! offset offset width height
+             (border border-width padding content)))
+    ;; Event handlers
+    (:mouse-entered _ (repaint))
+    (:mouse-exited _ (repaint))
+    (:mouse-pressed _ (repaint))
+    (:mouse-released _ (repaint))
+    (:mouse-clicked _ (apply callback args))))
+
+(defn combine-colors
+  "Returns color between color1 and color2. When c (0 <= c <= 1.0) is
+   closer to 0 the returned сolor is closer to color1."
+  [^Color color1 ^Color color2 c]
+  (case c
+    0.0 color1
+    1.0 color2
+    (let [rgb1 (.getRGBComponents color1 nil)
+          rgb2 (.getRGBComponents color2 nil)
+          rgb (float-array (map #(+ (* (- 1 c) %1) (* c %2)) rgb1 rgb2))]
+      (Color. (aget rgb 0) (aget rgb 1) (aget rgb 2) (aget rgb 3)))))
+
+(defn animate
+  "Changes the value of atom according to the specified range, speed,
+   and current frame interval.  Invokes repaint if change happens."
+  [atom from to speed]
+  (let [prev @atom
+        state (cond
+               (zero? speed) :stop
+               (= prev from) (if (pos? speed) :start :stop)               
+               (= prev to) (if (neg? speed) :start :stop)
+               :default :continue)]
+    (if (= state :stop)
+       prev
+       (let [interval (if (= state :start) 1 *interval*)
+             step (* speed interval 1E-9)
+             val (swap! atom #(-> % (+ step) (max from) (min to)))]
+         (repaint)
+         val))))
+
+(defn animated-button
+  "Creates an animated button."
+  [content callback & args]
+  (let [padding 4
+        border-width 1
+        shadow-offset 2
+        face (border padding border-width content)
+        highlight (atom 0)
+        animation-speed (atom 0)]
+    (interval-view
+     (reify
+      View
+      (render! [button]
+        (with-handlers button
+          (let [hovered (hovered? button)
+                offset (if (picked? button) (/ shadow-offset 2) 0)
+                color (combine-colors
+                       (:alt-back-color *theme*) Color/WHITE
+                       (animate highlight 0.0 1.0 @animation-speed))
+                width (- *width* shadow-offset)
+                height (- *height* shadow-offset)]
+            (with-color (:shadow-color *theme*)
+              (.fillRect *graphics*
+                         shadow-offset shadow-offset
+                         width height))
+            (with-color color
+              (.fillRect *graphics* offset offset width height))
+            (draw! offset offset width height
+                   (border border-width padding content)))
+          ;; Event handlers
+          (:mouse-entered _
+            (reset! animation-speed 4)
+            (repaint))
+          (:mouse-exited _
+            (reset! animation-speed -2)
+            (repaint))
+          (:mouse-pressed _ (repaint))
+          (:mouse-released _ (repaint))
+          (:mouse-clicked _ (apply callback args))))
+     (geometry [button]
+       (let [face-geom (geometry face)]
+         (->Size (+ (width face-geom) shadow-offset)
+                 (+ (height face-geom) shadow-offset))))))))
+
+(def button1 (animated-button (label "Animated button 1")
+                              println "Animated button 1 clicked"))
+
+(def button2 (animated-button (label "Animated button 2")
+                              println "Animated button 2 clicked"))
+
+(def test-view1
+  (reify
+   View
+   (render! [view]
+     (with-handlers view
+       (with-color (if (hovered? view) Color/ORANGE Color/RED)
+         (.fillRect *graphics* 0 0 *width* *height*))
+       (:mouse-entered e
+        (repaint)
+        (println e))
+       (:mouse-exited e
+        (repaint)
+        (println e))
+       (:mouse-moved e
+        (println e))))
+   (geometry [view]
+     (->Size 30 20))))
+
+(def test-view1b (border 2 3 test-view1))
+
+(def test-view2
+  (reify
+   View
+   (render! [view]
+     (doto *graphics*
+       (.setColor Color/YELLOW)
+       (.fillRect 0 0 *width* *height*))
+     (with-rotate 0.5 0 0
+       (draw! 30 25 test-view1b))
+     (draw! 55 5 test-view1))
+   (geometry [view]
+     (->Size 70 65))))
+
+(def test-view2m (miniature 30 30 test-view2))
+
+(def test-view3 (border (label :right :bottom "Sample\ntext")))
+
+(def root
+  (reify
+   View
+   (render! [view]
+     ;;(repaint)
+     (doto *graphics*
+       (.drawLine 0 0 *width* *height*)
+       (.drawLine *width* 0 0 *height*)
+       ;; Random color to see when repaint happens.
+       (.setColor (rand-nth [Color/BLACK Color/BLUE Color/RED]))
+       (.fillOval 5 5 20 20))
+     (draw! 30 20 test-view2)
+     (draw! 120 50 test-view2m)
+     (draw! 100 100 80 50 test-view3)
+     (draw! 50 160 button1)
+     (with-rotate (/ Math/PI 6) 250 200
+       (draw! 210 140 button1))
+     (draw! 100 200 button2)
+     (with-bounds 180 240 140 30
+       (draw-button! :button
+        (label :center :center "Immediate button")
+        #(println "Button clicked!"))))
+   (geometry [view]
+     (->Size 400 300))))
+
+;; Main viewport
+(def vp (viewport root))
+
+;; Miniature (rendered asynchronously)
+(def vp-miniature (->> vp (viewport-miniature 100 75) border shadow))
+
+;; Main scene
+(def scene
+  (fps-view
+   (decorate-view vp [_]
+     (draw! vp)
+     (draw-aligned!
+      :left :bottom 5 (- *height* 5)
+      (label (str "Drag mouse to pan," \newline
+                  "use mouse wheel to zoom.")))
+     (draw! (- *width* 105) 5 vp-miniature))))
+
+(defn show-frame [view]
+  (doto (make-jframe "Test" view)
+    (.setDefaultCloseOperation JFrame/DISPOSE_ON_CLOSE)
+    (.setVisible true)))
+
+(defn -main []
+  (show-frame scene))
+
+(comment
+  (show-frame (viewport-miniature 200 150 vp)))

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/indyvon/viewport.clj	Mon Apr 14 20:01:00 2014 +0400
@@ -0,0 +1,238 @@
+;;
+;; Copyright 2010-2014 Mikhail Kryshen <mikhail@kryshen.net>
+;;
+;; This file is part of Indyvon.
+;;
+;; Indyvon is free software: you can redistribute it and/or modify it
+;; under the terms of the GNU Lesser General Public License version 3
+;; only, as published by the Free Software Foundation.
+;;
+;; Indyvon is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with Indyvon.  If not, see
+;; <http://www.gnu.org/licenses/>.
+;;
+
+(ns indyvon.viewport
+  "Scrollable viewport and miniature."
+  (:use
+   (indyvon core async views))
+  (:import
+   java.awt.Cursor
+   java.awt.geom.AffineTransform))
+  
+;;(defn- translate [^AffineTransform transform ^double x ^double y]
+;;  (doto ^AffineTransform (.clone transform)
+;;        (.translate x y)))
+
+(defn- scale [^AffineTransform transform ^double sx ^double sy]
+    (doto ^AffineTransform (.clone transform)
+        (.scale sx sy)))
+
+(defn- pre-translate [^AffineTransform transform ^double x ^double y]
+  (if (== 0.0 x y)
+    transform
+    (doto (AffineTransform/getTranslateInstance x y)
+      (.concatenate transform))))
+
+(def ^:dynamic *viewport-scaling-step* (double 3/4))
+(def ^:dynamic *viewport-min-scale* 1E-6)
+(def ^:dynamic *viewport-max-scale* 1E6)
+
+(def ^:dynamic *viewport* nil)
+(def ^:dynamic ^AffineTransform *viewport-transform*)
+
+(declare scale-viewport!)
+
+(defrecord ViewportState [transform
+                          fix-x fix-y
+                          last-width last-height
+                          last-anchor-x last-anchor-y])
+
+(defn- update-viewport [state content-geom h-align v-align]
+  (let [w *width*
+        h *height*
+        cw (width content-geom)
+        ch (height content-geom)
+        ax (anchor-x content-geom h-align cw)
+        ay (anchor-y content-geom v-align ch)
+        ax1 (align-x h-align (:last-width state) w)
+        ay1 (align-y v-align (:last-height state) h)
+        ax2 (- (:last-anchor-x state) ax)
+        ay2 (- (:last-anchor-y state) ay)
+        transform (:transform state)
+        transform (if (and (zero? ax1) (zero? ay1)
+                           (zero? ax2) (zero? ay2))
+                    transform
+                    (doto
+                        (AffineTransform/getTranslateInstance ax1 ay1)
+                      (.concatenate transform)
+                      (.translate ax2 ay2)))]
+    (assoc state
+      :last-width w
+      :last-height h
+      :last-anchor-x ax
+      :last-anchor-y ay
+      :transform transform)))
+
+(defrecord Viewport [content h-align v-align state]
+  View
+  (render! [view]
+    (repaint-on-update view)
+    (with-handlers view
+      (let [geom (geometry content)
+            new-state (swap! state update-viewport geom h-align v-align)
+            transform (:transform new-state)]
+        ;; TODO: notify observers when size changes.
+        (binding [*viewport* view
+                  *viewport-transform* transform]
+          (with-transform transform
+            (draw! 0 0 (width geom) (height geom) false content))))
+      (:mouse-pressed e
+       (swap! state assoc
+              :fix-x (:x-on-screen e)
+              :fix-y (:y-on-screen e))
+       (set-cursor! (Cursor. Cursor/MOVE_CURSOR)))
+      (:mouse-released e
+       (set-cursor! (Cursor. Cursor/DEFAULT_CURSOR)))
+      (:mouse-dragged e
+       (swap! state
+              (fn [s]
+                (assoc s
+                  :transform (pre-translate
+                              (:transform s)
+                              (- (:x-on-screen e) (:fix-x s))
+                              (- (:y-on-screen e) (:fix-y s)))
+                  :fix-x (:x-on-screen e)
+                  :fix-y (:y-on-screen e))))
+       (update view))
+      (:mouse-wheel e
+       (scale-viewport!
+        view
+        (Math/pow *viewport-scaling-step* (:wheel-rotation e))
+        true (:x e) (:y e)))))
+  (geometry [_]
+    (geometry content)))
+
+(def ^:private viewport-initial-state
+  (->ViewportState
+   (AffineTransform.) ; transform
+   0 0                ; fix-x fix-y
+   0 0                ; last-width last-height
+   0 0))
+
+(defn viewport
+  "Creates scrollable viewport view."
+  ([content]
+     (viewport :left :top content))
+  ([h-align v-align content]
+     (->Viewport content h-align v-align (atom viewport-initial-state))))
+
+(defn- scale-viewport [state vp s relative? x y]
+  (let [^AffineTransform tr (:transform state)
+        sx (if relative? s (/ s (.getScaleX tr)))
+        sy (if relative? s (/ s (.getScaleY tr)))
+        x (or x (align-x (:h-align vp) (:last-width state)))
+        y (or y (align-y (:v-align vp) (:last-height state)))
+        x (- x (* x sx))
+        y (- y (* y sy))
+        scaled (doto (AffineTransform/getTranslateInstance x y)
+                 (.scale sx sy)
+                 (.concatenate tr))
+        sx (.getScaleX scaled)
+        sy (.getScaleY scaled)]
+    (if (<= *viewport-min-scale*
+            (min sx sy)
+            (max sx sy)
+            *viewport-max-scale*)
+      (assoc state
+        :transform scaled)
+      state)))
+
+(defn scale-viewport!
+  ([viewport s]
+     (scale-viewport! viewport s true))
+  ([viewport s relative?]
+     (scale-viewport! viewport s relative? nil nil))
+  ([viewport s relative? x y]
+     (swap! (:state viewport) scale-viewport viewport s relative? x y)
+     (update viewport)))
+
+(defn reset-viewport! [viewport]
+  (reset! (:state viewport) viewport-initial-state)
+  (update viewport))
+
+(defn ^AffineTransform viewport-transform [viewport]
+  (:transform @(:state viewport)))
+
+(defn- scaling
+  [width height max-width max-height]
+  (min (/ max-width width)
+       (/ max-height height)))
+
+(defn miniature
+  "Creates a view that asynchronously renders the content view scaled to
+  the specified size."
+  [mw mh content]
+  (async-view
+   mw mh *miniature-thread-priority*
+   (reify
+    View
+    (render! [this]
+      (let [geom (geometry content)
+            cw (width geom)
+            ch (height geom)
+            s (scaling cw ch mw mh)]
+        (.scale *graphics* s s)
+        (draw! (align-x :center cw (/ mw s))
+               (align-y :center ch (/ mh s))
+               cw ch
+               content)))
+    (geometry [_]
+      (->Size mw mh)))))
+
+(defn viewport-miniature
+  "Creates miniature view of the viewport's contents."
+  [m-width m-height viewport]
+  (let [miniature (miniature m-width m-height (:content viewport))]
+    (decorate-view miniature [l]
+      (repaint-on-update viewport)
+      (let [geom (geometry (:content viewport))
+            s (scaling (width geom) (height geom) m-width m-height)
+            vp-state @(:state viewport)
+            {:keys [transform last-width last-height]} @(:state viewport)
+            ox (align-x :center (width geom) (/ m-width s))
+            oy (align-y :center (height geom) (/ m-height s))
+            inverse (.createInverse ^AffineTransform transform)
+            transform (doto (AffineTransform.)
+                        (.scale s s)
+                        (.translate ox oy)
+                        (.concatenate inverse))
+            move-vp (fn [state x y]
+                      (let [x (- (/ x s) ox)
+                            y (- (/ y s) oy)
+                            tr (:transform state)
+                            [x y] (transform-point tr x y)
+                            x (- x (/ (:last-width state) 2))
+                            y (- y (/ (:last-height state) 2))]
+                        (assoc state
+                          :transform (pre-translate tr (- x) (- y)))))
+            move-vp! (fn [x y]
+                       (swap! (:state viewport) move-vp x y)
+                       (update viewport))]
+        (with-color :alt-back-color
+          (.fillRect *graphics* 0 0 *width* *height*))
+        (with-transform transform
+          (with-color :back-color
+            (.fillRect *graphics* 0 0 last-width last-height)))
+        (with-handlers l
+          (draw! miniature)
+          (:mouse-pressed e (move-vp! (:x e) (:y e)))
+          (:mouse-dragged e (move-vp! (:x e) (:y e))))
+        (with-transform transform
+          (with-color :border-color
+            (.drawRect *graphics* 0 0 last-width last-height)))))))

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/indyvon/views.clj	Mon Apr 14 20:01:00 2014 +0400
@@ -0,0 +1,410 @@
+;;
+;; Copyright 2010-2014 Mikhail Kryshen <mikhail@kryshen.net>
+;;
+;; This file is part of Indyvon.
+;;
+;; Indyvon is free software: you can redistribute it and/or modify it
+;; under the terms of the GNU Lesser General Public License version 3
+;; only, as published by the Free Software Foundation.
+;;
+;; Indyvon is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with Indyvon.  If not, see
+;; <http://www.gnu.org/licenses/>.
+;;
+
+(ns indyvon.views
+  "Implementations of the View protocol."
+  (:use
+   (indyvon core async))
+  (:import
+   (java.awt Font Image Toolkit)
+   java.awt.image.ImageObserver
+   (java.awt.geom Area AffineTransform Rectangle2D$Double Point2D
+                  Point2D$Double)
+   (java.awt.font FontRenderContext TextLayout)
+   java.util.concurrent.TimeUnit
+   (com.google.common.cache Cache CacheBuilder CacheLoader)))
+
+(defmacro decorate-view
+  "Decorate the view replacing render! implementation."
+  [view & render-tail]
+  `(let [view# ~view]
+     (reify
+       View
+       (render! ~@render-tail)
+       (geometry [t#] (geometry view#)))))
+
+(defrecord Empty []
+  View
+  (render! [_])
+  (geometry [_]
+    (->Size 0 0)))
+
+(def empty-view (->Empty))
+
+;; TODO: change argument order for decorators, content should be the
+;; last.
+
+(defn padding
+  "Adds padding to the content view."
+  ([distance content]
+     (padding distance distance distance distance content))
+  ([top left bottom right content]
+     (if (== 0 top left bottom right)
+       content
+       (reify
+        View
+        (render! [l]
+           (draw! left top
+                  (- *width* left right)
+                  (- *height* top bottom)
+                  false
+                  content))
+        (geometry [l]
+          (->NestedGeometry (geometry content) top left bottom right))))))
+
+(defn border
+  "Adds a border to the content view."
+  ([content]
+     (border 1 content))
+  ([thickness content]
+     (border thickness 0 content))
+  ([thickness gap content]
+     (let [view (padding (+ thickness gap) content)
+           t (double thickness)]
+       (decorate-view view [_]
+         (render! view)
+         (with-color :border-color
+           (let [w (double *width*)
+                 h (double *height*)
+                 outer (Area. (Rectangle2D$Double. 0.0 0.0 w h))
+                 inner (Area. (Rectangle2D$Double. t t (- w t t) (- h t t)))]
+             (.subtract outer inner)
+             (.fill *graphics* outer)))))))
+
+;; TODO: opacity and blur.
+(defn shadow
+  "Adds a shadow to the content view."
+  ([content]
+     (shadow 1 1 content))
+  ([x-offset y-offset content]
+     (let [x (if (neg? x-offset) (- x-offset) 0)
+           y (if (neg? y-offset) (- y-offset) 0)
+           abs-x (if (neg? x-offset) (- x-offset) x-offset)
+           abs-y (if (neg? y-offset) (- y-offset) y-offset)
+           shadow-x (+ x-offset x)
+           shadow-y (+ y-offset y)]
+       (reify
+        View
+        (render! [_]
+          (let [w (- *width* abs-x)
+                h (- *height* abs-y)]
+            (with-color :shadow-color
+              (.fillRect *graphics* shadow-x shadow-y w h))
+            (draw! x y w h content)))
+        (geometry [_]
+          (->NestedGeometry (geometry content)
+                            y x shadow-y shadow-x))))))
+
+(defn panel
+  "An opaque view using theme's alt-back-color or a custom background
+  color."
+  ([content]
+     (panel :alt-back-color content))
+  ([back-color content]
+     (decorate-view content [_]
+       (with-color back-color
+         (.fill *graphics* (Rectangle2D$Double. 0.0 0.0 *width* *height*)))
+       (render! content))))
+
+(defn hbox
+  "Creates a view that draws the specified content views placing them
+   horizontally."
+  [& contents]
+  (reify
+   View
+   (render! [_]
+     (let [widths (map #(width (geometry %)) contents)
+           xs (cons 0 (reductions + widths))
+           widths-sum (last xs)
+           scale (/ *width* widths-sum)]
+       (doseq [[c w x] (map vector contents widths xs)]
+         (draw! x 0 w *height* c))))
+   (geometry [_]
+     (reduce #(->Size (+ (width %1) (width %2))
+                      (max (height %1) (height %2)))
+             (->Size 0 0)
+             (map geometry contents)))))
+
+(defn vbox
+  "Creates a view that draws the specified content views placing them
+   vertically."
+  [& contents]
+  (reify
+   View
+   (render! [_]
+     (let [heights (map #(height (geometry %)) contents)
+           ys (cons 0 (reductions + heights))
+           heights-sum (last ys)
+           scale (/ *height* heights-sum)]
+       (doseq [[c h y] (map vector contents heights ys)]
+         (draw! 0 y *width* h c))))
+   (geometry [_]
+     (reduce #(->Size (max (width %1) (width %2))
+                      (+ (height %1) (height %2)))
+             (->Size 0 0)
+             (map geometry contents)))))
+
+(defn- re-split [^java.util.regex.Pattern re s]
+  (seq (.split re s)))
+
+(def ^:private ^Cache text-layout-cache
+  (-> (CacheBuilder/newBuilder)
+      (.softValues)
+      (.expireAfterAccess (long 1) TimeUnit/SECONDS)
+      (.build)))
+
+(defn- get-text-layout
+  [^String line ^Font font ^FontRenderContext font-context]
+  (.get text-layout-cache [line font font-context]
+        #(TextLayout. line font font-context)))
+
+(defn- layout-text
+  [lines font font-context]
+  (map #(get-text-layout % font font-context) lines))
+
+(defn- text-width [layouts]
+  (reduce (fn [w ^TextLayout tl] (max w (.getAdvance tl))) 0 layouts))
+
+(defn- text-height [layouts]
+  (reduce (fn [w ^TextLayout tl]
+            (+ w (.getAscent tl)
+               (.getDescent tl)
+               (.getLeading tl)))
+          0 layouts))
+
+(defn label
+  "Creates a view to display multiline text."
+  ([text]
+     (label :left :top text))
+  ([h-align v-align text]
+     (let [lines (re-split #"\r\n|\n|\r|\u0085|\u2028|\u2029" (str text))]
+       (reify View
+        (render! [view]
+          (let [w *width*
+                h *height*
+                font (.getFont *graphics*)
+                layouts (layout-text lines font (font-context))
+                y (align-y v-align (text-height layouts) h)]
+            (loop [layouts layouts, y y]
+              (when-first [^TextLayout layout layouts]
+                (let [ascent (.getAscent layout)
+                      lh (+ ascent (.getDescent layout) (.getLeading layout))
+                      x (align-x h-align (.getAdvance layout) w)]
+                  (.draw layout *graphics* x (+ y ascent))
+                  (recur (next layouts) (+ y lh)))))))
+        (geometry [view]
+          (let [layouts (layout-text lines (:font *theme*) (font-context))
+                w (text-width layouts)
+                h (text-height layouts)]
+            (->Size w h)))))))
+
+(defn- ^ImageObserver image-observer [view]
+  (reify
+   ImageObserver
+   (imageUpdate [this img infoflags x y width height]
+     (update view)
+     (zero? (bit-and infoflags
+                     (bit-or ImageObserver/ALLBITS
+                             ImageObserver/ABORT))))))
+
+(defn image-view
+  [image-or-uri]
+  (let [^Image image (if (instance? Image image-or-uri)
+                       image-or-uri
+                       (.getImage (Toolkit/getDefaultToolkit)
+                                  ^java.net.URL image-or-uri))]
+    (.prepareImage (Toolkit/getDefaultToolkit) image -1 -1 nil)
+    (reify
+     View
+     (render! [view]
+       (repaint-on-update view)
+       (.drawImage *graphics* image 0 0 (image-observer view)))
+     (geometry [view]
+       (let [observer (image-observer view)
+             width (.getWidth image observer)
+             height (.getHeight image observer)
+             width (if (pos? width) width 1)
+             height (if (pos? height) height 1)]
+         (->Size width height))))))
+
+(def ^:dynamic *miniature-thread-priority* 2)
+
+(defn ref-view
+  [view-ref]
+  (let [l (reify
+           View
+           (render! [l]
+             (repaint-on-update l)
+             (if-let [view @view-ref]
+               (render! view)))
+           (geometry [_]
+             (if-let [view @view-ref]
+               (geometry view)
+               (->Size 1 1))))]
+    (add-watch view-ref l (fn [_ _ _ _] (update l)))
+    l))
+
+;;
+;; View context decorators
+;;
+
+(defmacro handler [view & handlers]
+  "Adds event handling to the view."
+  `(let [view# ~view]
+     (decorate-view view# [t#]
+       (with-handlers t#
+         (render! view#)
+         ~@handlers))))
+
+(defn themed [view & map-or-keyvals]
+  (let [theme (if (== (count map-or-keyvals) 1)
+                (first map-or-keyvals)
+                (apply array-map map-or-keyvals))]
+    (reify
+     View
+     (render! [_]
+       (with-theme theme
+         (render! view)))
+     (geometry [_]
+       (with-theme theme
+         (geometry view))))))
+
+(defn hinted [view & map-or-keyvals]
+  (let [hints (if (== (count map-or-keyvals) 1)
+                (first map-or-keyvals)
+                (apply array-map map-or-keyvals))]
+    (decorate-view view [_]
+      (with-hints* hints render! view))))
+
+;;
+;; Measuring time
+;;
+
+(def ^:dynamic *interval*)
+
+(defn interval-view
+  "Creates a view that measures time between repaints ant draws it's
+  content with the *interval* var bound to the measured time."
+  [content]
+  (let [last-time (atom nil)]
+    (decorate-view content [_]
+      (compare-and-set! last-time nil *time*)
+      (let [lt @last-time]
+        (binding [*interval* (if (compare-and-set! last-time lt *time*)
+                               (- *time* lt)
+                               0)] ; already measured on parallel thread
+          (render! content))))))
+
+(defn- fps-label [text]
+  (padding 5 (label :right :bottom text)))
+
+(defn fps-view
+  "Creates a view that draws content and displays the
+  frames per second rate."
+  [content]
+  (let [update-interval 2E8 ; 0.2 s in nanoseconds
+        frames (ref 0)
+        prev-time (ref nil)
+        display (ref (fps-label "fps n/a"))]
+    (decorate-view content [_]
+      (draw! content)
+      (draw!
+       (dosync
+        (alter frames inc)
+        (if @prev-time
+          (let [elapsed (- *time* @prev-time)]
+            (when (> elapsed update-interval)
+              (let [fps (/ @frames (/ elapsed 1E9))]
+                (ref-set display (fps-label (format "%.1f" fps)))
+                (ref-set frames 0)
+                (ref-set prev-time *time*))))
+          (ref-set prev-time *time*))
+        @display)))))
+
+;;
+;; Overlays
+;;
+
+(def ^:private ^:dynamic *above*)
+
+(defn- overlay* [f & args]
+  (var-set #'*above* (conj *above* (apply partial f args))))
+
+(defn- ^Point2D to-graphics-coords
+  [^AffineTransform transform x y]
+  (let [p (Point2D$Double. x y)]
+    (.transform transform p p)
+    (.transform (.createInverse (.getTransform *graphics*)) p p)
+    p))
+
+(defn- draw-relative!
+  ([transform x y view]
+     (let [p (to-graphics-coords transform x y)]
+       (draw! (.getX p) (.getY p) view)))
+  ([transform x y w h view]
+     (let [p (to-graphics-coords transform x y)]
+       (draw! (.getX p) (.getY p) w h view))))
+
+(defn- draw-relative-aligned!
+  [transform h-align v-align x y view]
+  (let [geom (geometry view)
+        w (width geom)
+        h (height geom)
+        p (to-graphics-coords transform x y)
+        x (- (.getX p) (anchor-x geom h-align w))
+        y (- (.getY p) (anchor-y geom v-align h))]
+    (draw! x y w h view)))
+
+(defn overlay!
+  "Draws view in the overlay context above the other views."
+  ([view]
+     (overlay* draw-relative! (.getTransform *graphics*) 0 0 view))
+  ([x y view]
+     (overlay* draw-relative! (.getTransform *graphics*) x y view))
+  ([x y w h view]
+     (overlay* draw-relative! (.getTransform *graphics*) x y w h view)))
+
+(defn overlay-aligned! [h-align v-align x y view]
+  (overlay* draw-relative-aligned!
+            (.getTransform *graphics*)
+            h-align v-align x y
+            view))
+
+(defn with-overlays* [rec? f & args]
+  (binding [*above* []]
+    (apply f args)
+    (if rec?
+      (loop [above *above*]
+        (when (seq above)
+          (var-set #'*above* [])
+          (doseq [f above]
+            (f))
+          (recur *above*)))
+      (doseq [of *above*]
+        (of)))))
+
+(defmacro with-overlays [rec? & body]
+  `(with-overlays* ~rec? (fn [] ~@body)))
+
+(defn layered
+  ([content]
+     (layered true content))
+  ([rec? content]
+     (decorate-view content [_]
+       (with-overlays* rec? render! content))))

--- a/src/net/kryshen/indyvon/async.clj	Mon Apr 14 15:37:28 2014 +0400
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,178 +0,0 @@
-;;
-;; Copyright 2010-2014 Mikhail Kryshen <mikhail@kryshen.net>
-;;
-;; This file is part of Indyvon.
-;;
-;; Indyvon is free software: you can redistribute it and/or modify it
-;; under the terms of the GNU Lesser General Public License version 3
-;; only, as published by the Free Software Foundation.
-;;
-;; Indyvon is distributed in the hope that it will be useful, but
-;; WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
-;; Lesser General Public License for more details.
-;;
-;; You should have received a copy of the GNU Lesser General Public
-;; License along with Indyvon.  If not, see
-;; <http://www.gnu.org/licenses/>.
-;;
-
-(ns net.kryshen.indyvon.async
-  "Asynchronous drawing."
-  (:use
-   net.kryshen.indyvon.core)
-  (:import
-   java.awt.GraphicsConfiguration
-   (java.awt Image AlphaComposite Transparency)
-   (java.awt.image BufferedImage)
-   (java.util.concurrent ThreadFactory ThreadPoolExecutor
-                         ThreadPoolExecutor$DiscardOldestPolicy
-                         ArrayBlockingQueue TimeUnit)))
-
-(defrecord Buffer [id image readers state])
-;; Buffer states:
-;;   :front, readers > 0
-;;      being copied on screen
-;;   :back
-;;      being rendered to (offscreen)
-;;   :fresh
-;;      most recently updated
-;;   :free
-;;      not in use
-
-(defn- create-image [async-view ^GraphicsConfiguration device-conf]
-  ;; TODO: support different image types.
-  (.createCompatibleImage device-conf
-                          (:width async-view)
-                          (:height async-view)
-                          Transparency/TRANSLUCENT))
-
-(defn- create-buffer [async-view device-conf]
-  (Buffer. (Object.) (create-image async-view device-conf) 0 :free))
-
-(defn- find-buffer
-  "Find a buffer with the one of the specified states given
-   in the order of preference."
-  [buffers & states]
-  (some identity
-    (for [state states]
-      (some #(if (= (:state %) state) % nil) buffers))))
-
-(defn- replace-buffer [buffers buffer]
-  (conj (remove #(= (:id %) (:id buffer)) buffers)
-        buffer))
-
-(defn- take-buffer [al type]
-  (dosync
-   (let [buffers @(:buffers al)
-         b (case type
-             :front (find-buffer buffers :front :fresh :free)
-             :back (find-buffer buffers :free :fresh)
-             (throw (IllegalArgumentException.)))
-         readers (if (= type :front)
-                   (inc (:readers b))
-                   (:readers b))
-         b (assoc b
-             :state type
-             :readers readers)]
-     (alter (:buffers al) replace-buffer b)
-     b)))
-
-(defn- release-buffer [al buffer]
-  (dosync
-   (let [state (:state buffer)
-         readers (if (= state :front)
-                   (dec (:readers buffer))
-                   (:readers buffer))
-         fresh (delay (find-buffer @(:buffers al) :fresh))
-         state (cond
-                (pos? readers) :front
-                (= :back state) :fresh
-                @fresh :free
-                :default :fresh)]
-     (if (and (= state :fresh) @fresh)
-       ;; Change state of the prefiously fresh buffer to :free.
-       (alter (:buffers al)
-              replace-buffer (assoc @fresh
-                               :state :free)))
-     (alter (:buffers al)
-            replace-buffer (assoc buffer
-                             :state state
-                             :readers readers)))))
-
-(defmacro with-buffer
-  {:private true}
-  [al type [name] & body]
-  `(let [al# ~al
-         ~name (take-buffer al# ~type)]
-     (try
-       ~@body
-       (finally
-        (release-buffer al# ~name)))))
-
-(defn- draw-offscreen [async-view]
-  ;;(Thread/sleep 1000)
-  (with-buffer async-view :back [b]
-    (let [g (.createGraphics ^BufferedImage (:image b))]
-      ;; Clear the buffer.
-      (.setComposite g AlphaComposite/Clear)
-      (.fillRect g 0 0 (:width async-view) (:height async-view))
-      (.setComposite g AlphaComposite/Src)
-      (draw-scene! (:scene async-view)
-                   g
-                   (:width async-view)
-                   (:height async-view)))
-    (update async-view)))
-
-(defn- draw-offscreen-async [async-view]
-  (.execute ^ThreadPoolExecutor (:executor async-view)
-            #(draw-offscreen async-view)))
-
-(defrecord AsyncView [scene width height executor buffers]
-  View
-  (render! [view]
-    (repaint-on-update view)
-    (add-context-observer scene (fn [_ _] (draw-offscreen-async view)))
-    (when-not @buffers
-      ;; TODO: dynamic size, recreate buffers when size increases.
-      (let [device-conf (.getDeviceConfiguration *graphics*)
-            new-buffers (repeatedly 2
-                          (partial create-buffer view device-conf))]
-        (dosync
-         (ref-set buffers new-buffers)))
-      (draw-offscreen-async view))
-    (with-buffer view :front [b]
-      (.drawImage *graphics* ^Image (:image b) 0 0 nil)))
-  (geometry [view]
-    (->Size width height)))
-
-(defn- create-thread-factory [priority]
-  (reify
-   ThreadFactory
-   (newThread [_ runnable]
-     (let [thread (Thread. runnable)]
-       (when priority
-         (.setPriority thread priority))
-       (.setDaemon thread true)
-       thread))))
-
-(defn- create-executor [priority]
-  (doto (ThreadPoolExecutor.
-         (int 1) (int 1)
-         (long 0) TimeUnit/SECONDS
-         (ArrayBlockingQueue. 1)
-         (ThreadPoolExecutor$DiscardOldestPolicy.))
-    (.setThreadFactory (create-thread-factory priority))))
-
-(defn async-view 
-  "Creates a View that draws the content asynchronously using an
-   offscreen buffer."
-  ([width height content]
-     (async-view width height nil content))
-  ([width height priority content]
-     ;; TODO: use operational event dispatcher.
-     (->AsyncView (make-scene content)
-                  width
-                  height
-                  (create-executor priority)
-                  (ref nil))))

--- a/src/net/kryshen/indyvon/component.clj	Mon Apr 14 15:37:28 2014 +0400
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,69 +0,0 @@
-;;
-;; Copyright 2010-2014 Mikhail Kryshen <mikhail@kryshen.net>
-;;
-;; This file is part of Indyvon.
-;;
-;; Indyvon is free software: you can redistribute it and/or modify it
-;; under the terms of the GNU Lesser General Public License version 3
-;; only, as published by the Free Software Foundation.
-;;
-;; Indyvon is distributed in the hope that it will be useful, but
-;; WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
-;; Lesser General Public License for more details.
-;;
-;; You should have received a copy of the GNU Lesser General Public
-;; License along with Indyvon.  If not, see
-;; <http://www.gnu.org/licenses/>.
-;;
-
-(ns net.kryshen.indyvon.component
-  "Integrating Indyvon into AWT and Swing components."
-  (:use
-   net.kryshen.indyvon.core)
-  (:import
-   (java.awt Graphics Component Dimension Color)
-   (java.awt.geom Rectangle2D$Double)
-   (javax.swing JFrame JPanel JOptionPane)))
-
-(defn- paint-component [^Component c ^Graphics g scene]
-  (let [w (.getWidth c)
-        h (.getHeight c)]
-    (.setColor g (:back-color *theme*))
-    (.fillRect g 0 0 w h)
-    (draw-scene! scene g w h)))
-
-(defn- preferred-size [^Component c scene]
-  (let [geom (scene-geometry scene)]
-    (Dimension. (width geom) (height geom))))
-
-(defn ^JPanel make-jpanel
-  ([view]
-     (make-jpanel view (root-event-dispatcher)))
-  ([view event-dispatcher]
-     (let [panel (proxy [JPanel] [])
-           scene (make-scene
-                  view event-dispatcher panel
-                  (.getDesktopProperty (java.awt.Toolkit/getDefaultToolkit)
-                                       "awt.font.desktophints"))]
-       (update-proxy
-        panel
-        {"paintComponent" #(paint-component %1 %2 scene)
-         "getPreferredSize" #(preferred-size % scene)})
-       (.setBackground panel (:back-color *theme*))
-       (add-observer panel scene (fn [w _]
-                                   ;; Use the first observer argument
-                                   ;; instead of closing over panel to
-                                   ;; allow the panel and associated
-                                   ;; observer to be gc'd.
-                                   (.repaint ^Component w)))
-       (listen! event-dispatcher panel)
-       panel)))
-
-(defn ^JFrame make-jframe [^String title view]
-  (doto (JFrame. title)
-    (.. (getContentPane) (add (make-jpanel view)))
-    (.pack)))
-
-(defn message [m]
-  (JOptionPane/showMessageDialog (:component *scene*) m))

--- a/src/net/kryshen/indyvon/core.clj	Mon Apr 14 15:37:28 2014 +0400
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,881 +0,0 @@
-;;
-;; Copyright 2010-2014 Mikhail Kryshen <mikhail@kryshen.net>
-;;
-;; This file is part of Indyvon.
-;;
-;; Indyvon is free software: you can redistribute it and/or modify it
-;; under the terms of the GNU Lesser General Public License version 3
-;; only, as published by the Free Software Foundation.
-;;
-;; Indyvon is distributed in the hope that it will be useful, but
-;; WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
-;; Lesser General Public License for more details.
-;;
-;; You should have received a copy of the GNU Lesser General Public
-;; License along with Indyvon.  If not, see
-;; <http://www.gnu.org/licenses/>.
-;;
-
-(ns net.kryshen.indyvon.core
-  (:import
-   (java.awt Graphics2D RenderingHints Component Color Font Shape
-             Rectangle Cursor EventQueue)
-   (java.awt.geom AffineTransform Point2D$Double Rectangle2D$Double Area)
-   (java.awt.event MouseListener MouseMotionListener
-                   MouseWheelListener MouseWheelEvent)
-   (java.awt.font FontRenderContext)
-   java.util.concurrent.ConcurrentMap
-   com.google.common.collect.MapMaker))
-
-;;
-;; View context
-;;
-
-(def ^:dynamic ^Graphics2D *graphics*)
-
-(def ^:dynamic ^FontRenderContext *font-context*
-  "FontRenderContext to use when Graphics2D is not available."
-  (FontRenderContext.
-   nil
-   RenderingHints/VALUE_TEXT_ANTIALIAS_DEFAULT
-   RenderingHints/VALUE_FRACTIONALMETRICS_DEFAULT))
-
-(def ^:dynamic *width*
-  "Width of the rendering area.")
-
-(def ^:dynamic *height*
-  "Height of the rendering area.")
-
-(def ^:dynamic ^Shape *clip*)
-
-(def ^:dynamic ^Shape *input-clip*
-  "Clipping area used for dispatching pointer events (intersected with
-  *clip*). If nil, *clip* will be used.")
-
-(def ^:dynamic *time*
-  "Timestamp of the current frame (in nanoseconds).")
-
-(def ^:dynamic *scene*
-  "Encloses state that should be retained between repaints.")
-
-(def ^:dynamic *states*
-  "Transient scene states, a map.")
-
-(def ^:dynamic *event-dispatcher*)
-
-(def ^:dynamic ^AffineTransform *initial-transform*
-  "Initial transform associated with the graphics context.")
-
-(def ^:dynamic ^AffineTransform *inverse-initial-transform*
-  "Inversion of the initial transform associated with the graphics
-  context.")
-
-(defrecord Theme [fore-color back-color alt-back-color border-color
-                  shadow-color font])
-
-;; REMIND: use system colors, see java.awt.SystemColor.
-(defn default-theme []
-  (Theme. Color/BLACK
-          Color/WHITE
-          (Color. 0xDD 0xDD 0xDD)
-          (Color. 0 0 0xCC)
-          (Color. 0x44 0x44 0x44)
-          (Font. "Sans" Font/PLAIN 12)))
-
-(def ^:dynamic *theme* (default-theme))
-
-;;
-;; Core protocols and types
-;;
-
-(defprotocol View
-  "Basic UI element."
-  (render! [view]
-    "Draws the view in the current *graphics* context.")
-  (geometry [view]
-    "Returns the preferred Geometry for the view."))
-
-(defprotocol Geometry
-  "Describes geometry of a View.  Prefer using the available
-  implementations (Size, FixedGeometry and NestedGeometry) over
-  extending this protocol directly as it is likely to be changed in
-  the future versions."
-  (width [geom] [geom height])
-  (height [geom] [geom width])
-  (anchor-x [geom h-align width]
-    "Returns the x coordinate of the anchor point for the specified
-     horizontal alignment and width, h-align could be :left, :center
-     or :right.")
-  (anchor-y [geom v-align height]
-    "Returns the y coordinate of the anchor point for the specified
-    vertical alignment and height, v-align could be :top, :center
-    or :bottom."))
-
-(defn- emit-align-xy [align size first center last]
-  `(case ~align
-         ~first 0
-         ~center (/ ~size 2)
-         ~last ~size))
-
-;; Define as macro to avoid unnecessary calculation of width or height.
-(defmacro align-x
-  ([align inner outer]
-     `(align-x ~align (- ~outer ~inner)))
-  ([align width]
-     (emit-align-xy align width :left :center :right)))
-
-(defmacro align-y
-  ([align inner outer]
-     `(align-y ~align (- ~outer ~inner)))
-  ([align height]
-     (emit-align-xy align height :top :center :bottom)))
-
-(defrecord Size [width height]
-  Geometry
-  (width  [_] width)
-  (width [_ _] width)
-  (height [_] height)
-  (height [_ _] height)
-  (anchor-x [_ h-align width]
-    (align-x h-align width))
-  (anchor-y [_ v-align height]
-    (align-y v-align height)))
-
-(defrecord FixedGeometry [ax ay width height]
-  Geometry
-  (width  [_] width)
-  (width [_ _] width)
-  (height [_] height)
-  (height [_ _] height)
-  (anchor-x [_ _ _] ax)
-  (anchor-y [_ _ _] ay))
-
-(defrecord NestedGeometry [geometry top left bottom right]
-  Geometry
-  (width  [_]
-    (+ left right (width geometry)))
-  (width [_ h]
-    (+ left right (width geometry (- h top bottom))))
-  (height [_]
-    (+ top bottom (height geometry)))
-  (height [_ w]
-    (+ top bottom (height geometry (- w left right))))
-  (anchor-x [_ h-align w]
-    (+ left (anchor-x geometry h-align (- w left right))))
-  (anchor-y [_ v-align h]
-    (+ top (anchor-y geometry v-align (- h top bottom)))))
-
-(defrecord ScaledGeometry [geometry sx sy]
-  Geometry
-  (width  [_]
-    (* sx (width geometry)))
-  (width [_ h]
-    (* sx (width geometry (/ h sy))))
-  (height [_]
-    (* sy (height geometry)))
-  (height [_ w]
-    (* sy (height geometry (/ w sx))))
-  (anchor-x [_ h-align w]
-    (* sx (anchor-x geometry h-align (/ w sx))))
-  (anchor-y [_ v-align h]
-    (* sy (anchor-y geometry v-align (/ h sy)))))
-
-;; (defn ^:private to-integer
-;;   ^long [align x]
-;;   (if (integer? x)
-;;     x
-;;     (let [x (double x)]
-;;       (Math/round
-;;        (case align
-;;          (:top :left) (Math/floor x)
-;;          :center x
-;;          (:bottom :right) (Math/ceil x))))))
-
-;; (defrecord IntegerGeometry [geometry]
-;;   Geometry
-;;   (width [_]
-;;     (to-integer :right (width geometry)))
-;;   (width [_ h]
-;;     (to-integer :right (width geometry h)))
-;;   (height [_]
-;;     (to-integer :bottom (height geometry)))
-;;   (height [_ w]
-;;     (to-integer :bottom (height geometry w)))
-;;   (anchor-x [_ h-align w]
-;;     (to-integer h-align (anchor-x geometry h-align w)))
-;;   (anchor-y [_ v-align h]
-;;     (to-integer v-align (anchor-y geometry v-align h))))
-
-;; TODO: modifiers
-(defrecord MouseEvent [id when x y x-on-screen y-on-screen button
-                       wheel-rotation transform component])
-
-;; TODO: KeyEvent
-
-(defprotocol EventDispatcher
-  (listen! [this component]
-     "Listen for events on the specified AWT Component.")
-  (create-dispatcher [this handle handlers]
-     "Returns new event dispatcher associated with the specified event
-      handlers (an event-id -> handler-fn map). Handle is used to
-      match the contexts between commits.")
-  (commit [this]
-     "Apply the registered handlers for event processing.")
-  (handle-picked? [this handle]
-     "Returns true if the specified handle received the :mouse-pressed
-      event and have not yet received :moused-released.")
-  (handle-hovered? [this handle]
-     "Returns true if the specified handle received the :mouse-entered
-      event and have not yet received :mouse-exited."))
-
-(defn- assoc-cons [m key val]
-  (->> (get m key) (cons val) (assoc m key)))
-
-;;
-;; Observers
-;; The mechanism used by views to request repaints
-;;
-
-(def ^ConcurrentMap observers
-     (-> (MapMaker.) (.weakKeys) (.makeMap)))
-
-(defn- cm-replace!
-  "Wrap ConcurrentMap replace method to treat nil value as absent
-   mapping. Use with maps that does not support nil values."
-  [^ConcurrentMap cmap key old new]
-  (if (nil? old)
-    (nil? (.putIfAbsent cmap key new))
-    (.replace cmap key old new)))
-
-(defn- cm-swap!
-  "Atomically swaps the value associated with key in ConcurrentMap
-   to be (apply f current-value args). Returns the new value."
-  [^ConcurrentMap cmap key f & args]
-  (loop []
-    (let [old (.get cmap key)
-          new (apply f old args)]
-      (if (cm-replace! cmap key old new)
-        new
-        (recur)))))
-
-(defn add-observer
-  "Add observer fn for the target. Watcher identifies the group of
-  observers and could be used to remove the group. Watcher is weakly
-  referenced, all associated observers will be removed when the
-  wathcer is removed by gc. The observer fn will be called with
-  watcher and target arguments and any additional arguments specified
-  in update call."
-  [watcher target f]
-  (cm-swap! observers watcher assoc-cons target f)
-  nil)
-
-(defn remove-observers
-  "Remove group of observers associated with the specified watcher."
-  [watcher]
-  (.remove observers watcher)
-  nil)
-
-(defn- replace-observers-watcher
-  [old-watcher new-watcher]
-  (if-let [old (.remove observers old-watcher)]
-    (.put observers new-watcher old))
-  nil)
-
-(defn update
-  "Notify observers."
-  [target & args]
-  (doseq [entry observers
-          f (get (val entry) target)]
-    (apply f (key entry) target args)))
-
-(defn add-context-observer
-  "Observer registered with this function will be automatically
-  removed after the next repaint is complete."
-  [target f]
-  (add-observer *scene* target f))
-
-(defn repaint-on-update
-  "Trigger repaint of the current scene when the target updates."
-  [target]
-  (let [scene *scene*]
-    (if-not (identical? scene target)
-      (add-observer scene target (fn [w _] (update w))))))
-
-(defn repaint
-  "Requests repaint of the current scene. If handle and state are
-  specified, the handle will be associated with the state in the
-  *states* map for the next paint iteration."
-  ([]
-     (update *scene*))
-  ([handle state]
-     (let [scene *scene*]
-       (swap! (:next-state scene) assoc handle state)
-       (update scene))))
-
-;;
-;; Rendering
-;;
-
-(defn ^FontRenderContext font-context
-  "Returns FontRenderContext for the current view context."
-  []
-  (if (bound? (var *graphics*))
-    (.getFontRenderContext *graphics*)
-    *font-context*))
-
-(defn ^AffineTransform relative-transform
-  "Returns AffineTransform: view context -> AWT component."
-  []
-  (let [tr (.getTransform *graphics*)]
-    (.preConcatenate tr *inverse-initial-transform*)
-    tr))
-
-(defn ^AffineTransform inverse-relative-transform
-  "Returns AffineTransform: AWT component -> view context."
-  []
-  (let [tr (.getTransform *graphics*)]
-    (.invert tr)                          ; absolute -> view
-    (.concatenate tr *initial-transform*) ; component -> absolute
-    tr))
-
-(defn transform-point [^AffineTransform tr ^double x ^double y]
-  (let [p (Point2D$Double. x y)]
-    (.transform tr p p)
-    [(.x p) (.y p)]))
-
-(defn inverse-transform-point [^AffineTransform tr ^double x ^double y]
-  (let [p (Point2D$Double. x y)]
-    (.inverseTransform tr p p)
-    [(.x p) (.y p)]))
-
-;; (defn- clip
-;;   "Intersect clipping area with the specified shape or bounds.
-;;    Returns new clip (Shape or nil if empty)."
-;;   ([x y w h]
-;;      (clip (Rectangle2D$Double. x y w h)))
-;;   ([shape]
-;;      (let [a1 (Area. shape)
-;;            a2 (if (instance? Area *clip*) *clip* (Area. *clip*))]
-;;        (.transform a1 (relative-transform))
-;;        (.intersect a1 a2)
-;;        (if (.isEmpty a1)
-;;          nil
-;;          a1))))
-
-;; Use faster clipping calculation provided by Graphics2D.
-(defn- clip
-  "Intersect clipping area with the specified Shape in current
-   transform coordinates. Returns new clip in the AWT component
-   coordinates (Shape or nil if empty)."
-  [^Shape shape]
-  (let [^Graphics2D clip-g (.create *graphics*)]
-    (try
-      (doto clip-g
-        (.setClip shape)
-        (.setTransform *initial-transform*)
-        (.clip *clip*))
-      (if (.isEmpty (.getClipBounds clip-g))
-        nil
-        (.getClip clip-g))
-      (finally
-       (.dispose clip-g)))))
-
-(defn- ^Graphics2D apply-theme
-  "Set graphics' color and font to match theme.
-   Modifies and returns the first argument."
-  ([]
-     (apply-theme *graphics* *theme*))
-  ([^Graphics2D graphics theme]
-     (doto graphics
-       (.setColor (:fore-color theme))
-       (.setFont (:font theme)))))
-
-(defn- ^Graphics2D create-graphics
-  ([]
-     (apply-theme (.create *graphics*) *theme*))
-  ([^long x ^long y ^long w ^long h]
-     (apply-theme (.create *graphics* x y w h) *theme*)))
-
-(defn- with-bounds-noclip*
-  [x y w h f & args]
-  (let [graphics (create-graphics)]
-    (try
-      (.translate graphics (double x) (double y))
-      (binding [*width* w
-                *height* h
-                *input-clip* (Rectangle2D$Double. 0.0 0.0 w h)
-                *graphics* graphics]
-        (apply f args))
-      (finally
-       (.dispose graphics)))))
-
-(defn with-bounds*
-  [x y w h f & args]
-  (let [x (double x)
-        y (double y)
-        bounds (Rectangle2D$Double. x y w h)]
-    (when-let [clip (clip bounds)]
-      (let [^Graphics2D graphics (create-graphics)]
-        (try
-          (.clip graphics bounds)
-          (.translate graphics x y)
-          (binding [*width* w
-                    *height* h
-                    *clip* clip
-                    *input-clip* nil
-                    *graphics* graphics]
-            (apply f args))
-          (finally
-           (.dispose graphics)))))))
-
-(defmacro with-bounds
-  [x y w h & body]
-  `(with-bounds* ~x ~y ~w ~h (fn [] ~@body)))
-
-(defmacro with-theme
-  [theme & body]
-  `(binding [*theme* (merge *theme* ~theme)]
-     ~@body))
-
-(defmacro with-color [color-or-key & body]
-  `(let [color# ~color-or-key
-         color# (get *theme* color# color#)
-         g# *graphics*
-         old-color# (.getColor g#)]
-     (try
-       (.setColor g# color#)
-       ~@body
-       (finally
-         (.setColor g# old-color#)))))
-
-(defmacro with-stroke [stroke & body]
-  `(let [g# *graphics*
-         old-stroke# (.getStroke g#)]
-     (try
-       (.setStroke g# ~stroke)
-       ~@body
-       (finally
-        (.setStroke g# old-stroke#)))))
-
-(defmacro with-hints
-  [hints & body]
-  `(let [h# ~hints
-         g# *graphics*
-         old# (.getRenderingHints g#)]
-     (try
-       (.addRenderingHints g# h#)
-       ~@body
-       (finally
-        (.setRenderingHints g# old#)))))
-
-(defn with-hints* [hints f & args]
-  (with-hints hints
-    (apply f args)))
-
-;; TODO: constructor for AffineTransform.
-;; (transform :scale 0.3 0.5
-;;            :translate 5 10
-;;            :rotate (/ Math/PI 2))
-
-(defmacro with-transform [transform & body]
-  `(let [g# *graphics*
-         old-t# (.getTransform g#)]
-     (try
-       (.transform g# ~transform)
-       ~@body
-       (finally
-        (.setTransform g# old-t#)))))
-
-(defmacro with-rotate [theta ax ay & body]
-  `(let [transform# (AffineTransform/getRotateInstance ~theta ~ax ~ay)]
-     (with-transform transform# ~@body)))
-
-(defmacro with-translate [x y & body]
-  `(let [x# ~x
-         y# ~y
-         g# *graphics*]
-     (try
-       (.translate g# x# y#)
-       ~@body
-       (finally
-        (.translate g# (- x#) (- y#))))))
-
-(defn draw!
-  "Draws the View."
-  ([view]
-     (let [graphics (create-graphics)]
-       (try
-         (binding [*graphics* graphics]
-           (render! view))
-         (finally
-          (.dispose graphics)))))
-  ([x y view]
-     (draw! x y true view))
-  ([x y clip? view]
-     (let [geom (geometry view)]
-       (draw! x y (width geom) (height geom) clip? view)))
-  ([x y width height view]
-     (draw! x y width height true view))
-  ([x y width height clip? view]
-     (if clip?
-       (with-bounds* x y width height render! view)
-       (with-bounds-noclip* x y width height render! view))))
-
-(defn draw-aligned!
-  "Draws the View.  Location is relative to the view's anchor point
-   for the specified alignment."
-  ([h-align v-align x y view]
-     (let [geom (geometry view)
-           w (width geom)
-           h (height geom)]
-       (draw! (- x (anchor-x geom h-align w))
-              (- y (anchor-y geom v-align h))
-              w h
-              view)))
-  ([h-align v-align x y w h view]
-     (let [geom (geometry view)]
-       (draw! (- x (anchor-x geom h-align w))
-              (- y (anchor-y geom v-align h))
-              w h
-              view))))
-
-;;
-;; Event handling.
-;;
-
-(defn with-handlers*
-  [handle handlers f & args]
-  (binding [*event-dispatcher* (create-dispatcher
-                                *event-dispatcher* handle handlers)]
-    (apply f args)))
-
-(defmacro with-handlers
-  "specs => (:event-id name & handler-body)*
-
-  Execute form with the specified event handlers."
-  [handle form & specs]
-  `(with-handlers* ~handle
-     ~(reduce (fn [m spec]
-                (assoc m (first spec)
-                       `(fn [~(second spec)]
-                          ~@(nnext spec)))) {}
-                          specs)
-     (fn [] ~form)))
-
-(defn picked? [handle]
-  (handle-picked? *event-dispatcher* handle))
-
-(defn hovered? [handle]
-  (handle-hovered? *event-dispatcher* handle))
-
-;;
-;; EventDispatcher implementation
-;;
-
-(def awt-events
-     {java.awt.event.MouseEvent/MOUSE_CLICKED  :mouse-clicked
-      java.awt.event.MouseEvent/MOUSE_DRAGGED  :mouse-dragged
-      java.awt.event.MouseEvent/MOUSE_ENTERED  :mouse-entered
-      java.awt.event.MouseEvent/MOUSE_EXITED   :mouse-exited
-      java.awt.event.MouseEvent/MOUSE_MOVED    :mouse-moved
-      java.awt.event.MouseEvent/MOUSE_PRESSED  :mouse-pressed
-      java.awt.event.MouseEvent/MOUSE_RELEASED :mouse-released
-      java.awt.event.MouseEvent/MOUSE_WHEEL    :mouse-wheel})
-
-(def dummy-event-dispatcher
-  (reify EventDispatcher
-    (listen! [_ _])
-    (create-dispatcher [this _ _] this)
-    (commit [_])
-    (handle-picked? [_ _])
-    (handle-hovered? [_ _])))
-
-;; Not using defrecord to avoid unacceptable overhead of recursive
-;; hash code calculation.
-(deftype DispatcherNode [handle handlers parent
-                         ^Shape clip ^AffineTransform transform
-                         bindings]
-  EventDispatcher
-  (listen! [this component]
-    (listen! parent component))
-  (create-dispatcher [this handle handlers]
-    (create-dispatcher parent handle handlers))
-  (commit [this]
-    (commit parent))
-  (handle-picked? [this handle]
-    (handle-picked? parent handle))
-  (handle-hovered? [this handle]
-    (handle-hovered? parent handle)))
-
-(defn- make-node [handle handlers]
-  (let [clip (if *input-clip*
-               (clip *input-clip*)
-               *clip*)
-        bindings (-> (get-thread-bindings)
-                     (dissoc (var *graphics*))
-                     (assoc (var *font-context*) (font-context)))]
-    (DispatcherNode. handle handlers *event-dispatcher* clip
-                     (relative-transform)
-                     bindings)))
-
-(defn- add-node [tree ^DispatcherNode node]
-  (assoc-cons tree (.parent node) node))
-
-(defn- nodes [tree]
-  (apply concat (vals tree)))
-
-(defn- under-cursor
-  "Returns a vector of child nodes under cursor."
-  [node tree ^long x ^long y]
-  (some (fn [^DispatcherNode n]
-          (if (and (.clip n) (.contains ^Shape (.clip n) x y))
-            (conj (vec (under-cursor n tree x y)) n)))
-        (get tree node)))
-
-(defn- translate-mouse-event [^java.awt.event.MouseEvent event
-                              ^AffineTransform tr id]
-  (let [[x y] (inverse-transform-point tr (.getX event) (.getY event))
-        rotation (if (instance? MouseWheelEvent event)
-                   (.getWheelRotation ^MouseWheelEvent event)
-                   nil)]
-    (->MouseEvent id (.getWhen event) x y
-                  (.getXOnScreen event) (.getYOnScreen event)
-                  (.getButton event)
-                  rotation
-                  tr
-                  (.getComponent event))))
-
-(defn- translate-and-dispatch
-  ([nodes first-only ^java.awt.event.MouseEvent event]
-     (translate-and-dispatch nodes first-only
-                             event (awt-events (.getID event))))
-  ([nodes first-only event id]
-     (if-let [^DispatcherNode node (first nodes)]
-       (let [handlers (.handlers node)
-             handler (get handlers id)]
-         (if handler
-           (do
-             (with-bindings* (.bindings node)
-               handler
-               (translate-mouse-event event (.transform node) id))
-             (when-not first-only
-               (recur (rest nodes) false event id)))
-           (when-not (and (= id :mouse-dragged)
-                          (or (contains? handlers :mouse-pressed)
-                              (contains? handlers :mouse-released)))
-             (recur (rest nodes) first-only event id)))))))
-
-(defn- process-mouse-event
-  [dispatcher ^java.awt.event.MouseEvent source-event]
-  (let [{active-ref :active
-         hovered-ref :hovered
-         picked-ref :picked
-         last-ref :last-motion
-         tree-ref :tree} dispatcher
-         pressed (and source-event
-                      (== (.getID source-event)
-                          java.awt.event.MouseEvent/MOUSE_PRESSED))
-         released (and source-event
-                       (== (.getID source-event)
-                           java.awt.event.MouseEvent/MOUSE_RELEASED))
-         ^java.awt.event.MouseEvent last-event @last-ref
-         ^java.awt.event.MouseEvent event (or source-event last-event)]
-    (when event
-      (let [x (.getX event)
-            y (.getY event)
-            active @active-ref
-            active (if (and active
-                            source-event
-                            (== (.getX last-event) x)
-                            (== (.getY last-event) y))
-                     active
-                     (ref-set active-ref
-                              (under-cursor dispatcher @tree-ref x y)))
-            acted (cond
-                   pressed (ref-set picked-ref active)
-                   released (let [picked @picked-ref]
-                              (ref-set picked-ref nil)
-                              picked)
-                   :else active)
-            picked (seq @picked-ref)
-            pred #(= (.handle ^DispatcherNode %1) (.handle ^DispatcherNode %2))
-            hovered (if picked
-                      (filter #(some (partial pred %) picked) active)
-                      active)
-            remove-all (fn [c1 c2]
-                         (filter #(not (some (partial pred %) c2)) c1))
-            old-hovered @hovered-ref
-            exited (remove-all old-hovered hovered)
-            entered (remove-all hovered old-hovered)
-            moved (or picked (remove-all hovered entered))]
-        (ref-set hovered-ref hovered)
-        (ref-set last-ref event)
-        [exited entered moved acted event]))))
-
-(defn- dispatch-mouse-event
-  [dispatcher source-event button?]
-  (when-let [[exited
-              entered
-              moved
-              acted
-              event] (dosync (process-mouse-event dispatcher source-event))]
-    (when button?
-      (translate-and-dispatch acted true event))
-    (translate-and-dispatch exited false event :mouse-exited)
-    (translate-and-dispatch entered false event :mouse-entered)
-    (when-not button?
-      (translate-and-dispatch moved true source-event))))
-
-(defrecord RootEventDispatcher [tree-r  ;; register
-                                tree    ;; dispatch
-                                active  ;; nodes under cursor
-                                hovered ;; mouse entered
-                                picked  ;; mouse pressed
-                                last-motion]
-  EventDispatcher
-  (listen! [dispatcher component]
-    (doto ^Component component
-          (.addMouseListener dispatcher)
-          (.addMouseWheelListener dispatcher)
-          (.addMouseMotionListener dispatcher)))
-  (create-dispatcher [dispatcher handle handlers]
-    (let [node (make-node handle handlers)]
-      (dosync (alter tree-r add-node node))
-      node))
-  (commit [dispatcher]
-    (let [[exited
-           entered
-           _ _
-           event] (dosync
-                   ;; TODO: retain contexts that do
-                   ;; not intersect graphics
-                   ;; clipping area in tree.
-                   (ref-set tree @tree-r)
-                   (ref-set tree-r {})
-                   (process-mouse-event dispatcher nil))]
-      ;; Send mouse entered and exited events if necessary due to
-      ;; updated layout.
-      (translate-and-dispatch exited false event :mouse-exited)
-      (translate-and-dispatch entered false event :mouse-entered)))
-  (handle-picked? [dispatcher handle]
-    (some #(= handle (.handle ^DispatcherNode %)) @picked))
-  (handle-hovered? [dispatcher handle]
-    (some #(= handle (.handle ^DispatcherNode %)) @hovered))
-  MouseListener
-  (mouseEntered [dispatcher event]
-    (dispatch-mouse-event dispatcher event false))
-  (mouseExited [dispatcher event]
-    (dispatch-mouse-event dispatcher event false))
-  (mouseClicked [dispatcher event]
-    (dispatch-mouse-event dispatcher event true))
-  (mousePressed [dispatcher event]
-    (dispatch-mouse-event dispatcher event true))
-  (mouseReleased [dispatcher event]
-    (dispatch-mouse-event dispatcher event true))
-  MouseWheelListener
-  (mouseWheelMoved [dispatcher event]
-    (dispatch-mouse-event dispatcher event true))
-  MouseMotionListener
-  (mouseDragged [dispatcher event]
-    (dispatch-mouse-event dispatcher event false))
-  (mouseMoved [dispatcher event]
-    (dispatch-mouse-event dispatcher event false)))
-
-(defn root-event-dispatcher []
-  (->RootEventDispatcher
-   (ref {}) (ref {})             ;; trees
-   (ref nil) (ref nil) (ref nil) ;; node states
-   (ref nil)))                   ;; last event
-
-;;
-;; Scene
-;;
-
-(defrecord Scene [view
-                  event-dispatcher
-                  component
-                  rendering-hints
-                  next-state])
-
-;; Define rendering hints that affect font metrics to make sure that
-;; Graphics and Scene FontRenderContexts are consistent.
-(def ^:private default-rendering-hints
-  {RenderingHints/KEY_TEXT_ANTIALIASING
-   RenderingHints/VALUE_TEXT_ANTIALIAS_DEFAULT,
-   RenderingHints/KEY_FRACTIONALMETRICS
-   RenderingHints/VALUE_FRACTIONALMETRICS_DEFAULT})
-
-(defn make-scene
-  ([view]
-     (make-scene view dummy-event-dispatcher nil))
-  ([view event-dispatcher]
-     (make-scene view event-dispatcher nil))
-  ([view event-dispatcher ^Component component]
-     (make-scene view event-dispatcher component nil))
-  ([view event-dispatcher ^Component component hints]
-     (let [hints (merge default-rendering-hints hints)]
-       (->Scene view
-                event-dispatcher
-                component
-                hints
-                (atom nil)))))
-
-(defn- get-and-set!
-  "Atomically sets the value of atom to newval and returns the old
-  value."
-  [atom newval]
-  (loop [v @atom]
-    (if (compare-and-set! atom v newval)
-      v
-      (recur @atom))))
-
-(defn draw-scene!
-  [scene ^Graphics2D graphics width height]
-  (.addRenderingHints graphics (:rendering-hints scene))
-  (binding [*states* (get-and-set! (:next-state scene) nil)
-            *scene* scene
-            *graphics* graphics
-            *initial-transform* (.getTransform graphics)
-            *inverse-initial-transform* (-> graphics
-                                            .getTransform
-                                            .createInverse)
-            *event-dispatcher* (:event-dispatcher scene)
-            *width* width
-            *height* height
-            *clip* (Rectangle2D$Double. 0.0 0.0 width height)
-            *input-clip* nil
-            *time* (System/nanoTime)]
-    (apply-theme)
-    (let [tmp-watcher (Object.)]
-      ;; Keep current context observers until the rendering is
-      ;; complete. Some observers may be invoked twice if they
-      ;; appear in both groups until tmp-watcher is removed.
-      (replace-observers-watcher scene tmp-watcher)
-      (try
-        (render! (:view scene))
-        (finally
-         (remove-observers tmp-watcher)
-         (commit (:event-dispatcher scene)))))))
-
-(defn- scene-font-context [scene]
-  (let [hints (:rendering-hints scene)
-        ^Component c (:component scene)
-        t (if c (->> c
-                     .getFont
-                     (.getFontMetrics c)
-                     .getFontRenderContext
-                     .getTransform))]
-    (FontRenderContext.
-     t
-     (get hints RenderingHints/KEY_TEXT_ANTIALIASING)
-     (get hints RenderingHints/KEY_FRACTIONALMETRICS))))      
-
-(defn scene-geometry [scene]
-  (binding [*scene* scene
-            *font-context* (scene-font-context scene)]
-    (geometry (:view scene))))
-
-(defn set-cursor! [^Cursor cursor]
-  (when-let [^Component component (:component *scene*)]
-    (EventQueue/invokeLater #(.setCursor component cursor))))

--- a/src/net/kryshen/indyvon/demo.clj	Mon Apr 14 15:37:28 2014 +0400
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,223 +0,0 @@
-;;
-;; Copyright 2010-2014 Mikhail Kryshen <mikhail@kryshen.net>
-;;
-;; This file is part of Indyvon.
-;;
-;; Indyvon is free software: you can redistribute it and/or modify it
-;; under the terms of the GNU Lesser General Public License version 3
-;; only, as published by the Free Software Foundation.
-;;
-;; Indyvon is distributed in the hope that it will be useful, but
-;; WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
-;; Lesser General Public License for more details.
-;;
-;; You should have received a copy of the GNU Lesser General Public
-;; License along with Indyvon.  If not, see
-;; <http://www.gnu.org/licenses/>.
-;;
-
-(ns net.kryshen.indyvon.demo
-  "Indyvon demo and experiments."
-  (:gen-class)
-  (:use
-   (net.kryshen.indyvon core views viewport component))
-  (:import
-   (java.awt Color)
-   (javax.swing JFrame)))
-
-(defn draw-button!
-  "Draws a button immediately (but uses callback for the action unlike
-   IMGUI)."
-  [id content callback & args]
-  (with-handlers id
-    (let [shadow-offset 2
-          padding 4
-          border-width 1
-          offset (if (picked? id) (/ shadow-offset 2) 0)
-          ^Color color (:alt-back-color *theme*)
-          color (if (hovered? id) (.brighter color) color)
-          width (- *width* shadow-offset)
-          height (- *height* shadow-offset)]
-      (with-color (:shadow-color *theme*)
-        (.fillRect *graphics* shadow-offset shadow-offset width height))
-      (with-color color
-        (.fillRect *graphics* offset offset width height))
-      (draw! offset offset width height
-             (border border-width padding content)))
-    ;; Event handlers
-    (:mouse-entered _ (repaint))
-    (:mouse-exited _ (repaint))
-    (:mouse-pressed _ (repaint))
-    (:mouse-released _ (repaint))
-    (:mouse-clicked _ (apply callback args))))
-
-(defn combine-colors
-  "Returns color between color1 and color2. When c (0 <= c <= 1.0) is
-   closer to 0 the returned сolor is closer to color1."
-  [^Color color1 ^Color color2 c]
-  (case c
-    0.0 color1
-    1.0 color2
-    (let [rgb1 (.getRGBComponents color1 nil)
-          rgb2 (.getRGBComponents color2 nil)
-          rgb (float-array (map #(+ (* (- 1 c) %1) (* c %2)) rgb1 rgb2))]
-      (Color. (aget rgb 0) (aget rgb 1) (aget rgb 2) (aget rgb 3)))))
-
-(defn animate
-  "Changes the value of atom according to the specified range, speed,
-   and current frame interval.  Invokes repaint if change happens."
-  [atom from to speed]
-  (let [prev @atom
-        state (cond
-               (zero? speed) :stop
-               (= prev from) (if (pos? speed) :start :stop)               
-               (= prev to) (if (neg? speed) :start :stop)
-               :default :continue)]
-    (if (= state :stop)
-       prev
-       (let [interval (if (= state :start) 1 *interval*)
-             step (* speed interval 1E-9)
-             val (swap! atom #(-> % (+ step) (max from) (min to)))]
-         (repaint)
-         val))))
-
-(defn animated-button
-  "Creates an animated button."
-  [content callback & args]
-  (let [padding 4
-        border-width 1
-        shadow-offset 2
-        face (border padding border-width content)
-        highlight (atom 0)
-        animation-speed (atom 0)]
-    (interval-view
-     (reify
-      View
-      (render! [button]
-        (with-handlers button
-          (let [hovered (hovered? button)
-                offset (if (picked? button) (/ shadow-offset 2) 0)
-                color (combine-colors
-                       (:alt-back-color *theme*) Color/WHITE
-                       (animate highlight 0.0 1.0 @animation-speed))
-                width (- *width* shadow-offset)
-                height (- *height* shadow-offset)]
-            (with-color (:shadow-color *theme*)
-              (.fillRect *graphics*
-                         shadow-offset shadow-offset
-                         width height))
-            (with-color color
-              (.fillRect *graphics* offset offset width height))
-            (draw! offset offset width height
-                   (border border-width padding content)))
-          ;; Event handlers
-          (:mouse-entered _
-            (reset! animation-speed 4)
-            (repaint))
-          (:mouse-exited _
-            (reset! animation-speed -2)
-            (repaint))
-          (:mouse-pressed _ (repaint))
-          (:mouse-released _ (repaint))
-          (:mouse-clicked _ (apply callback args))))
-     (geometry [button]
-       (let [face-geom (geometry face)]
-         (->Size (+ (width face-geom) shadow-offset)
-                 (+ (height face-geom) shadow-offset))))))))
-
-(def button1 (animated-button (label "Animated button 1")
-                              println "Animated button 1 clicked"))
-
-(def button2 (animated-button (label "Animated button 2")
-                              println "Animated button 2 clicked"))
-
-(def test-view1
-  (reify
-   View
-   (render! [view]
-     (with-handlers view
-       (with-color (if (hovered? view) Color/ORANGE Color/RED)
-         (.fillRect *graphics* 0 0 *width* *height*))
-       (:mouse-entered e
-        (repaint)
-        (println e))
-       (:mouse-exited e
-        (repaint)
-        (println e))
-       (:mouse-moved e
-        (println e))))
-   (geometry [view]
-     (->Size 30 20))))
-
-(def test-view1b (border 2 3 test-view1))
-
-(def test-view2
-  (reify
-   View
-   (render! [view]
-     (doto *graphics*
-       (.setColor Color/YELLOW)
-       (.fillRect 0 0 *width* *height*))
-     (with-rotate 0.5 0 0
-       (draw! 30 25 test-view1b))
-     (draw! 55 5 test-view1))
-   (geometry [view]
-     (->Size 70 65))))
-
-(def test-view2m (miniature 30 30 test-view2))
-
-(def test-view3 (border (label :right :bottom "Sample\ntext")))
-
-(def root
-  (reify
-   View
-   (render! [view]
-     ;;(repaint)
-     (doto *graphics*
-       (.drawLine 0 0 *width* *height*)
-       (.drawLine *width* 0 0 *height*)
-       ;; Random color to see when repaint happens.
-       (.setColor (rand-nth [Color/BLACK Color/BLUE Color/RED]))
-       (.fillOval 5 5 20 20))
-     (draw! 30 20 test-view2)
-     (draw! 120 50 test-view2m)
-     (draw! 100 100 80 50 test-view3)
-     (draw! 50 160 button1)
-     (with-rotate (/ Math/PI 6) 250 200
-       (draw! 210 140 button1))
-     (draw! 100 200 button2)
-     (with-bounds 180 240 140 30
-       (draw-button! :button
-        (label :center :center "Immediate button")
-        #(println "Button clicked!"))))
-   (geometry [view]
-     (->Size 400 300))))
-
-;; Main viewport
-(def vp (viewport root))
-
-;; Miniature (rendered asynchronously)
-(def vp-miniature (->> vp (viewport-miniature 100 75) border shadow))
-
-;; Main scene
-(def scene
-  (fps-view
-   (decorate-view vp [_]
-     (draw! vp)
-     (draw-aligned!
-      :left :bottom 5 (- *height* 5)
-      (label (str "Drag mouse to pan," \newline
-                  "use mouse wheel to zoom.")))
-     (draw! (- *width* 105) 5 vp-miniature))))
-
-(defn show-frame [view]
-  (doto (make-jframe "Test" view)
-    (.setDefaultCloseOperation JFrame/DISPOSE_ON_CLOSE)
-    (.setVisible true)))
-
-(defn -main []
-  (show-frame scene))
-
-(comment
-  (show-frame (viewport-miniature 200 150 vp)))

--- a/src/net/kryshen/indyvon/viewport.clj	Mon Apr 14 15:37:28 2014 +0400
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,238 +0,0 @@
-;;
-;; Copyright 2010-2014 Mikhail Kryshen <mikhail@kryshen.net>
-;;
-;; This file is part of Indyvon.
-;;
-;; Indyvon is free software: you can redistribute it and/or modify it
-;; under the terms of the GNU Lesser General Public License version 3
-;; only, as published by the Free Software Foundation.
-;;
-;; Indyvon is distributed in the hope that it will be useful, but
-;; WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
-;; Lesser General Public License for more details.
-;;
-;; You should have received a copy of the GNU Lesser General Public
-;; License along with Indyvon.  If not, see
-;; <http://www.gnu.org/licenses/>.
-;;
-
-(ns net.kryshen.indyvon.viewport
-  "Scrollable viewport and miniature."
-  (:use
-   (net.kryshen.indyvon core async views))
-  (:import
-   java.awt.Cursor
-   java.awt.geom.AffineTransform))
-  
-;;(defn- translate [^AffineTransform transform ^double x ^double y]
-;;  (doto ^AffineTransform (.clone transform)
-;;        (.translate x y)))
-
-(defn- scale [^AffineTransform transform ^double sx ^double sy]
-    (doto ^AffineTransform (.clone transform)
-        (.scale sx sy)))
-
-(defn- pre-translate [^AffineTransform transform ^double x ^double y]
-  (if (== 0.0 x y)
-    transform
-    (doto (AffineTransform/getTranslateInstance x y)
-      (.concatenate transform))))
-
-(def ^:dynamic *viewport-scaling-step* (double 3/4))
-(def ^:dynamic *viewport-min-scale* 1E-6)
-(def ^:dynamic *viewport-max-scale* 1E6)
-
-(def ^:dynamic *viewport* nil)
-(def ^:dynamic ^AffineTransform *viewport-transform*)
-
-(declare scale-viewport!)
-
-(defrecord ViewportState [transform
-                          fix-x fix-y
-                          last-width last-height
-                          last-anchor-x last-anchor-y])
-
-(defn- update-viewport [state content-geom h-align v-align]
-  (let [w *width*
-        h *height*
-        cw (width content-geom)
-        ch (height content-geom)
-        ax (anchor-x content-geom h-align cw)
-        ay (anchor-y content-geom v-align ch)
-        ax1 (align-x h-align (:last-width state) w)
-        ay1 (align-y v-align (:last-height state) h)
-        ax2 (- (:last-anchor-x state) ax)
-        ay2 (- (:last-anchor-y state) ay)
-        transform (:transform state)
-        transform (if (and (zero? ax1) (zero? ay1)
-                           (zero? ax2) (zero? ay2))
-                    transform
-                    (doto
-                        (AffineTransform/getTranslateInstance ax1 ay1)
-                      (.concatenate transform)
-                      (.translate ax2 ay2)))]
-    (assoc state
-      :last-width w
-      :last-height h
-      :last-anchor-x ax
-      :last-anchor-y ay
-      :transform transform)))
-
-(defrecord Viewport [content h-align v-align state]
-  View
-  (render! [view]
-    (repaint-on-update view)
-    (with-handlers view
-      (let [geom (geometry content)
-            new-state (swap! state update-viewport geom h-align v-align)
-            transform (:transform new-state)]
-        ;; TODO: notify observers when size changes.
-        (binding [*viewport* view
-                  *viewport-transform* transform]
-          (with-transform transform
-            (draw! 0 0 (width geom) (height geom) false content))))
-      (:mouse-pressed e
-       (swap! state assoc
-              :fix-x (:x-on-screen e)
-              :fix-y (:y-on-screen e))
-       (set-cursor! (Cursor. Cursor/MOVE_CURSOR)))
-      (:mouse-released e
-       (set-cursor! (Cursor. Cursor/DEFAULT_CURSOR)))
-      (:mouse-dragged e
-       (swap! state
-              (fn [s]
-                (assoc s
-                  :transform (pre-translate
-                              (:transform s)
-                              (- (:x-on-screen e) (:fix-x s))
-                              (- (:y-on-screen e) (:fix-y s)))
-                  :fix-x (:x-on-screen e)
-                  :fix-y (:y-on-screen e))))
-       (update view))
-      (:mouse-wheel e
-       (scale-viewport!
-        view
-        (Math/pow *viewport-scaling-step* (:wheel-rotation e))
-        true (:x e) (:y e)))))
-  (geometry [_]
-    (geometry content)))
-
-(def ^:private viewport-initial-state
-  (->ViewportState
-   (AffineTransform.) ; transform
-   0 0                ; fix-x fix-y
-   0 0                ; last-width last-height
-   0 0))
-
-(defn viewport
-  "Creates scrollable viewport view."
-  ([content]
-     (viewport :left :top content))
-  ([h-align v-align content]
-     (->Viewport content h-align v-align (atom viewport-initial-state))))
-
-(defn- scale-viewport [state vp s relative? x y]
-  (let [^AffineTransform tr (:transform state)
-        sx (if relative? s (/ s (.getScaleX tr)))
-        sy (if relative? s (/ s (.getScaleY tr)))
-        x (or x (align-x (:h-align vp) (:last-width state)))
-        y (or y (align-y (:v-align vp) (:last-height state)))
-        x (- x (* x sx))
-        y (- y (* y sy))
-        scaled (doto (AffineTransform/getTranslateInstance x y)
-                 (.scale sx sy)
-                 (.concatenate tr))
-        sx (.getScaleX scaled)
-        sy (.getScaleY scaled)]
-    (if (<= *viewport-min-scale*
-            (min sx sy)
-            (max sx sy)
-            *viewport-max-scale*)
-      (assoc state
-        :transform scaled)
-      state)))
-
-(defn scale-viewport!
-  ([viewport s]
-     (scale-viewport! viewport s true))
-  ([viewport s relative?]
-     (scale-viewport! viewport s relative? nil nil))
-  ([viewport s relative? x y]
-     (swap! (:state viewport) scale-viewport viewport s relative? x y)
-     (update viewport)))
-
-(defn reset-viewport! [viewport]
-  (reset! (:state viewport) viewport-initial-state)
-  (update viewport))
-
-(defn ^AffineTransform viewport-transform [viewport]
-  (:transform @(:state viewport)))
-
-(defn- scaling
-  [width height max-width max-height]
-  (min (/ max-width width)
-       (/ max-height height)))
-
-(defn miniature
-  "Creates a view that asynchronously renders the content view scaled to
-  the specified size."
-  [mw mh content]
-  (async-view
-   mw mh *miniature-thread-priority*
-   (reify
-    View
-    (render! [this]
-      (let [geom (geometry content)
-            cw (width geom)
-            ch (height geom)
-            s (scaling cw ch mw mh)]
-        (.scale *graphics* s s)
-        (draw! (align-x :center cw (/ mw s))
-               (align-y :center ch (/ mh s))
-               cw ch
-               content)))
-    (geometry [_]
-      (->Size mw mh)))))
-
-(defn viewport-miniature
-  "Creates miniature view of the viewport's contents."
-  [m-width m-height viewport]
-  (let [miniature (miniature m-width m-height (:content viewport))]
-    (decorate-view miniature [l]
-      (repaint-on-update viewport)
-      (let [geom (geometry (:content viewport))
-            s (scaling (width geom) (height geom) m-width m-height)
-            vp-state @(:state viewport)
-            {:keys [transform last-width last-height]} @(:state viewport)
-            ox (align-x :center (width geom) (/ m-width s))
-            oy (align-y :center (height geom) (/ m-height s))
-            inverse (.createInverse ^AffineTransform transform)
-            transform (doto (AffineTransform.)
-                        (.scale s s)
-                        (.translate ox oy)
-                        (.concatenate inverse))
-            move-vp (fn [state x y]
-                      (let [x (- (/ x s) ox)
-                            y (- (/ y s) oy)
-                            tr (:transform state)
-                            [x y] (transform-point tr x y)
-                            x (- x (/ (:last-width state) 2))
-                            y (- y (/ (:last-height state) 2))]
-                        (assoc state
-                          :transform (pre-translate tr (- x) (- y)))))
-            move-vp! (fn [x y]
-                       (swap! (:state viewport) move-vp x y)
-                       (update viewport))]
-        (with-color :alt-back-color
-          (.fillRect *graphics* 0 0 *width* *height*))
-        (with-transform transform
-          (with-color :back-color
-            (.fillRect *graphics* 0 0 last-width last-height)))
-        (with-handlers l
-          (draw! miniature)
-          (:mouse-pressed e (move-vp! (:x e) (:y e)))
-          (:mouse-dragged e (move-vp! (:x e) (:y e))))
-        (with-transform transform
-          (with-color :border-color
-            (.drawRect *graphics* 0 0 last-width last-height)))))))

--- a/src/net/kryshen/indyvon/views.clj	Mon Apr 14 15:37:28 2014 +0400
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,410 +0,0 @@
-;;
-;; Copyright 2010-2014 Mikhail Kryshen <mikhail@kryshen.net>
-;;
-;; This file is part of Indyvon.
-;;
-;; Indyvon is free software: you can redistribute it and/or modify it
-;; under the terms of the GNU Lesser General Public License version 3
-;; only, as published by the Free Software Foundation.
-;;
-;; Indyvon is distributed in the hope that it will be useful, but
-;; WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
-;; Lesser General Public License for more details.
-;;
-;; You should have received a copy of the GNU Lesser General Public
-;; License along with Indyvon.  If not, see
-;; <http://www.gnu.org/licenses/>.
-;;
-
-(ns net.kryshen.indyvon.views
-  "Implementations of the View protocol."
-  (:use
-   (net.kryshen.indyvon core async))
-  (:import
-   (java.awt Font Image Toolkit)
-   java.awt.image.ImageObserver
-   (java.awt.geom Area AffineTransform Rectangle2D$Double Point2D
-                  Point2D$Double)
-   (java.awt.font FontRenderContext TextLayout)
-   java.util.concurrent.TimeUnit
-   (com.google.common.cache Cache CacheBuilder CacheLoader)))
-
-(defmacro decorate-view
-  "Decorate the view replacing render! implementation."
-  [view & render-tail]
-  `(let [view# ~view]
-     (reify
-       View
-       (render! ~@render-tail)
-       (geometry [t#] (geometry view#)))))
-
-(defrecord Empty []
-  View
-  (render! [_])
-  (geometry [_]
-    (->Size 0 0)))
-
-(def empty-view (->Empty))
-
-;; TODO: change argument order for decorators, content should be the
-;; last.
-
-(defn padding
-  "Adds padding to the content view."
-  ([distance content]
-     (padding distance distance distance distance content))
-  ([top left bottom right content]
-     (if (== 0 top left bottom right)
-       content
-       (reify
-        View
-        (render! [l]
-           (draw! left top
-                  (- *width* left right)
-                  (- *height* top bottom)
-                  false
-                  content))
-        (geometry [l]
-          (->NestedGeometry (geometry content) top left bottom right))))))
-
-(defn border
-  "Adds a border to the content view."
-  ([content]
-     (border 1 content))
-  ([thickness content]
-     (border thickness 0 content))
-  ([thickness gap content]
-     (let [view (padding (+ thickness gap) content)
-           t (double thickness)]
-       (decorate-view view [_]
-         (render! view)
-         (with-color :border-color
-           (let [w (double *width*)
-                 h (double *height*)
-                 outer (Area. (Rectangle2D$Double. 0.0 0.0 w h))
-                 inner (Area. (Rectangle2D$Double. t t (- w t t) (- h t t)))]
-             (.subtract outer inner)
-             (.fill *graphics* outer)))))))
-
-;; TODO: opacity and blur.
-(defn shadow
-  "Adds a shadow to the content view."
-  ([content]
-     (shadow 1 1 content))
-  ([x-offset y-offset content]
-     (let [x (if (neg? x-offset) (- x-offset) 0)
-           y (if (neg? y-offset) (- y-offset) 0)
-           abs-x (if (neg? x-offset) (- x-offset) x-offset)
-           abs-y (if (neg? y-offset) (- y-offset) y-offset)
-           shadow-x (+ x-offset x)
-           shadow-y (+ y-offset y)]
-       (reify
-        View
-        (render! [_]
-          (let [w (- *width* abs-x)
-                h (- *height* abs-y)]
-            (with-color :shadow-color
-              (.fillRect *graphics* shadow-x shadow-y w h))
-            (draw! x y w h content)))
-        (geometry [_]
-          (->NestedGeometry (geometry content)
-                            y x shadow-y shadow-x))))))
-
-(defn panel
-  "An opaque view using theme's alt-back-color or a custom background
-  color."
-  ([content]
-     (panel :alt-back-color content))
-  ([back-color content]
-     (decorate-view content [_]
-       (with-color back-color
-         (.fill *graphics* (Rectangle2D$Double. 0.0 0.0 *width* *height*)))
-       (render! content))))
-
-(defn hbox
-  "Creates a view that draws the specified content views placing them
-   horizontally."
-  [& contents]
-  (reify
-   View
-   (render! [_]
-     (let [widths (map #(width (geometry %)) contents)
-           xs (cons 0 (reductions + widths))
-           widths-sum (last xs)
-           scale (/ *width* widths-sum)]
-       (doseq [[c w x] (map vector contents widths xs)]
-         (draw! x 0 w *height* c))))
-   (geometry [_]
-     (reduce #(->Size (+ (width %1) (width %2))
-                      (max (height %1) (height %2)))
-             (->Size 0 0)
-             (map geometry contents)))))
-
-(defn vbox
-  "Creates a view that draws the specified content views placing them
-   vertically."
-  [& contents]
-  (reify
-   View
-   (render! [_]
-     (let [heights (map #(height (geometry %)) contents)
-           ys (cons 0 (reductions + heights))
-           heights-sum (last ys)
-           scale (/ *height* heights-sum)]
-       (doseq [[c h y] (map vector contents heights ys)]
-         (draw! 0 y *width* h c))))
-   (geometry [_]
-     (reduce #(->Size (max (width %1) (width %2))
-                      (+ (height %1) (height %2)))
-             (->Size 0 0)
-             (map geometry contents)))))
-
-(defn- re-split [^java.util.regex.Pattern re s]
-  (seq (.split re s)))
-
-(def ^:private ^Cache text-layout-cache
-  (-> (CacheBuilder/newBuilder)
-      (.softValues)
-      (.expireAfterAccess (long 1) TimeUnit/SECONDS)
-      (.build)))
-
-(defn- get-text-layout
-  [^String line ^Font font ^FontRenderContext font-context]
-  (.get text-layout-cache [line font font-context]
-        #(TextLayout. line font font-context)))
-
-(defn- layout-text
-  [lines font font-context]
-  (map #(get-text-layout % font font-context) lines))
-
-(defn- text-width [layouts]
-  (reduce (fn [w ^TextLayout tl] (max w (.getAdvance tl))) 0 layouts))
-
-(defn- text-height [layouts]
-  (reduce (fn [w ^TextLayout tl]
-            (+ w (.getAscent tl)
-               (.getDescent tl)
-               (.getLeading tl)))
-          0 layouts))
-
-(defn label
-  "Creates a view to display multiline text."
-  ([text]
-     (label :left :top text))
-  ([h-align v-align text]
-     (let [lines (re-split #"\r\n|\n|\r|\u0085|\u2028|\u2029" (str text))]
-       (reify View
-        (render! [view]
-          (let [w *width*
-                h *height*
-                font (.getFont *graphics*)
-                layouts (layout-text lines font (font-context))
-                y (align-y v-align (text-height layouts) h)]
-            (loop [layouts layouts, y y]
-              (when-first [^TextLayout layout layouts]
-                (let [ascent (.getAscent layout)
-                      lh (+ ascent (.getDescent layout) (.getLeading layout))
-                      x (align-x h-align (.getAdvance layout) w)]
-                  (.draw layout *graphics* x (+ y ascent))
-                  (recur (next layouts) (+ y lh)))))))
-        (geometry [view]
-          (let [layouts (layout-text lines (:font *theme*) (font-context))
-                w (text-width layouts)
-                h (text-height layouts)]
-            (->Size w h)))))))
-
-(defn- ^ImageObserver image-observer [view]
-  (reify
-   ImageObserver
-   (imageUpdate [this img infoflags x y width height]
-     (update view)
-     (zero? (bit-and infoflags
-                     (bit-or ImageObserver/ALLBITS
-                             ImageObserver/ABORT))))))
-
-(defn image-view
-  [image-or-uri]
-  (let [^Image image (if (instance? Image image-or-uri)
-                       image-or-uri
-                       (.getImage (Toolkit/getDefaultToolkit)
-                                  ^java.net.URL image-or-uri))]
-    (.prepareImage (Toolkit/getDefaultToolkit) image -1 -1 nil)
-    (reify
-     View
-     (render! [view]
-       (repaint-on-update view)
-       (.drawImage *graphics* image 0 0 (image-observer view)))
-     (geometry [view]
-       (let [observer (image-observer view)
-             width (.getWidth image observer)
-             height (.getHeight image observer)
-             width (if (pos? width) width 1)
-             height (if (pos? height) height 1)]
-         (->Size width height))))))
-
-(def ^:dynamic *miniature-thread-priority* 2)
-
-(defn ref-view
-  [view-ref]
-  (let [l (reify
-           View
-           (render! [l]
-             (repaint-on-update l)
-             (if-let [view @view-ref]
-               (render! view)))
-           (geometry [_]
-             (if-let [view @view-ref]
-               (geometry view)
-               (->Size 1 1))))]
-    (add-watch view-ref l (fn [_ _ _ _] (update l)))
-    l))
-
-;;
-;; View context decorators
-;;
-
-(defmacro handler [view & handlers]
-  "Adds event handling to the view."
-  `(let [view# ~view]
-     (decorate-view view# [t#]
-       (with-handlers t#
-         (render! view#)
-         ~@handlers))))
-
-(defn themed [view & map-or-keyvals]
-  (let [theme (if (== (count map-or-keyvals) 1)
-                (first map-or-keyvals)
-                (apply array-map map-or-keyvals))]
-    (reify
-     View
-     (render! [_]
-       (with-theme theme
-         (render! view)))
-     (geometry [_]
-       (with-theme theme
-         (geometry view))))))
-
-(defn hinted [view & map-or-keyvals]
-  (let [hints (if (== (count map-or-keyvals) 1)
-                (first map-or-keyvals)
-                (apply array-map map-or-keyvals))]
-    (decorate-view view [_]
-      (with-hints* hints render! view))))
-
-;;
-;; Measuring time
-;;
-
-(def ^:dynamic *interval*)
-
-(defn interval-view
-  "Creates a view that measures time between repaints ant draws it's
-  content with the *interval* var bound to the measured time."
-  [content]
-  (let [last-time (atom nil)]
-    (decorate-view content [_]
-      (compare-and-set! last-time nil *time*)
-      (let [lt @last-time]
-        (binding [*interval* (if (compare-and-set! last-time lt *time*)
-                               (- *time* lt)
-                               0)] ; already measured on parallel thread
-          (render! content))))))
-
-(defn- fps-label [text]
-  (padding 5 (label :right :bottom text)))
-
-(defn fps-view
-  "Creates a view that draws content and displays the
-  frames per second rate."
-  [content]
-  (let [update-interval 2E8 ; 0.2 s in nanoseconds
-        frames (ref 0)
-        prev-time (ref nil)
-        display (ref (fps-label "fps n/a"))]
-    (decorate-view content [_]
-      (draw! content)
-      (draw!
-       (dosync
-        (alter frames inc)
-        (if @prev-time
-          (let [elapsed (- *time* @prev-time)]
-            (when (> elapsed update-interval)
-              (let [fps (/ @frames (/ elapsed 1E9))]
-                (ref-set display (fps-label (format "%.1f" fps)))
-                (ref-set frames 0)
-                (ref-set prev-time *time*))))
-          (ref-set prev-time *time*))
-        @display)))))
-
-;;
-;; Overlays
-;;
-
-(def ^:private ^:dynamic *above*)
-
-(defn- overlay* [f & args]
-  (var-set #'*above* (conj *above* (apply partial f args))))
-
-(defn- ^Point2D to-graphics-coords
-  [^AffineTransform transform x y]
-  (let [p (Point2D$Double. x y)]
-    (.transform transform p p)
-    (.transform (.createInverse (.getTransform *graphics*)) p p)
-    p))
-
-(defn- draw-relative!
-  ([transform x y view]
-     (let [p (to-graphics-coords transform x y)]
-       (draw! (.getX p) (.getY p) view)))
-  ([transform x y w h view]
-     (let [p (to-graphics-coords transform x y)]
-       (draw! (.getX p) (.getY p) w h view))))
-
-(defn- draw-relative-aligned!
-  [transform h-align v-align x y view]
-  (let [geom (geometry view)
-        w (width geom)
-        h (height geom)
-        p (to-graphics-coords transform x y)
-        x (- (.getX p) (anchor-x geom h-align w))
-        y (- (.getY p) (anchor-y geom v-align h))]
-    (draw! x y w h view)))
-
-(defn overlay!
-  "Draws view in the overlay context above the other views."
-  ([view]
-     (overlay* draw-relative! (.getTransform *graphics*) 0 0 view))
-  ([x y view]
-     (overlay* draw-relative! (.getTransform *graphics*) x y view))
-  ([x y w h view]
-     (overlay* draw-relative! (.getTransform *graphics*) x y w h view)))
-
-(defn overlay-aligned! [h-align v-align x y view]
-  (overlay* draw-relative-aligned!
-            (.getTransform *graphics*)
-            h-align v-align x y
-            view))
-
-(defn with-overlays* [rec? f & args]
-  (binding [*above* []]
-    (apply f args)
-    (if rec?
-      (loop [above *above*]
-        (when (seq above)
-          (var-set #'*above* [])
-          (doseq [f above]
-            (f))
-          (recur *above*)))
-      (doseq [of *above*]
-        (of)))))
-
-(defmacro with-overlays [rec? & body]
-  `(with-overlays* ~rec? (fn [] ~@body)))
-
-(defn layered
-  ([content]
-     (layered true content))
-  ([rec? content]
-     (decorate-view content [_]
-       (with-overlays* rec? render! content))))