1.1 --- a/src/indyvon/core.clj	Fri Sep 18 17:59:50 2015 +0300
     1.2 +++ b/src/indyvon/core.clj	Sun Sep 20 02:00:53 2015 +0300
     1.3 @@ -643,17 +643,20 @@
     1.4                                       *event-dispatcher* handle handlers)]
     1.5      (apply f args)))
     1.6  
     1.7 +(defmacro handlers [& specs]
     1.8 +  (reduce (fn [m spec]
     1.9 +            (assoc m (first spec)
    1.10 +                   `(fn [~(second spec)]
    1.11 +                      ~@(nnext spec)))) {}
    1.12 +                      specs))
    1.13 +
    1.14  (defmacro with-handlers
    1.15    "specs => (:event-id name & handler-body)*
    1.16  
    1.17    Execute form with the specified event handlers."
    1.18    [handle form & specs]
    1.19    `(with-handlers* ~handle
    1.20 -     ~(reduce (fn [m spec]
    1.21 -                (assoc m (first spec)
    1.22 -                       `(fn [~(second spec)]
    1.23 -                          ~@(nnext spec)))) {}
    1.24 -                          specs)
    1.25 +     (handlers ~@specs)
    1.26       (fn [] ~form)))
    1.27  
    1.28  (defn picked? [handle]

     2.1 --- a/src/indyvon/demo.clj	Fri Sep 18 17:59:50 2015 +0300
     2.2 +++ b/src/indyvon/demo.clj	Sun Sep 20 02:00:53 2015 +0300
     2.3 @@ -201,14 +201,15 @@
     2.4  
     2.5  ;; Main scene
     2.6  (def scene
     2.7 -  (fps-view
     2.8 -   (decorate-view vp [_]
     2.9 -     (draw! vp)
    2.10 -     (draw-aligned!
    2.11 -      (label (str "Drag mouse to pan," \newline
    2.12 -                  "use mouse wheel to zoom."))
    2.13 -      :left :bottom 5 (- *height* 5))
    2.14 -     (draw! vp-miniature (- *width* 105) 5))))
    2.15 +  (->> vp
    2.16 +       (decorator (fn [_ content]
    2.17 +                    (draw! content)
    2.18 +                    (draw-aligned!
    2.19 +                     (label (str "Drag mouse to pan," \newline
    2.20 +                                 "use mouse wheel to zoom."))
    2.21 +                     :left :bottom 5 (- *height* 5))
    2.22 +                    (draw! vp-miniature (- *width* 105) 5)))
    2.23 +       fps-view))
    2.24  
    2.25  (defn show-frame [view]
    2.26    (doto (make-jframe "Test" view)

     3.1 --- a/src/indyvon/viewport.clj	Fri Sep 18 17:59:50 2015 +0300
     3.2 +++ b/src/indyvon/viewport.clj	Sun Sep 20 02:00:53 2015 +0300
     3.3 @@ -174,65 +174,67 @@
     3.4    (min (/ max-width width)
     3.5         (/ max-height height)))
     3.6  
     3.7 +(def ^:dynamic *miniature-thread-priority* 2)
     3.8 +
     3.9  (defn miniature
    3.10    "Creates a view that asynchronously renders the content view scaled to
    3.11    the specified size."
    3.12    [mw mh content]
    3.13 -  (async-view
    3.14 -   mw mh *miniature-thread-priority*
    3.15 -   (reify
    3.16 -    View
    3.17 -    (render! [this]
    3.18 -      (let [geom (geometry content)
    3.19 -            cw (width geom)
    3.20 -            ch (height geom)
    3.21 -            s (scaling cw ch mw mh)]
    3.22 -        (.scale *graphics* s s)
    3.23 -        (draw! content
    3.24 -               (align-x :center cw (/ mw s))
    3.25 -               (align-y :center ch (/ mh s))
    3.26 -               cw ch)))
    3.27 -    (geometry [_]
    3.28 -      (->Size mw mh)))))
    3.29 +  (->> content
    3.30 +       (decorator (fn [_ content]
    3.31 +                    (let [geom (geometry content)
    3.32 +                          cw (width geom)
    3.33 +                          ch (height geom)
    3.34 +                          s (scaling cw ch mw mh)]
    3.35 +                      (.scale *graphics* s s)
    3.36 +                      (draw! content
    3.37 +                             (align-x :center cw (/ mw s))
    3.38 +                             (align-y :center ch (/ mh s))
    3.39 +                             cw ch)))
    3.40 +                  (fn [_ _]
    3.41 +                    (->Size mw mh)))  
    3.42 +       (async-view mw mh *miniature-thread-priority*)))
    3.43  
    3.44  (defn viewport-miniature
    3.45    "Creates miniature view of the viewport's contents."
    3.46    [m-width m-height viewport]
    3.47 -  (let [miniature (miniature m-width m-height (:content viewport))]
    3.48 -    (decorate-view miniature [l]
    3.49 -      (repaint-on-update! viewport)
    3.50 -      (let [geom (geometry (:content viewport))
    3.51 -            s (scaling (width geom) (height geom) m-width m-height)
    3.52 -            vp-state @(:state viewport)
    3.53 -            {:keys [transform last-width last-height]} @(:state viewport)
    3.54 -            ox (align-x :center (width geom) (/ m-width s))
    3.55 -            oy (align-y :center (height geom) (/ m-height s))
    3.56 -            inverse (.createInverse ^AffineTransform transform)
    3.57 -            transform (doto (AffineTransform.)
    3.58 -                        (.scale s s)
    3.59 -                        (.translate ox oy)
    3.60 -                        (.concatenate inverse))
    3.61 -            move-vp (fn [state x y]
    3.62 -                      (let [x (- (/ x s) ox)
    3.63 -                            y (- (/ y s) oy)
    3.64 -                            tr (:transform state)
    3.65 -                            [x y] (transform-point tr x y)
    3.66 -                            x (- x (/ (:last-width state) 2))
    3.67 -                            y (- y (/ (:last-height state) 2))]
    3.68 -                        (assoc state
    3.69 -                          :transform (pre-translate tr (- x) (- y)))))
    3.70 -            move-vp! (fn [x y]
    3.71 -                       (swap! (:state viewport) move-vp x y)
    3.72 -                       (notify! viewport))]
    3.73 -        (with-color :alt-back-color
    3.74 -          (.fillRect *graphics* 0 0 *width* *height*))
    3.75 -        (with-transform transform
    3.76 -          (with-color :back-color
    3.77 -            (.fillRect *graphics* 0 0 last-width last-height)))
    3.78 -        (with-handlers l
    3.79 -          (draw! miniature)
    3.80 -          [:mouse-pressed e (move-vp! (:x e) (:y e))]
    3.81 -          [:mouse-dragged e (move-vp! (:x e) (:y e))])
    3.82 -        (with-transform transform
    3.83 -          (with-color :border-color
    3.84 -            (.drawRect *graphics* 0 0 last-width last-height)))))))
    3.85 +  (->> (:content viewport)
    3.86 +       (miniature m-width m-height)
    3.87 +       (decorator
    3.88 +        (fn [v m]
    3.89 +          (repaint-on-update! viewport)
    3.90 +          (let [geom (geometry (:content viewport))
    3.91 +                s (scaling (width geom) (height geom) m-width m-height)
    3.92 +                vp-state @(:state viewport)
    3.93 +                {:keys [transform last-width last-height]} @(:state viewport)
    3.94 +                ox (align-x :center (width geom) (/ m-width s))
    3.95 +                oy (align-y :center (height geom) (/ m-height s))
    3.96 +                inverse (.createInverse ^AffineTransform transform)
    3.97 +                transform (doto (AffineTransform.)
    3.98 +                            (.scale s s)
    3.99 +                            (.translate ox oy)
   3.100 +                            (.concatenate inverse))
   3.101 +                move-vp (fn [state x y]
   3.102 +                          (let [x (- (/ x s) ox)
   3.103 +                                y (- (/ y s) oy)
   3.104 +                                tr (:transform state)
   3.105 +                                [x y] (transform-point tr x y)
   3.106 +                                x (- x (/ (:last-width state) 2))
   3.107 +                                y (- y (/ (:last-height state) 2))]
   3.108 +                            (assoc state
   3.109 +                                   :transform (pre-translate tr (- x) (- y)))))
   3.110 +                move-vp! (fn [x y]
   3.111 +                           (swap! (:state viewport) move-vp x y)
   3.112 +                           (notify! viewport))]
   3.113 +            (with-color :alt-back-color
   3.114 +              (.fillRect *graphics* 0 0 *width* *height*))
   3.115 +            (with-transform transform
   3.116 +              (with-color :back-color
   3.117 +                (.fillRect *graphics* 0 0 last-width last-height)))
   3.118 +            (with-handlers v
   3.119 +              (draw! m)
   3.120 +              [:mouse-pressed e (move-vp! (:x e) (:y e))]
   3.121 +              [:mouse-dragged e (move-vp! (:x e) (:y e))])
   3.122 +            (with-transform transform
   3.123 +              (with-color :border-color
   3.124 +                (.drawRect *graphics* 0 0 last-width last-height))))))))

     4.1 --- a/src/indyvon/views.clj	Fri Sep 18 17:59:50 2015 +0300
     4.2 +++ b/src/indyvon/views.clj	Sun Sep 20 02:00:53 2015 +0300
     4.3 @@ -30,14 +30,26 @@
     4.4     java.util.concurrent.TimeUnit
     4.5     (com.google.common.cache Cache CacheBuilder CacheLoader)))
     4.6  
     4.7 -(defmacro decorate-view
     4.8 -  "Decorate the view replacing render! implementation."
     4.9 -  [view & render-tail]
    4.10 -  `(let [view# ~view]
    4.11 -     (reify
    4.12 -       View
    4.13 -       (render! ~@render-tail)
    4.14 -       (geometry [t#] (geometry view#)))))
    4.15 +(defrecord Decorator [render-fn geometry-fn content]
    4.16 +  View
    4.17 +  (render! [decorator]
    4.18 +    (render-fn decorator content))
    4.19 +  (geometry [decorator]
    4.20 +    (geometry-fn decorator content)))
    4.21 +
    4.22 +(defn- decorator-content-geometry [_ content]
    4.23 +  (geometry content))
    4.24 +
    4.25 +(defn decorator
    4.26 +  "Creates a decorator view. Functions render-fn and geometry-fn will
    4.27 +  be called with the decorator and content as arguments. Use this in
    4.28 +  preference to (reify View) as it creates a defrecord instance
    4.29 +  instead of an opaque reify object. Prefer to pass render-fn and
    4.30 +  geometry-fn as Vars to allow the view to be printed and read back."
    4.31 +  ([render-fn content]
    4.32 +   (decorator render-fn #'decorator-content-geometry content))
    4.33 +  ([render-fn geometry-fn content]
    4.34 +   (->Decorator render-fn geometry-fn content)))
    4.35  
    4.36  (defrecord Empty []
    4.37    View
    4.38 @@ -47,23 +59,39 @@
    4.39  
    4.40  (def empty-view (->Empty))
    4.41  
    4.42 +(defrecord Padding [top left bottom right content]
    4.43 +  View
    4.44 +  (render! [l]
    4.45 +    (draw! content
    4.46 +           left top
    4.47 +           (- *width* left right)
    4.48 +           (- *height* top bottom)
    4.49 +           false))
    4.50 +  (geometry [l]
    4.51 +    (->NestedGeometry (geometry content) top left bottom right)))
    4.52 +
    4.53  (defn padding
    4.54    "Adds padding to the content view."
    4.55    ([distance content]
    4.56 -     (padding distance distance distance distance content))
    4.57 +   (padding distance distance distance distance content))
    4.58    ([top left bottom right content]
    4.59 -     (if (== 0 top left bottom right)
    4.60 -       content
    4.61 -       (reify
    4.62 -        View
    4.63 -        (render! [l]
    4.64 -           (draw! content
    4.65 -                  left top
    4.66 -                  (- *width* left right)
    4.67 -                  (- *height* top bottom)
    4.68 -                  false))
    4.69 -        (geometry [l]
    4.70 -          (->NestedGeometry (geometry content) top left bottom right))))))
    4.71 +   (if (== 0 top left bottom right)
    4.72 +     content
    4.73 +     (->Padding top left bottom right content))))
    4.74 +
    4.75 +(defrecord Border [^double thickness content]
    4.76 +  View
    4.77 +  (render! [_]
    4.78 +    (render! content)
    4.79 +    (with-color :border-color
    4.80 +      (let [w (double *width*)
    4.81 +            h (double *height*)
    4.82 +            t thickness
    4.83 +            outer (Area. (Rectangle2D$Double. 0.0 0.0 w h))
    4.84 +            inner (Area. (Rectangle2D$Double. t t (- w t t) (- h t t)))]
    4.85 +        (.subtract outer inner)
    4.86 +        (.fill *graphics* outer))))
    4.87 +  (geometry [_] (geometry content)))
    4.88  
    4.89  (defn border
    4.90    "Adds a border to the content view."
    4.91 @@ -72,52 +100,45 @@
    4.92    ([thickness content]
    4.93       (border thickness 0 content))
    4.94    ([thickness gap content]
    4.95 -     (let [view (padding (+ thickness gap) content)
    4.96 -           t (double thickness)]
    4.97 -       (decorate-view view [_]
    4.98 -         (render! view)
    4.99 -         (with-color :border-color
   4.100 -           (let [w (double *width*)
   4.101 -                 h (double *height*)
   4.102 -                 outer (Area. (Rectangle2D$Double. 0.0 0.0 w h))
   4.103 -                 inner (Area. (Rectangle2D$Double. t t (- w t t) (- h t t)))]
   4.104 -             (.subtract outer inner)
   4.105 -             (.fill *graphics* outer)))))))
   4.106 +   (->Border thickness (padding (+ thickness gap) content))))
   4.107  
   4.108  ;; TODO: opacity and blur.
   4.109 +(defrecord Shadow [^double x ^double y content]
   4.110 +  View
   4.111 +  (render! [_]
   4.112 +    (let [w (- *width* (Math/abs x))
   4.113 +          h (- *height* (Math/abs y))]
   4.114 +      (with-color :shadow-color
   4.115 +        (.fillRect *graphics* (max x 0.0) (max y 0.0) w h))
   4.116 +      (draw! content (max (- x) 0.0) (max (- y) 0.0) w h)))
   4.117 +  (geometry [_]
   4.118 +    (->NestedGeometry (geometry content)
   4.119 +                      (max (- y) 0.0) ;; top
   4.120 +                      (max (- x) 0.0) ;; left
   4.121 +                      (max y 0.0)     ;; bottom
   4.122 +                      (max x 0.0))))  ;; right
   4.123  (defn shadow
   4.124    "Adds a shadow to the content view."
   4.125    ([content]
   4.126 -     (shadow 1 1 content))
   4.127 +   (shadow 1 1 content))
   4.128    ([x-offset y-offset content]
   4.129 -     (let [x (if (neg? x-offset) (- x-offset) 0)
   4.130 -           y (if (neg? y-offset) (- y-offset) 0)
   4.131 -           abs-x (if (neg? x-offset) (- x-offset) x-offset)
   4.132 -           abs-y (if (neg? y-offset) (- y-offset) y-offset)
   4.133 -           shadow-x (+ x-offset x)
   4.134 -           shadow-y (+ y-offset y)]
   4.135 -       (reify
   4.136 -        View
   4.137 -        (render! [_]
   4.138 -          (let [w (- *width* abs-x)
   4.139 -                h (- *height* abs-y)]
   4.140 -            (with-color :shadow-color
   4.141 -              (.fillRect *graphics* shadow-x shadow-y w h))
   4.142 -            (draw! content x y w h)))
   4.143 -        (geometry [_]
   4.144 -          (->NestedGeometry (geometry content)
   4.145 -                            y x shadow-y shadow-x))))))
   4.146 +   (->Shadow x-offset y-offset content)))
   4.147 +
   4.148 +(defrecord Panel [back-color content]
   4.149 +  View
   4.150 +  (render! [_]
   4.151 +    (with-color back-color
   4.152 +      (.fill *graphics* (Rectangle2D$Double. 0.0 0.0 *width* *height*)))
   4.153 +    (render! content))
   4.154 +  (geometry [_] (geometry content)))
   4.155  
   4.156  (defn panel
   4.157    "An opaque view using theme's alt-back-color or a custom background
   4.158    color."
   4.159    ([content]
   4.160 -     (panel :alt-back-color content))
   4.161 +   (panel :alt-back-color content))
   4.162    ([back-color content]
   4.163 -     (decorate-view content [_]
   4.164 -       (with-color back-color
   4.165 -         (.fill *graphics* (Rectangle2D$Double. 0.0 0.0 *width* *height*)))
   4.166 -       (render! content))))
   4.167 +   (->Panel back-color content)))
   4.168  
   4.169  (defrecord Box [proportional? translate-geometry contents]
   4.170    View
   4.171 @@ -242,40 +263,53 @@
   4.172                 (.getLeading tl)))
   4.173            0 layouts))
   4.174  
   4.175 +(defrecord Label [h-align v-align lines]
   4.176 +  View
   4.177 +  (render! [view]
   4.178 +    (let [w *width*
   4.179 +          h *height*
   4.180 +          font (.getFont *graphics*)
   4.181 +          layouts (layout-text lines font (font-context))
   4.182 +          y (align-y v-align (text-height layouts) h)]
   4.183 +      (loop [layouts layouts, y y]
   4.184 +        (when-first [^TextLayout layout layouts]
   4.185 +          (let [ascent (.getAscent layout)
   4.186 +                lh (+ ascent (.getDescent layout) (.getLeading layout))
   4.187 +                x (align-x h-align (.getAdvance layout) w)]
   4.188 +            (.draw layout *graphics* x (+ y ascent))
   4.189 +            (recur (next layouts) (+ y lh)))))))
   4.190 +  (geometry [view]
   4.191 +    (let [layouts (layout-text lines (theme-get :font) (font-context))
   4.192 +          w (text-width layouts)
   4.193 +          h (text-height layouts)]
   4.194 +      (->Size w h))))
   4.195 +
   4.196  (defn label
   4.197    "Creates a view to display multiline text."
   4.198    ([text]
   4.199 -     (label :left :top text))
   4.200 +   (label :left :top text))
   4.201    ([h-align v-align text]
   4.202 -     (let [lines (re-split #"\r\n|\n|\r|\u0085|\u2028|\u2029" (str text))]
   4.203 -       (reify View
   4.204 -        (render! [view]
   4.205 -          (let [w *width*
   4.206 -                h *height*
   4.207 -                font (.getFont *graphics*)
   4.208 -                layouts (layout-text lines font (font-context))
   4.209 -                y (align-y v-align (text-height layouts) h)]
   4.210 -            (loop [layouts layouts, y y]
   4.211 -              (when-first [^TextLayout layout layouts]
   4.212 -                (let [ascent (.getAscent layout)
   4.213 -                      lh (+ ascent (.getDescent layout) (.getLeading layout))
   4.214 -                      x (align-x h-align (.getAdvance layout) w)]
   4.215 -                  (.draw layout *graphics* x (+ y ascent))
   4.216 -                  (recur (next layouts) (+ y lh)))))))
   4.217 -        (geometry [view]
   4.218 -          (let [layouts (layout-text lines (theme-get :font) (font-context))
   4.219 -                w (text-width layouts)
   4.220 -                h (text-height layouts)]
   4.221 -            (->Size w h)))))))
   4.222 +   (->Label h-align
   4.223 +            v-align
   4.224 +            (re-split #"\r\n|\n|\r|\u0085|\u2028|\u2029" (str text)))))
   4.225  
   4.226 -(defn- ^ImageObserver image-observer [view]
   4.227 -  (reify
   4.228 -   ImageObserver
   4.229 -   (imageUpdate [this img infoflags x y width height]
   4.230 -     (notify! view)
   4.231 -     (zero? (bit-and infoflags
   4.232 -                     (bit-or ImageObserver/ALLBITS
   4.233 -                             ImageObserver/ABORT))))))
   4.234 +(defrecord ImageView [^Image image]
   4.235 +  View
   4.236 +  (render! [view]
   4.237 +    (repaint-on-update! view)
   4.238 +    (.drawImage *graphics* image 0 0 view))
   4.239 +  (geometry [view]
   4.240 +    (let [width (.getWidth image view)
   4.241 +          height (.getHeight image view)
   4.242 +          width (if (pos? width) width 1)
   4.243 +          height (if (pos? height) height 1)]
   4.244 +      (->Size width height)))
   4.245 +  ImageObserver
   4.246 +  (imageUpdate [view img infoflags x y width height]
   4.247 +    (notify! view)
   4.248 +    (zero? (bit-and infoflags
   4.249 +                    (bit-or ImageObserver/ALLBITS
   4.250 +                            ImageObserver/ABORT)))))
   4.251  
   4.252  (defn image-view
   4.253    [image-or-uri]
   4.254 @@ -284,93 +318,97 @@
   4.255                         (.getImage (Toolkit/getDefaultToolkit)
   4.256                                    ^java.net.URL image-or-uri))]
   4.257      (.prepareImage (Toolkit/getDefaultToolkit) image -1 -1 nil)
   4.258 -    (reify
   4.259 -     View
   4.260 -     (render! [view]
   4.261 -       (repaint-on-update! view)
   4.262 -       (.drawImage *graphics* image 0 0 (image-observer view)))
   4.263 -     (geometry [view]
   4.264 -       (let [observer (image-observer view)
   4.265 -             width (.getWidth image observer)
   4.266 -             height (.getHeight image observer)
   4.267 -             width (if (pos? width) width 1)
   4.268 -             height (if (pos? height) height 1)]
   4.269 -         (->Size width height))))))
   4.270 +    (->ImageView image)))
   4.271  
   4.272 -(def ^:dynamic *miniature-thread-priority* 2)
   4.273 +(defrecord RefView [reference view-delay-atom]
   4.274 +  View
   4.275 +  (render! [v]
   4.276 +    (repaint-on-update! v)
   4.277 +    (when-let [view @@view-delay-atom]
   4.278 +      (render! view)))
   4.279 +  (geometry [v]
   4.280 +    (if-let [view @@view-delay-atom]
   4.281 +      (geometry view)
   4.282 +      (->Size 1 1))))
   4.283  
   4.284  (defn ref-view
   4.285 -  ([view-ref]
   4.286 -   (ref-view view-ref identity))
   4.287 -  ([view-ref view-fn]
   4.288 -   (let [v (reify
   4.289 -             View
   4.290 -             (render! [v]
   4.291 -               (repaint-on-update! v)
   4.292 -               (when-let [view (view-fn @view-ref)]
   4.293 -                 (render! view)))
   4.294 -             (geometry [_]
   4.295 -               (if-let [view (view-fn @view-ref)]
   4.296 -                 (geometry view)
   4.297 -                 (->Size 1 1))))]
   4.298 -     (add-watch view-ref v (fn [_ _ _ _] (notify! v)))
   4.299 +  ([reference]
   4.300 +   (ref-view reference #'identity))
   4.301 +  ([reference view-fn]
   4.302 +   ;; The reference may update multiple times before repaint happens,
   4.303 +   ;; delay is used to avoid unnecessary invocations of view-fn.
   4.304 +   (let [view-delay-atom (atom (delay (view-fn @reference)))
   4.305 +         v (->RefView reference view-delay-atom)]
   4.306 +     (add-watch reference v (fn [_ _ _ n]
   4.307 +                              (reset! view-delay-atom (delay (view-fn n)))
   4.308 +                              (notify! v)))
   4.309       v)))
   4.310  
   4.311  ;;
   4.312  ;; View context decorators
   4.313  ;;
   4.314  
   4.315 -(defmacro add-handlers [view & handlers]
   4.316 +(defrecord Active [handlers content]
   4.317 +  View
   4.318 +  (render! [v]
   4.319 +    (with-handlers* v handlers render! content))
   4.320 +  (geometry [_]
   4.321 +    (geometry content)))
   4.322 +
   4.323 +(defmacro add-handlers [view & event-handlers]
   4.324    "Adds event handling to the view."
   4.325 -  `(let [view# ~view]
   4.326 -     (decorate-view view# [t#]
   4.327 -       (with-handlers t#
   4.328 -         (render! view#)
   4.329 -         ~@handlers))))
   4.330 +  `(->Active (handlers ~@event-handlers) ~view))
   4.331 +
   4.332 +(defrecord Themed [theme view]
   4.333 +  View
   4.334 +  (render! [_]
   4.335 +    (with-theme theme
   4.336 +      (apply-theme)
   4.337 +      (render! view)))
   4.338 +  (geometry [_]
   4.339 +    (with-theme* theme geometry view)))
   4.340  
   4.341  (defn themed [theme view]
   4.342 -  (reify
   4.343 -    View
   4.344 -    (render! [_]
   4.345 -      (with-theme theme
   4.346 -        (apply-theme)
   4.347 -        (render! view)))
   4.348 -    (geometry [_]
   4.349 -      (with-theme* theme geometry view))))
   4.350 +  (->Themed theme view))
   4.351 +
   4.352 +(defrecord Hinted [hints view]
   4.353 +  View
   4.354 +  (render! [_]
   4.355 +    (with-hints* hints render! view))
   4.356 +  (geometry [_]
   4.357 +    (if (bound? #'*graphics*)
   4.358 +      (with-hints* hints geometry view)
   4.359 +      (geometry view))))
   4.360  
   4.361  (defn hinted [hints view]
   4.362 -  (reify
   4.363 -    View
   4.364 -    (render! [_]
   4.365 -      (with-hints* hints render! view))
   4.366 -    (geometry [_]
   4.367 -      (if (bound? #'*graphics*)
   4.368 -        (with-hints* hints geometry view)
   4.369 -        (geometry view)))))
   4.370 +  (->Hinted hints view))
   4.371  
   4.372  (defn- transform-bounds
   4.373    ^Rectangle2D [^AffineTransform tr ^double w ^double h]
   4.374    (.getBounds2D
   4.375     (.createTransformedShape tr (Rectangle2D$Double. 0 0 w h))))
   4.376  
   4.377 +(defrecord Transform [transform view]
   4.378 +  View
   4.379 +  (render! [v]
   4.380 +    (let [g (geometry view)
   4.381 +          w (double (width g))
   4.382 +          h (double (height g))
   4.383 +          ^Rectangle2D bounds (transform-bounds transform w h)
   4.384 +          g *graphics*]
   4.385 +      (.translate g (- (.getX bounds)) (- (.getY bounds)))
   4.386 +      (.transform g transform)
   4.387 +      ;; TODO: scale w and h to fit *width* and *height*.
   4.388 +      (draw! view 0 0 w h)))
   4.389 +  (geometry [_]
   4.390 +    (let [g (geometry view)
   4.391 +          w (double (width g))
   4.392 +          h (double (height g))
   4.393 +          ^Rectangle2D bounds (transform-bounds transform w h)]
   4.394 +      (->Size (.getWidth bounds) (.getHeight bounds)))))
   4.395 +
   4.396  (defn transform [tr view]
   4.397 -  (reify View
   4.398 -    (render! [v]
   4.399 -      (let [g (geometry view)
   4.400 -            w (double (width g))
   4.401 -            h (double (height g))
   4.402 -            ^Rectangle2D bounds (transform-bounds tr w h)
   4.403 -            g *graphics*]
   4.404 -        (.translate g (- (.getX bounds)) (- (.getY bounds)))
   4.405 -        (.transform g tr)
   4.406 -        ;; TODO: scale w and h to fit *width* and *height*.
   4.407 -        (draw! view 0 0 w h)))
   4.408 -    (geometry [_]
   4.409 -      (let [g (geometry view)
   4.410 -            w (double (width g))
   4.411 -            h (double (height g))
   4.412 -            ^Rectangle2D bounds (transform-bounds tr w h)]
   4.413 -        (->Size (.getWidth bounds) (.getHeight bounds))))))
   4.414 +  (->Transform tr view))
   4.415  
   4.416  (defn rotate [^double degrees view]
   4.417    (transform
   4.418 @@ -383,44 +421,51 @@
   4.419  
   4.420  (def ^:dynamic *interval*)
   4.421  
   4.422 +(defrecord IntervalView [last-time content]
   4.423 +  View
   4.424 +  (render! [_]
   4.425 +    (compare-and-set! last-time nil *time*)
   4.426 +    (let [lt @last-time]
   4.427 +      (binding [*interval* (if (compare-and-set! last-time lt *time*)
   4.428 +                             (- *time* lt)
   4.429 +                             0)] ; already measured on parallel thread
   4.430 +        (render! content))))
   4.431 +  (geometry [_]
   4.432 +    (geometry content)))
   4.433 +
   4.434  (defn interval-view
   4.435 -  "Creates a view that measures time between repaints ant draws it's
   4.436 +  "Creates a view that measures time between repaints and draws it's
   4.437    content with the *interval* var bound to the measured time."
   4.438    [content]
   4.439 -  (let [last-time (atom nil)]
   4.440 -    (decorate-view content [_]
   4.441 -      (compare-and-set! last-time nil *time*)
   4.442 -      (let [lt @last-time]
   4.443 -        (binding [*interval* (if (compare-and-set! last-time lt *time*)
   4.444 -                               (- *time* lt)
   4.445 -                               0)] ; already measured on parallel thread
   4.446 -          (render! content))))))
   4.447 +  (->IntervalView (atom nil) content))
   4.448  
   4.449  (defn- fps-label [text]
   4.450    (padding 5 (label :right :bottom text)))
   4.451  
   4.452 +(defrecord FPSView [update-interval frames prev-time display content]
   4.453 +  View
   4.454 +  (render! [_]
   4.455 +    (draw! content)
   4.456 +    (draw!
   4.457 +     (dosync
   4.458 +      (alter frames inc)
   4.459 +      (if @prev-time
   4.460 +        (let [elapsed (- *time* @prev-time)]
   4.461 +          (when (> elapsed update-interval)
   4.462 +            (let [fps (/ @frames (/ elapsed 1E9))]
   4.463 +              (ref-set display (fps-label (format "%.1f" fps)))
   4.464 +              (ref-set frames 0)
   4.465 +              (ref-set prev-time *time*))))
   4.466 +        (ref-set prev-time *time*))
   4.467 +      @display)))
   4.468 +  (geometry [_] (geometry content)))
   4.469 +
   4.470  (defn fps-view
   4.471    "Creates a view that draws content and displays the
   4.472    frames per second rate."
   4.473    [content]
   4.474 -  (let [update-interval 2E8 ; 0.2 s in nanoseconds
   4.475 -        frames (ref 0)
   4.476 -        prev-time (ref nil)
   4.477 -        display (ref (fps-label "fps n/a"))]
   4.478 -    (decorate-view content [_]
   4.479 -      (draw! content)
   4.480 -      (draw!
   4.481 -       (dosync
   4.482 -        (alter frames inc)
   4.483 -        (if @prev-time
   4.484 -          (let [elapsed (- *time* @prev-time)]
   4.485 -            (when (> elapsed update-interval)
   4.486 -              (let [fps (/ @frames (/ elapsed 1E9))]
   4.487 -                (ref-set display (fps-label (format "%.1f" fps)))
   4.488 -                (ref-set frames 0)
   4.489 -                (ref-set prev-time *time*))))
   4.490 -          (ref-set prev-time *time*))
   4.491 -        @display)))))
   4.492 +  ;; 2E8 ns = 0.2 s.
   4.493 +  (->FPSView 2E8 (ref 0) (ref nil) (ref (fps-label "fps n/a")) content))
   4.494  
   4.495  ;;
   4.496  ;; Overlays
   4.497 @@ -457,7 +502,7 @@
   4.498      (draw! view x y w h)))
   4.499  
   4.500  (defn overlay!
   4.501 -  "Draws view in the overlay context above the other views."
   4.502 +  "Draws view in the overlay context above the current layer."
   4.503    ([view]
   4.504       (overlay* draw-relative! view (.getTransform *graphics*) 0 0))
   4.505    ([view x y]
   4.506 @@ -488,9 +533,16 @@
   4.507  (defmacro with-overlays [recursive? & body]
   4.508    `(with-overlays* ~recursive? (fn [] ~@body)))
   4.509  
   4.510 +(defrecord Layered [recursive? content]
   4.511 +  View
   4.512 +  (render! [_]
   4.513 +    (with-overlays* recursive? render! content))
   4.514 +  (geometry [_ ]
   4.515 +    (geometry content)))
   4.516 +
   4.517  (defn layered
   4.518 +  "Allows content view to display pop-ups on top of itself."
   4.519    ([content]
   4.520 -     (layered true content))
   4.521 +   (layered true content))
   4.522    ([recursive? content]
   4.523 -     (decorate-view content [_]
   4.524 -       (with-overlays* recursive? render! content))))
   4.525 +   (->Layered recursive? content)))