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

     2.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     2.2 +++ b/src/indyvon/async.clj	Mon Apr 14 20:01:00 2014 +0400
     2.3 @@ -0,0 +1,178 @@
     2.4 +;;
     2.5 +;; Copyright 2010-2014 Mikhail Kryshen <mikhail@kryshen.net>
     2.6 +;;
     2.7 +;; This file is part of Indyvon.
     2.8 +;;
     2.9 +;; Indyvon is free software: you can redistribute it and/or modify it
    2.10 +;; under the terms of the GNU Lesser General Public License version 3
    2.11 +;; only, as published by the Free Software Foundation.
    2.12 +;;
    2.13 +;; Indyvon is distributed in the hope that it will be useful, but
    2.14 +;; WITHOUT ANY WARRANTY; without even the implied warranty of
    2.15 +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
    2.16 +;; Lesser General Public License for more details.
    2.17 +;;
    2.18 +;; You should have received a copy of the GNU Lesser General Public
    2.19 +;; License along with Indyvon.  If not, see
    2.20 +;; <http://www.gnu.org/licenses/>.
    2.21 +;;
    2.22 +
    2.23 +(ns indyvon.async
    2.24 +  "Asynchronous drawing."
    2.25 +  (:use
    2.26 +   indyvon.core)
    2.27 +  (:import
    2.28 +   java.awt.GraphicsConfiguration
    2.29 +   (java.awt Image AlphaComposite Transparency)
    2.30 +   (java.awt.image BufferedImage)
    2.31 +   (java.util.concurrent ThreadFactory ThreadPoolExecutor
    2.32 +                         ThreadPoolExecutor$DiscardOldestPolicy
    2.33 +                         ArrayBlockingQueue TimeUnit)))
    2.34 +
    2.35 +(defrecord Buffer [id image readers state])
    2.36 +;; Buffer states:
    2.37 +;;   :front, readers > 0
    2.38 +;;      being copied on screen
    2.39 +;;   :back
    2.40 +;;      being rendered to (offscreen)
    2.41 +;;   :fresh
    2.42 +;;      most recently updated
    2.43 +;;   :free
    2.44 +;;      not in use
    2.45 +
    2.46 +(defn- create-image [async-view ^GraphicsConfiguration device-conf]
    2.47 +  ;; TODO: support different image types.
    2.48 +  (.createCompatibleImage device-conf
    2.49 +                          (:width async-view)
    2.50 +                          (:height async-view)
    2.51 +                          Transparency/TRANSLUCENT))
    2.52 +
    2.53 +(defn- create-buffer [async-view device-conf]
    2.54 +  (Buffer. (Object.) (create-image async-view device-conf) 0 :free))
    2.55 +
    2.56 +(defn- find-buffer
    2.57 +  "Find a buffer with the one of the specified states given
    2.58 +   in the order of preference."
    2.59 +  [buffers & states]
    2.60 +  (some identity
    2.61 +    (for [state states]
    2.62 +      (some #(if (= (:state %) state) % nil) buffers))))
    2.63 +
    2.64 +(defn- replace-buffer [buffers buffer]
    2.65 +  (conj (remove #(= (:id %) (:id buffer)) buffers)
    2.66 +        buffer))
    2.67 +
    2.68 +(defn- take-buffer [al type]
    2.69 +  (dosync
    2.70 +   (let [buffers @(:buffers al)
    2.71 +         b (case type
    2.72 +             :front (find-buffer buffers :front :fresh :free)
    2.73 +             :back (find-buffer buffers :free :fresh)
    2.74 +             (throw (IllegalArgumentException.)))
    2.75 +         readers (if (= type :front)
    2.76 +                   (inc (:readers b))
    2.77 +                   (:readers b))
    2.78 +         b (assoc b
    2.79 +             :state type
    2.80 +             :readers readers)]
    2.81 +     (alter (:buffers al) replace-buffer b)
    2.82 +     b)))
    2.83 +
    2.84 +(defn- release-buffer [al buffer]
    2.85 +  (dosync
    2.86 +   (let [state (:state buffer)
    2.87 +         readers (if (= state :front)
    2.88 +                   (dec (:readers buffer))
    2.89 +                   (:readers buffer))
    2.90 +         fresh (delay (find-buffer @(:buffers al) :fresh))
    2.91 +         state (cond
    2.92 +                (pos? readers) :front
    2.93 +                (= :back state) :fresh
    2.94 +                @fresh :free
    2.95 +                :default :fresh)]
    2.96 +     (if (and (= state :fresh) @fresh)
    2.97 +       ;; Change state of the prefiously fresh buffer to :free.
    2.98 +       (alter (:buffers al)
    2.99 +              replace-buffer (assoc @fresh
   2.100 +                               :state :free)))
   2.101 +     (alter (:buffers al)
   2.102 +            replace-buffer (assoc buffer
   2.103 +                             :state state
   2.104 +                             :readers readers)))))
   2.105 +
   2.106 +(defmacro with-buffer
   2.107 +  {:private true}
   2.108 +  [al type [name] & body]
   2.109 +  `(let [al# ~al
   2.110 +         ~name (take-buffer al# ~type)]
   2.111 +     (try
   2.112 +       ~@body
   2.113 +       (finally
   2.114 +        (release-buffer al# ~name)))))
   2.115 +
   2.116 +(defn- draw-offscreen [async-view]
   2.117 +  ;;(Thread/sleep 1000)
   2.118 +  (with-buffer async-view :back [b]
   2.119 +    (let [g (.createGraphics ^BufferedImage (:image b))]
   2.120 +      ;; Clear the buffer.
   2.121 +      (.setComposite g AlphaComposite/Clear)
   2.122 +      (.fillRect g 0 0 (:width async-view) (:height async-view))
   2.123 +      (.setComposite g AlphaComposite/Src)
   2.124 +      (draw-scene! (:scene async-view)
   2.125 +                   g
   2.126 +                   (:width async-view)
   2.127 +                   (:height async-view)))
   2.128 +    (update async-view)))
   2.129 +
   2.130 +(defn- draw-offscreen-async [async-view]
   2.131 +  (.execute ^ThreadPoolExecutor (:executor async-view)
   2.132 +            #(draw-offscreen async-view)))
   2.133 +
   2.134 +(defrecord AsyncView [scene width height executor buffers]
   2.135 +  View
   2.136 +  (render! [view]
   2.137 +    (repaint-on-update view)
   2.138 +    (add-context-observer scene (fn [_ _] (draw-offscreen-async view)))
   2.139 +    (when-not @buffers
   2.140 +      ;; TODO: dynamic size, recreate buffers when size increases.
   2.141 +      (let [device-conf (.getDeviceConfiguration *graphics*)
   2.142 +            new-buffers (repeatedly 2
   2.143 +                          (partial create-buffer view device-conf))]
   2.144 +        (dosync
   2.145 +         (ref-set buffers new-buffers)))
   2.146 +      (draw-offscreen-async view))
   2.147 +    (with-buffer view :front [b]
   2.148 +      (.drawImage *graphics* ^Image (:image b) 0 0 nil)))
   2.149 +  (geometry [view]
   2.150 +    (->Size width height)))
   2.151 +
   2.152 +(defn- create-thread-factory [priority]
   2.153 +  (reify
   2.154 +   ThreadFactory
   2.155 +   (newThread [_ runnable]
   2.156 +     (let [thread (Thread. runnable)]
   2.157 +       (when priority
   2.158 +         (.setPriority thread priority))
   2.159 +       (.setDaemon thread true)
   2.160 +       thread))))
   2.161 +
   2.162 +(defn- create-executor [priority]
   2.163 +  (doto (ThreadPoolExecutor.
   2.164 +         (int 1) (int 1)
   2.165 +         (long 0) TimeUnit/SECONDS
   2.166 +         (ArrayBlockingQueue. 1)
   2.167 +         (ThreadPoolExecutor$DiscardOldestPolicy.))
   2.168 +    (.setThreadFactory (create-thread-factory priority))))
   2.169 +
   2.170 +(defn async-view 
   2.171 +  "Creates a View that draws the content asynchronously using an
   2.172 +   offscreen buffer."
   2.173 +  ([width height content]
   2.174 +     (async-view width height nil content))
   2.175 +  ([width height priority content]
   2.176 +     ;; TODO: use operational event dispatcher.
   2.177 +     (->AsyncView (make-scene content)
   2.178 +                  width
   2.179 +                  height
   2.180 +                  (create-executor priority)
   2.181 +                  (ref nil))))

     3.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     3.2 +++ b/src/indyvon/component.clj	Mon Apr 14 20:01:00 2014 +0400
     3.3 @@ -0,0 +1,69 @@
     3.4 +;;
     3.5 +;; Copyright 2010-2014 Mikhail Kryshen <mikhail@kryshen.net>
     3.6 +;;
     3.7 +;; This file is part of Indyvon.
     3.8 +;;
     3.9 +;; Indyvon is free software: you can redistribute it and/or modify it
    3.10 +;; under the terms of the GNU Lesser General Public License version 3
    3.11 +;; only, as published by the Free Software Foundation.
    3.12 +;;
    3.13 +;; Indyvon is distributed in the hope that it will be useful, but
    3.14 +;; WITHOUT ANY WARRANTY; without even the implied warranty of
    3.15 +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
    3.16 +;; Lesser General Public License for more details.
    3.17 +;;
    3.18 +;; You should have received a copy of the GNU Lesser General Public
    3.19 +;; License along with Indyvon.  If not, see
    3.20 +;; <http://www.gnu.org/licenses/>.
    3.21 +;;
    3.22 +
    3.23 +(ns indyvon.component
    3.24 +  "Integrating Indyvon into AWT and Swing components."
    3.25 +  (:use
    3.26 +   indyvon.core)
    3.27 +  (:import
    3.28 +   (java.awt Graphics Component Dimension Color)
    3.29 +   (java.awt.geom Rectangle2D$Double)
    3.30 +   (javax.swing JFrame JPanel JOptionPane)))
    3.31 +
    3.32 +(defn- paint-component [^Component c ^Graphics g scene]
    3.33 +  (let [w (.getWidth c)
    3.34 +        h (.getHeight c)]
    3.35 +    (.setColor g (:back-color *theme*))
    3.36 +    (.fillRect g 0 0 w h)
    3.37 +    (draw-scene! scene g w h)))
    3.38 +
    3.39 +(defn- preferred-size [^Component c scene]
    3.40 +  (let [geom (scene-geometry scene)]
    3.41 +    (Dimension. (width geom) (height geom))))
    3.42 +
    3.43 +(defn ^JPanel make-jpanel
    3.44 +  ([view]
    3.45 +     (make-jpanel view (root-event-dispatcher)))
    3.46 +  ([view event-dispatcher]
    3.47 +     (let [panel (proxy [JPanel] [])
    3.48 +           scene (make-scene
    3.49 +                  view event-dispatcher panel
    3.50 +                  (.getDesktopProperty (java.awt.Toolkit/getDefaultToolkit)
    3.51 +                                       "awt.font.desktophints"))]
    3.52 +       (update-proxy
    3.53 +        panel
    3.54 +        {"paintComponent" #(paint-component %1 %2 scene)
    3.55 +         "getPreferredSize" #(preferred-size % scene)})
    3.56 +       (.setBackground panel (:back-color *theme*))
    3.57 +       (add-observer panel scene (fn [w _]
    3.58 +                                   ;; Use the first observer argument
    3.59 +                                   ;; instead of closing over panel to
    3.60 +                                   ;; allow the panel and associated
    3.61 +                                   ;; observer to be gc'd.
    3.62 +                                   (.repaint ^Component w)))
    3.63 +       (listen! event-dispatcher panel)
    3.64 +       panel)))
    3.65 +
    3.66 +(defn ^JFrame make-jframe [^String title view]
    3.67 +  (doto (JFrame. title)
    3.68 +    (.. (getContentPane) (add (make-jpanel view)))
    3.69 +    (.pack)))
    3.70 +
    3.71 +(defn message [m]
    3.72 +  (JOptionPane/showMessageDialog (:component *scene*) m))

     4.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     4.2 +++ b/src/indyvon/core.clj	Mon Apr 14 20:01:00 2014 +0400
     4.3 @@ -0,0 +1,881 @@
     4.4 +;;
     4.5 +;; Copyright 2010-2014 Mikhail Kryshen <mikhail@kryshen.net>
     4.6 +;;
     4.7 +;; This file is part of Indyvon.
     4.8 +;;
     4.9 +;; Indyvon is free software: you can redistribute it and/or modify it
    4.10 +;; under the terms of the GNU Lesser General Public License version 3
    4.11 +;; only, as published by the Free Software Foundation.
    4.12 +;;
    4.13 +;; Indyvon is distributed in the hope that it will be useful, but
    4.14 +;; WITHOUT ANY WARRANTY; without even the implied warranty of
    4.15 +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
    4.16 +;; Lesser General Public License for more details.
    4.17 +;;
    4.18 +;; You should have received a copy of the GNU Lesser General Public
    4.19 +;; License along with Indyvon.  If not, see
    4.20 +;; <http://www.gnu.org/licenses/>.
    4.21 +;;
    4.22 +
    4.23 +(ns indyvon.core
    4.24 +  (:import
    4.25 +   (java.awt Graphics2D RenderingHints Component Color Font Shape
    4.26 +             Rectangle Cursor EventQueue)
    4.27 +   (java.awt.geom AffineTransform Point2D$Double Rectangle2D$Double Area)
    4.28 +   (java.awt.event MouseListener MouseMotionListener
    4.29 +                   MouseWheelListener MouseWheelEvent)
    4.30 +   (java.awt.font FontRenderContext)
    4.31 +   java.util.concurrent.ConcurrentMap
    4.32 +   com.google.common.collect.MapMaker))
    4.33 +
    4.34 +;;
    4.35 +;; View context
    4.36 +;;
    4.37 +
    4.38 +(def ^:dynamic ^Graphics2D *graphics*)
    4.39 +
    4.40 +(def ^:dynamic ^FontRenderContext *font-context*
    4.41 +  "FontRenderContext to use when Graphics2D is not available."
    4.42 +  (FontRenderContext.
    4.43 +   nil
    4.44 +   RenderingHints/VALUE_TEXT_ANTIALIAS_DEFAULT
    4.45 +   RenderingHints/VALUE_FRACTIONALMETRICS_DEFAULT))
    4.46 +
    4.47 +(def ^:dynamic *width*
    4.48 +  "Width of the rendering area.")
    4.49 +
    4.50 +(def ^:dynamic *height*
    4.51 +  "Height of the rendering area.")
    4.52 +
    4.53 +(def ^:dynamic ^Shape *clip*)
    4.54 +
    4.55 +(def ^:dynamic ^Shape *input-clip*
    4.56 +  "Clipping area used for dispatching pointer events (intersected with
    4.57 +  *clip*). If nil, *clip* will be used.")
    4.58 +
    4.59 +(def ^:dynamic *time*
    4.60 +  "Timestamp of the current frame (in nanoseconds).")
    4.61 +
    4.62 +(def ^:dynamic *scene*
    4.63 +  "Encloses state that should be retained between repaints.")
    4.64 +
    4.65 +(def ^:dynamic *states*
    4.66 +  "Transient scene states, a map.")
    4.67 +
    4.68 +(def ^:dynamic *event-dispatcher*)
    4.69 +
    4.70 +(def ^:dynamic ^AffineTransform *initial-transform*
    4.71 +  "Initial transform associated with the graphics context.")
    4.72 +
    4.73 +(def ^:dynamic ^AffineTransform *inverse-initial-transform*
    4.74 +  "Inversion of the initial transform associated with the graphics
    4.75 +  context.")
    4.76 +
    4.77 +(defrecord Theme [fore-color back-color alt-back-color border-color
    4.78 +                  shadow-color font])
    4.79 +
    4.80 +;; REMIND: use system colors, see java.awt.SystemColor.
    4.81 +(defn default-theme []
    4.82 +  (Theme. Color/BLACK
    4.83 +          Color/WHITE
    4.84 +          (Color. 0xDD 0xDD 0xDD)
    4.85 +          (Color. 0 0 0xCC)
    4.86 +          (Color. 0x44 0x44 0x44)
    4.87 +          (Font. "Sans" Font/PLAIN 12)))
    4.88 +
    4.89 +(def ^:dynamic *theme* (default-theme))
    4.90 +
    4.91 +;;
    4.92 +;; Core protocols and types
    4.93 +;;
    4.94 +
    4.95 +(defprotocol View
    4.96 +  "Basic UI element."
    4.97 +  (render! [view]
    4.98 +    "Draws the view in the current *graphics* context.")
    4.99 +  (geometry [view]
   4.100 +    "Returns the preferred Geometry for the view."))
   4.101 +
   4.102 +(defprotocol Geometry
   4.103 +  "Describes geometry of a View.  Prefer using the available
   4.104 +  implementations (Size, FixedGeometry and NestedGeometry) over
   4.105 +  extending this protocol directly as it is likely to be changed in
   4.106 +  the future versions."
   4.107 +  (width [geom] [geom height])
   4.108 +  (height [geom] [geom width])
   4.109 +  (anchor-x [geom h-align width]
   4.110 +    "Returns the x coordinate of the anchor point for the specified
   4.111 +     horizontal alignment and width, h-align could be :left, :center
   4.112 +     or :right.")
   4.113 +  (anchor-y [geom v-align height]
   4.114 +    "Returns the y coordinate of the anchor point for the specified
   4.115 +    vertical alignment and height, v-align could be :top, :center
   4.116 +    or :bottom."))
   4.117 +
   4.118 +(defn- emit-align-xy [align size first center last]
   4.119 +  `(case ~align
   4.120 +         ~first 0
   4.121 +         ~center (/ ~size 2)
   4.122 +         ~last ~size))
   4.123 +
   4.124 +;; Define as macro to avoid unnecessary calculation of width or height.
   4.125 +(defmacro align-x
   4.126 +  ([align inner outer]
   4.127 +     `(align-x ~align (- ~outer ~inner)))
   4.128 +  ([align width]
   4.129 +     (emit-align-xy align width :left :center :right)))
   4.130 +
   4.131 +(defmacro align-y
   4.132 +  ([align inner outer]
   4.133 +     `(align-y ~align (- ~outer ~inner)))
   4.134 +  ([align height]
   4.135 +     (emit-align-xy align height :top :center :bottom)))
   4.136 +
   4.137 +(defrecord Size [width height]
   4.138 +  Geometry
   4.139 +  (width  [_] width)
   4.140 +  (width [_ _] width)
   4.141 +  (height [_] height)
   4.142 +  (height [_ _] height)
   4.143 +  (anchor-x [_ h-align width]
   4.144 +    (align-x h-align width))
   4.145 +  (anchor-y [_ v-align height]
   4.146 +    (align-y v-align height)))
   4.147 +
   4.148 +(defrecord FixedGeometry [ax ay width height]
   4.149 +  Geometry
   4.150 +  (width  [_] width)
   4.151 +  (width [_ _] width)
   4.152 +  (height [_] height)
   4.153 +  (height [_ _] height)
   4.154 +  (anchor-x [_ _ _] ax)
   4.155 +  (anchor-y [_ _ _] ay))
   4.156 +
   4.157 +(defrecord NestedGeometry [geometry top left bottom right]
   4.158 +  Geometry
   4.159 +  (width  [_]
   4.160 +    (+ left right (width geometry)))
   4.161 +  (width [_ h]
   4.162 +    (+ left right (width geometry (- h top bottom))))
   4.163 +  (height [_]
   4.164 +    (+ top bottom (height geometry)))
   4.165 +  (height [_ w]
   4.166 +    (+ top bottom (height geometry (- w left right))))
   4.167 +  (anchor-x [_ h-align w]
   4.168 +    (+ left (anchor-x geometry h-align (- w left right))))
   4.169 +  (anchor-y [_ v-align h]
   4.170 +    (+ top (anchor-y geometry v-align (- h top bottom)))))
   4.171 +
   4.172 +(defrecord ScaledGeometry [geometry sx sy]
   4.173 +  Geometry
   4.174 +  (width  [_]
   4.175 +    (* sx (width geometry)))
   4.176 +  (width [_ h]
   4.177 +    (* sx (width geometry (/ h sy))))
   4.178 +  (height [_]
   4.179 +    (* sy (height geometry)))
   4.180 +  (height [_ w]
   4.181 +    (* sy (height geometry (/ w sx))))
   4.182 +  (anchor-x [_ h-align w]
   4.183 +    (* sx (anchor-x geometry h-align (/ w sx))))
   4.184 +  (anchor-y [_ v-align h]
   4.185 +    (* sy (anchor-y geometry v-align (/ h sy)))))
   4.186 +
   4.187 +;; (defn ^:private to-integer
   4.188 +;;   ^long [align x]
   4.189 +;;   (if (integer? x)
   4.190 +;;     x
   4.191 +;;     (let [x (double x)]
   4.192 +;;       (Math/round
   4.193 +;;        (case align
   4.194 +;;          (:top :left) (Math/floor x)
   4.195 +;;          :center x
   4.196 +;;          (:bottom :right) (Math/ceil x))))))
   4.197 +
   4.198 +;; (defrecord IntegerGeometry [geometry]
   4.199 +;;   Geometry
   4.200 +;;   (width [_]
   4.201 +;;     (to-integer :right (width geometry)))
   4.202 +;;   (width [_ h]
   4.203 +;;     (to-integer :right (width geometry h)))
   4.204 +;;   (height [_]
   4.205 +;;     (to-integer :bottom (height geometry)))
   4.206 +;;   (height [_ w]
   4.207 +;;     (to-integer :bottom (height geometry w)))
   4.208 +;;   (anchor-x [_ h-align w]
   4.209 +;;     (to-integer h-align (anchor-x geometry h-align w)))
   4.210 +;;   (anchor-y [_ v-align h]
   4.211 +;;     (to-integer v-align (anchor-y geometry v-align h))))
   4.212 +
   4.213 +;; TODO: modifiers
   4.214 +(defrecord MouseEvent [id when x y x-on-screen y-on-screen button
   4.215 +                       wheel-rotation transform component])
   4.216 +
   4.217 +;; TODO: KeyEvent
   4.218 +
   4.219 +(defprotocol EventDispatcher
   4.220 +  (listen! [this component]
   4.221 +     "Listen for events on the specified AWT Component.")
   4.222 +  (create-dispatcher [this handle handlers]
   4.223 +     "Returns new event dispatcher associated with the specified event
   4.224 +      handlers (an event-id -> handler-fn map). Handle is used to
   4.225 +      match the contexts between commits.")
   4.226 +  (commit [this]
   4.227 +     "Apply the registered handlers for event processing.")
   4.228 +  (handle-picked? [this handle]
   4.229 +     "Returns true if the specified handle received the :mouse-pressed
   4.230 +      event and have not yet received :moused-released.")
   4.231 +  (handle-hovered? [this handle]
   4.232 +     "Returns true if the specified handle received the :mouse-entered
   4.233 +      event and have not yet received :mouse-exited."))
   4.234 +
   4.235 +(defn- assoc-cons [m key val]
   4.236 +  (->> (get m key) (cons val) (assoc m key)))
   4.237 +
   4.238 +;;
   4.239 +;; Observers
   4.240 +;; The mechanism used by views to request repaints
   4.241 +;;
   4.242 +
   4.243 +(def ^ConcurrentMap observers
   4.244 +     (-> (MapMaker.) (.weakKeys) (.makeMap)))
   4.245 +
   4.246 +(defn- cm-replace!
   4.247 +  "Wrap ConcurrentMap replace method to treat nil value as absent
   4.248 +   mapping. Use with maps that does not support nil values."
   4.249 +  [^ConcurrentMap cmap key old new]
   4.250 +  (if (nil? old)
   4.251 +    (nil? (.putIfAbsent cmap key new))
   4.252 +    (.replace cmap key old new)))
   4.253 +
   4.254 +(defn- cm-swap!
   4.255 +  "Atomically swaps the value associated with key in ConcurrentMap
   4.256 +   to be (apply f current-value args). Returns the new value."
   4.257 +  [^ConcurrentMap cmap key f & args]
   4.258 +  (loop []
   4.259 +    (let [old (.get cmap key)
   4.260 +          new (apply f old args)]
   4.261 +      (if (cm-replace! cmap key old new)
   4.262 +        new
   4.263 +        (recur)))))
   4.264 +
   4.265 +(defn add-observer
   4.266 +  "Add observer fn for the target. Watcher identifies the group of
   4.267 +  observers and could be used to remove the group. Watcher is weakly
   4.268 +  referenced, all associated observers will be removed when the
   4.269 +  wathcer is removed by gc. The observer fn will be called with
   4.270 +  watcher and target arguments and any additional arguments specified
   4.271 +  in update call."
   4.272 +  [watcher target f]
   4.273 +  (cm-swap! observers watcher assoc-cons target f)
   4.274 +  nil)
   4.275 +
   4.276 +(defn remove-observers
   4.277 +  "Remove group of observers associated with the specified watcher."
   4.278 +  [watcher]
   4.279 +  (.remove observers watcher)
   4.280 +  nil)
   4.281 +
   4.282 +(defn- replace-observers-watcher
   4.283 +  [old-watcher new-watcher]
   4.284 +  (if-let [old (.remove observers old-watcher)]
   4.285 +    (.put observers new-watcher old))
   4.286 +  nil)
   4.287 +
   4.288 +(defn update
   4.289 +  "Notify observers."
   4.290 +  [target & args]
   4.291 +  (doseq [entry observers
   4.292 +          f (get (val entry) target)]
   4.293 +    (apply f (key entry) target args)))
   4.294 +
   4.295 +(defn add-context-observer
   4.296 +  "Observer registered with this function will be automatically
   4.297 +  removed after the next repaint is complete."
   4.298 +  [target f]
   4.299 +  (add-observer *scene* target f))
   4.300 +
   4.301 +(defn repaint-on-update
   4.302 +  "Trigger repaint of the current scene when the target updates."
   4.303 +  [target]
   4.304 +  (let [scene *scene*]
   4.305 +    (if-not (identical? scene target)
   4.306 +      (add-observer scene target (fn [w _] (update w))))))
   4.307 +
   4.308 +(defn repaint
   4.309 +  "Requests repaint of the current scene. If handle and state are
   4.310 +  specified, the handle will be associated with the state in the
   4.311 +  *states* map for the next paint iteration."
   4.312 +  ([]
   4.313 +     (update *scene*))
   4.314 +  ([handle state]
   4.315 +     (let [scene *scene*]
   4.316 +       (swap! (:next-state scene) assoc handle state)
   4.317 +       (update scene))))
   4.318 +
   4.319 +;;
   4.320 +;; Rendering
   4.321 +;;
   4.322 +
   4.323 +(defn ^FontRenderContext font-context
   4.324 +  "Returns FontRenderContext for the current view context."
   4.325 +  []
   4.326 +  (if (bound? (var *graphics*))
   4.327 +    (.getFontRenderContext *graphics*)
   4.328 +    *font-context*))
   4.329 +
   4.330 +(defn ^AffineTransform relative-transform
   4.331 +  "Returns AffineTransform: view context -> AWT component."
   4.332 +  []
   4.333 +  (let [tr (.getTransform *graphics*)]
   4.334 +    (.preConcatenate tr *inverse-initial-transform*)
   4.335 +    tr))
   4.336 +
   4.337 +(defn ^AffineTransform inverse-relative-transform
   4.338 +  "Returns AffineTransform: AWT component -> view context."
   4.339 +  []
   4.340 +  (let [tr (.getTransform *graphics*)]
   4.341 +    (.invert tr)                          ; absolute -> view
   4.342 +    (.concatenate tr *initial-transform*) ; component -> absolute
   4.343 +    tr))
   4.344 +
   4.345 +(defn transform-point [^AffineTransform tr ^double x ^double y]
   4.346 +  (let [p (Point2D$Double. x y)]
   4.347 +    (.transform tr p p)
   4.348 +    [(.x p) (.y p)]))
   4.349 +
   4.350 +(defn inverse-transform-point [^AffineTransform tr ^double x ^double y]
   4.351 +  (let [p (Point2D$Double. x y)]
   4.352 +    (.inverseTransform tr p p)
   4.353 +    [(.x p) (.y p)]))
   4.354 +
   4.355 +;; (defn- clip
   4.356 +;;   "Intersect clipping area with the specified shape or bounds.
   4.357 +;;    Returns new clip (Shape or nil if empty)."
   4.358 +;;   ([x y w h]
   4.359 +;;      (clip (Rectangle2D$Double. x y w h)))
   4.360 +;;   ([shape]
   4.361 +;;      (let [a1 (Area. shape)
   4.362 +;;            a2 (if (instance? Area *clip*) *clip* (Area. *clip*))]
   4.363 +;;        (.transform a1 (relative-transform))
   4.364 +;;        (.intersect a1 a2)
   4.365 +;;        (if (.isEmpty a1)
   4.366 +;;          nil
   4.367 +;;          a1))))
   4.368 +
   4.369 +;; Use faster clipping calculation provided by Graphics2D.
   4.370 +(defn- clip
   4.371 +  "Intersect clipping area with the specified Shape in current
   4.372 +   transform coordinates. Returns new clip in the AWT component
   4.373 +   coordinates (Shape or nil if empty)."
   4.374 +  [^Shape shape]
   4.375 +  (let [^Graphics2D clip-g (.create *graphics*)]
   4.376 +    (try
   4.377 +      (doto clip-g
   4.378 +        (.setClip shape)
   4.379 +        (.setTransform *initial-transform*)
   4.380 +        (.clip *clip*))
   4.381 +      (if (.isEmpty (.getClipBounds clip-g))
   4.382 +        nil
   4.383 +        (.getClip clip-g))
   4.384 +      (finally
   4.385 +       (.dispose clip-g)))))
   4.386 +
   4.387 +(defn- ^Graphics2D apply-theme
   4.388 +  "Set graphics' color and font to match theme.
   4.389 +   Modifies and returns the first argument."
   4.390 +  ([]
   4.391 +     (apply-theme *graphics* *theme*))
   4.392 +  ([^Graphics2D graphics theme]
   4.393 +     (doto graphics
   4.394 +       (.setColor (:fore-color theme))
   4.395 +       (.setFont (:font theme)))))
   4.396 +
   4.397 +(defn- ^Graphics2D create-graphics
   4.398 +  ([]
   4.399 +     (apply-theme (.create *graphics*) *theme*))
   4.400 +  ([^long x ^long y ^long w ^long h]
   4.401 +     (apply-theme (.create *graphics* x y w h) *theme*)))
   4.402 +
   4.403 +(defn- with-bounds-noclip*
   4.404 +  [x y w h f & args]
   4.405 +  (let [graphics (create-graphics)]
   4.406 +    (try
   4.407 +      (.translate graphics (double x) (double y))
   4.408 +      (binding [*width* w
   4.409 +                *height* h
   4.410 +                *input-clip* (Rectangle2D$Double. 0.0 0.0 w h)
   4.411 +                *graphics* graphics]
   4.412 +        (apply f args))
   4.413 +      (finally
   4.414 +       (.dispose graphics)))))
   4.415 +
   4.416 +(defn with-bounds*
   4.417 +  [x y w h f & args]
   4.418 +  (let [x (double x)
   4.419 +        y (double y)
   4.420 +        bounds (Rectangle2D$Double. x y w h)]
   4.421 +    (when-let [clip (clip bounds)]
   4.422 +      (let [^Graphics2D graphics (create-graphics)]
   4.423 +        (try
   4.424 +          (.clip graphics bounds)
   4.425 +          (.translate graphics x y)
   4.426 +          (binding [*width* w
   4.427 +                    *height* h
   4.428 +                    *clip* clip
   4.429 +                    *input-clip* nil
   4.430 +                    *graphics* graphics]
   4.431 +            (apply f args))
   4.432 +          (finally
   4.433 +           (.dispose graphics)))))))
   4.434 +
   4.435 +(defmacro with-bounds
   4.436 +  [x y w h & body]
   4.437 +  `(with-bounds* ~x ~y ~w ~h (fn [] ~@body)))
   4.438 +
   4.439 +(defmacro with-theme
   4.440 +  [theme & body]
   4.441 +  `(binding [*theme* (merge *theme* ~theme)]
   4.442 +     ~@body))
   4.443 +
   4.444 +(defmacro with-color [color-or-key & body]
   4.445 +  `(let [color# ~color-or-key
   4.446 +         color# (get *theme* color# color#)
   4.447 +         g# *graphics*
   4.448 +         old-color# (.getColor g#)]
   4.449 +     (try
   4.450 +       (.setColor g# color#)
   4.451 +       ~@body
   4.452 +       (finally
   4.453 +         (.setColor g# old-color#)))))
   4.454 +
   4.455 +(defmacro with-stroke [stroke & body]
   4.456 +  `(let [g# *graphics*
   4.457 +         old-stroke# (.getStroke g#)]
   4.458 +     (try
   4.459 +       (.setStroke g# ~stroke)
   4.460 +       ~@body
   4.461 +       (finally
   4.462 +        (.setStroke g# old-stroke#)))))
   4.463 +
   4.464 +(defmacro with-hints
   4.465 +  [hints & body]
   4.466 +  `(let [h# ~hints
   4.467 +         g# *graphics*
   4.468 +         old# (.getRenderingHints g#)]
   4.469 +     (try
   4.470 +       (.addRenderingHints g# h#)
   4.471 +       ~@body
   4.472 +       (finally
   4.473 +        (.setRenderingHints g# old#)))))
   4.474 +
   4.475 +(defn with-hints* [hints f & args]
   4.476 +  (with-hints hints
   4.477 +    (apply f args)))
   4.478 +
   4.479 +;; TODO: constructor for AffineTransform.
   4.480 +;; (transform :scale 0.3 0.5
   4.481 +;;            :translate 5 10
   4.482 +;;            :rotate (/ Math/PI 2))
   4.483 +
   4.484 +(defmacro with-transform [transform & body]
   4.485 +  `(let [g# *graphics*
   4.486 +         old-t# (.getTransform g#)]
   4.487 +     (try
   4.488 +       (.transform g# ~transform)
   4.489 +       ~@body
   4.490 +       (finally
   4.491 +        (.setTransform g# old-t#)))))
   4.492 +
   4.493 +(defmacro with-rotate [theta ax ay & body]
   4.494 +  `(let [transform# (AffineTransform/getRotateInstance ~theta ~ax ~ay)]
   4.495 +     (with-transform transform# ~@body)))
   4.496 +
   4.497 +(defmacro with-translate [x y & body]
   4.498 +  `(let [x# ~x
   4.499 +         y# ~y
   4.500 +         g# *graphics*]
   4.501 +     (try
   4.502 +       (.translate g# x# y#)
   4.503 +       ~@body
   4.504 +       (finally
   4.505 +        (.translate g# (- x#) (- y#))))))
   4.506 +
   4.507 +(defn draw!
   4.508 +  "Draws the View."
   4.509 +  ([view]
   4.510 +     (let [graphics (create-graphics)]
   4.511 +       (try
   4.512 +         (binding [*graphics* graphics]
   4.513 +           (render! view))
   4.514 +         (finally
   4.515 +          (.dispose graphics)))))
   4.516 +  ([x y view]
   4.517 +     (draw! x y true view))
   4.518 +  ([x y clip? view]
   4.519 +     (let [geom (geometry view)]
   4.520 +       (draw! x y (width geom) (height geom) clip? view)))
   4.521 +  ([x y width height view]
   4.522 +     (draw! x y width height true view))
   4.523 +  ([x y width height clip? view]
   4.524 +     (if clip?
   4.525 +       (with-bounds* x y width height render! view)
   4.526 +       (with-bounds-noclip* x y width height render! view))))
   4.527 +
   4.528 +(defn draw-aligned!
   4.529 +  "Draws the View.  Location is relative to the view's anchor point
   4.530 +   for the specified alignment."
   4.531 +  ([h-align v-align x y view]
   4.532 +     (let [geom (geometry view)
   4.533 +           w (width geom)
   4.534 +           h (height geom)]
   4.535 +       (draw! (- x (anchor-x geom h-align w))
   4.536 +              (- y (anchor-y geom v-align h))
   4.537 +              w h
   4.538 +              view)))
   4.539 +  ([h-align v-align x y w h view]
   4.540 +     (let [geom (geometry view)]
   4.541 +       (draw! (- x (anchor-x geom h-align w))
   4.542 +              (- y (anchor-y geom v-align h))
   4.543 +              w h
   4.544 +              view))))
   4.545 +
   4.546 +;;
   4.547 +;; Event handling.
   4.548 +;;
   4.549 +
   4.550 +(defn with-handlers*
   4.551 +  [handle handlers f & args]
   4.552 +  (binding [*event-dispatcher* (create-dispatcher
   4.553 +                                *event-dispatcher* handle handlers)]
   4.554 +    (apply f args)))
   4.555 +
   4.556 +(defmacro with-handlers
   4.557 +  "specs => (:event-id name & handler-body)*
   4.558 +
   4.559 +  Execute form with the specified event handlers."
   4.560 +  [handle form & specs]
   4.561 +  `(with-handlers* ~handle
   4.562 +     ~(reduce (fn [m spec]
   4.563 +                (assoc m (first spec)
   4.564 +                       `(fn [~(second spec)]
   4.565 +                          ~@(nnext spec)))) {}
   4.566 +                          specs)
   4.567 +     (fn [] ~form)))
   4.568 +
   4.569 +(defn picked? [handle]
   4.570 +  (handle-picked? *event-dispatcher* handle))
   4.571 +
   4.572 +(defn hovered? [handle]
   4.573 +  (handle-hovered? *event-dispatcher* handle))
   4.574 +
   4.575 +;;
   4.576 +;; EventDispatcher implementation
   4.577 +;;
   4.578 +
   4.579 +(def awt-events
   4.580 +     {java.awt.event.MouseEvent/MOUSE_CLICKED  :mouse-clicked
   4.581 +      java.awt.event.MouseEvent/MOUSE_DRAGGED  :mouse-dragged
   4.582 +      java.awt.event.MouseEvent/MOUSE_ENTERED  :mouse-entered
   4.583 +      java.awt.event.MouseEvent/MOUSE_EXITED   :mouse-exited
   4.584 +      java.awt.event.MouseEvent/MOUSE_MOVED    :mouse-moved
   4.585 +      java.awt.event.MouseEvent/MOUSE_PRESSED  :mouse-pressed
   4.586 +      java.awt.event.MouseEvent/MOUSE_RELEASED :mouse-released
   4.587 +      java.awt.event.MouseEvent/MOUSE_WHEEL    :mouse-wheel})
   4.588 +
   4.589 +(def dummy-event-dispatcher
   4.590 +  (reify EventDispatcher
   4.591 +    (listen! [_ _])
   4.592 +    (create-dispatcher [this _ _] this)
   4.593 +    (commit [_])
   4.594 +    (handle-picked? [_ _])
   4.595 +    (handle-hovered? [_ _])))
   4.596 +
   4.597 +;; Not using defrecord to avoid unacceptable overhead of recursive
   4.598 +;; hash code calculation.
   4.599 +(deftype DispatcherNode [handle handlers parent
   4.600 +                         ^Shape clip ^AffineTransform transform
   4.601 +                         bindings]
   4.602 +  EventDispatcher
   4.603 +  (listen! [this component]
   4.604 +    (listen! parent component))
   4.605 +  (create-dispatcher [this handle handlers]
   4.606 +    (create-dispatcher parent handle handlers))
   4.607 +  (commit [this]
   4.608 +    (commit parent))
   4.609 +  (handle-picked? [this handle]
   4.610 +    (handle-picked? parent handle))
   4.611 +  (handle-hovered? [this handle]
   4.612 +    (handle-hovered? parent handle)))
   4.613 +
   4.614 +(defn- make-node [handle handlers]
   4.615 +  (let [clip (if *input-clip*
   4.616 +               (clip *input-clip*)
   4.617 +               *clip*)
   4.618 +        bindings (-> (get-thread-bindings)
   4.619 +                     (dissoc (var *graphics*))
   4.620 +                     (assoc (var *font-context*) (font-context)))]
   4.621 +    (DispatcherNode. handle handlers *event-dispatcher* clip
   4.622 +                     (relative-transform)
   4.623 +                     bindings)))
   4.624 +
   4.625 +(defn- add-node [tree ^DispatcherNode node]
   4.626 +  (assoc-cons tree (.parent node) node))
   4.627 +
   4.628 +(defn- nodes [tree]
   4.629 +  (apply concat (vals tree)))
   4.630 +
   4.631 +(defn- under-cursor
   4.632 +  "Returns a vector of child nodes under cursor."
   4.633 +  [node tree ^long x ^long y]
   4.634 +  (some (fn [^DispatcherNode n]
   4.635 +          (if (and (.clip n) (.contains ^Shape (.clip n) x y))
   4.636 +            (conj (vec (under-cursor n tree x y)) n)))
   4.637 +        (get tree node)))
   4.638 +
   4.639 +(defn- translate-mouse-event [^java.awt.event.MouseEvent event
   4.640 +                              ^AffineTransform tr id]
   4.641 +  (let [[x y] (inverse-transform-point tr (.getX event) (.getY event))
   4.642 +        rotation (if (instance? MouseWheelEvent event)
   4.643 +                   (.getWheelRotation ^MouseWheelEvent event)
   4.644 +                   nil)]
   4.645 +    (->MouseEvent id (.getWhen event) x y
   4.646 +                  (.getXOnScreen event) (.getYOnScreen event)
   4.647 +                  (.getButton event)
   4.648 +                  rotation
   4.649 +                  tr
   4.650 +                  (.getComponent event))))
   4.651 +
   4.652 +(defn- translate-and-dispatch
   4.653 +  ([nodes first-only ^java.awt.event.MouseEvent event]
   4.654 +     (translate-and-dispatch nodes first-only
   4.655 +                             event (awt-events (.getID event))))
   4.656 +  ([nodes first-only event id]
   4.657 +     (if-let [^DispatcherNode node (first nodes)]
   4.658 +       (let [handlers (.handlers node)
   4.659 +             handler (get handlers id)]
   4.660 +         (if handler
   4.661 +           (do
   4.662 +             (with-bindings* (.bindings node)
   4.663 +               handler
   4.664 +               (translate-mouse-event event (.transform node) id))
   4.665 +             (when-not first-only
   4.666 +               (recur (rest nodes) false event id)))
   4.667 +           (when-not (and (= id :mouse-dragged)
   4.668 +                          (or (contains? handlers :mouse-pressed)
   4.669 +                              (contains? handlers :mouse-released)))
   4.670 +             (recur (rest nodes) first-only event id)))))))
   4.671 +
   4.672 +(defn- process-mouse-event
   4.673 +  [dispatcher ^java.awt.event.MouseEvent source-event]
   4.674 +  (let [{active-ref :active
   4.675 +         hovered-ref :hovered
   4.676 +         picked-ref :picked
   4.677 +         last-ref :last-motion
   4.678 +         tree-ref :tree} dispatcher
   4.679 +         pressed (and source-event
   4.680 +                      (== (.getID source-event)
   4.681 +                          java.awt.event.MouseEvent/MOUSE_PRESSED))
   4.682 +         released (and source-event
   4.683 +                       (== (.getID source-event)
   4.684 +                           java.awt.event.MouseEvent/MOUSE_RELEASED))
   4.685 +         ^java.awt.event.MouseEvent last-event @last-ref
   4.686 +         ^java.awt.event.MouseEvent event (or source-event last-event)]
   4.687 +    (when event
   4.688 +      (let [x (.getX event)
   4.689 +            y (.getY event)
   4.690 +            active @active-ref
   4.691 +            active (if (and active
   4.692 +                            source-event
   4.693 +                            (== (.getX last-event) x)
   4.694 +                            (== (.getY last-event) y))
   4.695 +                     active
   4.696 +                     (ref-set active-ref
   4.697 +                              (under-cursor dispatcher @tree-ref x y)))
   4.698 +            acted (cond
   4.699 +                   pressed (ref-set picked-ref active)
   4.700 +                   released (let [picked @picked-ref]
   4.701 +                              (ref-set picked-ref nil)
   4.702 +                              picked)
   4.703 +                   :else active)
   4.704 +            picked (seq @picked-ref)
   4.705 +            pred #(= (.handle ^DispatcherNode %1) (.handle ^DispatcherNode %2))
   4.706 +            hovered (if picked
   4.707 +                      (filter #(some (partial pred %) picked) active)
   4.708 +                      active)
   4.709 +            remove-all (fn [c1 c2]
   4.710 +                         (filter #(not (some (partial pred %) c2)) c1))
   4.711 +            old-hovered @hovered-ref
   4.712 +            exited (remove-all old-hovered hovered)
   4.713 +            entered (remove-all hovered old-hovered)
   4.714 +            moved (or picked (remove-all hovered entered))]
   4.715 +        (ref-set hovered-ref hovered)
   4.716 +        (ref-set last-ref event)
   4.717 +        [exited entered moved acted event]))))
   4.718 +
   4.719 +(defn- dispatch-mouse-event
   4.720 +  [dispatcher source-event button?]
   4.721 +  (when-let [[exited
   4.722 +              entered
   4.723 +              moved
   4.724 +              acted
   4.725 +              event] (dosync (process-mouse-event dispatcher source-event))]
   4.726 +    (when button?
   4.727 +      (translate-and-dispatch acted true event))
   4.728 +    (translate-and-dispatch exited false event :mouse-exited)
   4.729 +    (translate-and-dispatch entered false event :mouse-entered)
   4.730 +    (when-not button?
   4.731 +      (translate-and-dispatch moved true source-event))))
   4.732 +
   4.733 +(defrecord RootEventDispatcher [tree-r  ;; register
   4.734 +                                tree    ;; dispatch
   4.735 +                                active  ;; nodes under cursor
   4.736 +                                hovered ;; mouse entered
   4.737 +                                picked  ;; mouse pressed
   4.738 +                                last-motion]
   4.739 +  EventDispatcher
   4.740 +  (listen! [dispatcher component]
   4.741 +    (doto ^Component component
   4.742 +          (.addMouseListener dispatcher)
   4.743 +          (.addMouseWheelListener dispatcher)
   4.744 +          (.addMouseMotionListener dispatcher)))
   4.745 +  (create-dispatcher [dispatcher handle handlers]
   4.746 +    (let [node (make-node handle handlers)]
   4.747 +      (dosync (alter tree-r add-node node))
   4.748 +      node))
   4.749 +  (commit [dispatcher]
   4.750 +    (let [[exited
   4.751 +           entered
   4.752 +           _ _
   4.753 +           event] (dosync
   4.754 +                   ;; TODO: retain contexts that do
   4.755 +                   ;; not intersect graphics
   4.756 +                   ;; clipping area in tree.
   4.757 +                   (ref-set tree @tree-r)
   4.758 +                   (ref-set tree-r {})
   4.759 +                   (process-mouse-event dispatcher nil))]
   4.760 +      ;; Send mouse entered and exited events if necessary due to
   4.761 +      ;; updated layout.
   4.762 +      (translate-and-dispatch exited false event :mouse-exited)
   4.763 +      (translate-and-dispatch entered false event :mouse-entered)))
   4.764 +  (handle-picked? [dispatcher handle]
   4.765 +    (some #(= handle (.handle ^DispatcherNode %)) @picked))
   4.766 +  (handle-hovered? [dispatcher handle]
   4.767 +    (some #(= handle (.handle ^DispatcherNode %)) @hovered))
   4.768 +  MouseListener
   4.769 +  (mouseEntered [dispatcher event]
   4.770 +    (dispatch-mouse-event dispatcher event false))
   4.771 +  (mouseExited [dispatcher event]
   4.772 +    (dispatch-mouse-event dispatcher event false))
   4.773 +  (mouseClicked [dispatcher event]
   4.774 +    (dispatch-mouse-event dispatcher event true))
   4.775 +  (mousePressed [dispatcher event]
   4.776 +    (dispatch-mouse-event dispatcher event true))
   4.777 +  (mouseReleased [dispatcher event]
   4.778 +    (dispatch-mouse-event dispatcher event true))
   4.779 +  MouseWheelListener
   4.780 +  (mouseWheelMoved [dispatcher event]
   4.781 +    (dispatch-mouse-event dispatcher event true))
   4.782 +  MouseMotionListener
   4.783 +  (mouseDragged [dispatcher event]
   4.784 +    (dispatch-mouse-event dispatcher event false))
   4.785 +  (mouseMoved [dispatcher event]
   4.786 +    (dispatch-mouse-event dispatcher event false)))
   4.787 +
   4.788 +(defn root-event-dispatcher []
   4.789 +  (->RootEventDispatcher
   4.790 +   (ref {}) (ref {})             ;; trees
   4.791 +   (ref nil) (ref nil) (ref nil) ;; node states
   4.792 +   (ref nil)))                   ;; last event
   4.793 +
   4.794 +;;
   4.795 +;; Scene
   4.796 +;;
   4.797 +
   4.798 +(defrecord Scene [view
   4.799 +                  event-dispatcher
   4.800 +                  component
   4.801 +                  rendering-hints
   4.802 +                  next-state])
   4.803 +
   4.804 +;; Define rendering hints that affect font metrics to make sure that
   4.805 +;; Graphics and Scene FontRenderContexts are consistent.
   4.806 +(def ^:private default-rendering-hints
   4.807 +  {RenderingHints/KEY_TEXT_ANTIALIASING
   4.808 +   RenderingHints/VALUE_TEXT_ANTIALIAS_DEFAULT,
   4.809 +   RenderingHints/KEY_FRACTIONALMETRICS
   4.810 +   RenderingHints/VALUE_FRACTIONALMETRICS_DEFAULT})
   4.811 +
   4.812 +(defn make-scene
   4.813 +  ([view]
   4.814 +     (make-scene view dummy-event-dispatcher nil))
   4.815 +  ([view event-dispatcher]
   4.816 +     (make-scene view event-dispatcher nil))
   4.817 +  ([view event-dispatcher ^Component component]
   4.818 +     (make-scene view event-dispatcher component nil))
   4.819 +  ([view event-dispatcher ^Component component hints]
   4.820 +     (let [hints (merge default-rendering-hints hints)]
   4.821 +       (->Scene view
   4.822 +                event-dispatcher
   4.823 +                component
   4.824 +                hints
   4.825 +                (atom nil)))))
   4.826 +
   4.827 +(defn- get-and-set!
   4.828 +  "Atomically sets the value of atom to newval and returns the old
   4.829 +  value."
   4.830 +  [atom newval]
   4.831 +  (loop [v @atom]
   4.832 +    (if (compare-and-set! atom v newval)
   4.833 +      v
   4.834 +      (recur @atom))))
   4.835 +
   4.836 +(defn draw-scene!
   4.837 +  [scene ^Graphics2D graphics width height]
   4.838 +  (.addRenderingHints graphics (:rendering-hints scene))
   4.839 +  (binding [*states* (get-and-set! (:next-state scene) nil)
   4.840 +            *scene* scene
   4.841 +            *graphics* graphics
   4.842 +            *initial-transform* (.getTransform graphics)
   4.843 +            *inverse-initial-transform* (-> graphics
   4.844 +                                            .getTransform
   4.845 +                                            .createInverse)
   4.846 +            *event-dispatcher* (:event-dispatcher scene)
   4.847 +            *width* width
   4.848 +            *height* height
   4.849 +            *clip* (Rectangle2D$Double. 0.0 0.0 width height)
   4.850 +            *input-clip* nil
   4.851 +            *time* (System/nanoTime)]
   4.852 +    (apply-theme)
   4.853 +    (let [tmp-watcher (Object.)]
   4.854 +      ;; Keep current context observers until the rendering is
   4.855 +      ;; complete. Some observers may be invoked twice if they
   4.856 +      ;; appear in both groups until tmp-watcher is removed.
   4.857 +      (replace-observers-watcher scene tmp-watcher)
   4.858 +      (try
   4.859 +        (render! (:view scene))
   4.860 +        (finally
   4.861 +         (remove-observers tmp-watcher)
   4.862 +         (commit (:event-dispatcher scene)))))))
   4.863 +
   4.864 +(defn- scene-font-context [scene]
   4.865 +  (let [hints (:rendering-hints scene)
   4.866 +        ^Component c (:component scene)
   4.867 +        t (if c (->> c
   4.868 +                     .getFont
   4.869 +                     (.getFontMetrics c)
   4.870 +                     .getFontRenderContext
   4.871 +                     .getTransform))]
   4.872 +    (FontRenderContext.
   4.873 +     t
   4.874 +     (get hints RenderingHints/KEY_TEXT_ANTIALIASING)
   4.875 +     (get hints RenderingHints/KEY_FRACTIONALMETRICS))))      
   4.876 +
   4.877 +(defn scene-geometry [scene]
   4.878 +  (binding [*scene* scene
   4.879 +            *font-context* (scene-font-context scene)]
   4.880 +    (geometry (:view scene))))
   4.881 +
   4.882 +(defn set-cursor! [^Cursor cursor]
   4.883 +  (when-let [^Component component (:component *scene*)]
   4.884 +    (EventQueue/invokeLater #(.setCursor component cursor))))

     5.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     5.2 +++ b/src/indyvon/demo.clj	Mon Apr 14 20:01:00 2014 +0400
     5.3 @@ -0,0 +1,223 @@
     5.4 +;;
     5.5 +;; Copyright 2010-2014 Mikhail Kryshen <mikhail@kryshen.net>
     5.6 +;;
     5.7 +;; This file is part of Indyvon.
     5.8 +;;
     5.9 +;; Indyvon is free software: you can redistribute it and/or modify it
    5.10 +;; under the terms of the GNU Lesser General Public License version 3
    5.11 +;; only, as published by the Free Software Foundation.
    5.12 +;;
    5.13 +;; Indyvon is distributed in the hope that it will be useful, but
    5.14 +;; WITHOUT ANY WARRANTY; without even the implied warranty of
    5.15 +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
    5.16 +;; Lesser General Public License for more details.
    5.17 +;;
    5.18 +;; You should have received a copy of the GNU Lesser General Public
    5.19 +;; License along with Indyvon.  If not, see
    5.20 +;; <http://www.gnu.org/licenses/>.
    5.21 +;;
    5.22 +
    5.23 +(ns indyvon.demo
    5.24 +  "Indyvon demo and experiments."
    5.25 +  (:gen-class)
    5.26 +  (:use
    5.27 +   (indyvon core views viewport component))
    5.28 +  (:import
    5.29 +   (java.awt Color)
    5.30 +   (javax.swing JFrame)))
    5.31 +
    5.32 +(defn draw-button!
    5.33 +  "Draws a button immediately (but uses callback for the action unlike
    5.34 +   IMGUI)."
    5.35 +  [id content callback & args]
    5.36 +  (with-handlers id
    5.37 +    (let [shadow-offset 2
    5.38 +          padding 4
    5.39 +          border-width 1
    5.40 +          offset (if (picked? id) (/ shadow-offset 2) 0)
    5.41 +          ^Color color (:alt-back-color *theme*)
    5.42 +          color (if (hovered? id) (.brighter color) color)
    5.43 +          width (- *width* shadow-offset)
    5.44 +          height (- *height* shadow-offset)]
    5.45 +      (with-color (:shadow-color *theme*)
    5.46 +        (.fillRect *graphics* shadow-offset shadow-offset width height))
    5.47 +      (with-color color
    5.48 +        (.fillRect *graphics* offset offset width height))
    5.49 +      (draw! offset offset width height
    5.50 +             (border border-width padding content)))
    5.51 +    ;; Event handlers
    5.52 +    (:mouse-entered _ (repaint))
    5.53 +    (:mouse-exited _ (repaint))
    5.54 +    (:mouse-pressed _ (repaint))
    5.55 +    (:mouse-released _ (repaint))
    5.56 +    (:mouse-clicked _ (apply callback args))))
    5.57 +
    5.58 +(defn combine-colors
    5.59 +  "Returns color between color1 and color2. When c (0 <= c <= 1.0) is
    5.60 +   closer to 0 the returned сolor is closer to color1."
    5.61 +  [^Color color1 ^Color color2 c]
    5.62 +  (case c
    5.63 +    0.0 color1
    5.64 +    1.0 color2
    5.65 +    (let [rgb1 (.getRGBComponents color1 nil)
    5.66 +          rgb2 (.getRGBComponents color2 nil)
    5.67 +          rgb (float-array (map #(+ (* (- 1 c) %1) (* c %2)) rgb1 rgb2))]
    5.68 +      (Color. (aget rgb 0) (aget rgb 1) (aget rgb 2) (aget rgb 3)))))
    5.69 +
    5.70 +(defn animate
    5.71 +  "Changes the value of atom according to the specified range, speed,
    5.72 +   and current frame interval.  Invokes repaint if change happens."
    5.73 +  [atom from to speed]
    5.74 +  (let [prev @atom
    5.75 +        state (cond
    5.76 +               (zero? speed) :stop
    5.77 +               (= prev from) (if (pos? speed) :start :stop)               
    5.78 +               (= prev to) (if (neg? speed) :start :stop)
    5.79 +               :default :continue)]
    5.80 +    (if (= state :stop)
    5.81 +       prev
    5.82 +       (let [interval (if (= state :start) 1 *interval*)
    5.83 +             step (* speed interval 1E-9)
    5.84 +             val (swap! atom #(-> % (+ step) (max from) (min to)))]
    5.85 +         (repaint)
    5.86 +         val))))
    5.87 +
    5.88 +(defn animated-button
    5.89 +  "Creates an animated button."
    5.90 +  [content callback & args]
    5.91 +  (let [padding 4
    5.92 +        border-width 1
    5.93 +        shadow-offset 2
    5.94 +        face (border padding border-width content)
    5.95 +        highlight (atom 0)
    5.96 +        animation-speed (atom 0)]
    5.97 +    (interval-view
    5.98 +     (reify
    5.99 +      View
   5.100 +      (render! [button]
   5.101 +        (with-handlers button
   5.102 +          (let [hovered (hovered? button)
   5.103 +                offset (if (picked? button) (/ shadow-offset 2) 0)
   5.104 +                color (combine-colors
   5.105 +                       (:alt-back-color *theme*) Color/WHITE
   5.106 +                       (animate highlight 0.0 1.0 @animation-speed))
   5.107 +                width (- *width* shadow-offset)
   5.108 +                height (- *height* shadow-offset)]
   5.109 +            (with-color (:shadow-color *theme*)
   5.110 +              (.fillRect *graphics*
   5.111 +                         shadow-offset shadow-offset
   5.112 +                         width height))
   5.113 +            (with-color color
   5.114 +              (.fillRect *graphics* offset offset width height))
   5.115 +            (draw! offset offset width height
   5.116 +                   (border border-width padding content)))
   5.117 +          ;; Event handlers
   5.118 +          (:mouse-entered _
   5.119 +            (reset! animation-speed 4)
   5.120 +            (repaint))
   5.121 +          (:mouse-exited _
   5.122 +            (reset! animation-speed -2)
   5.123 +            (repaint))
   5.124 +          (:mouse-pressed _ (repaint))
   5.125 +          (:mouse-released _ (repaint))
   5.126 +          (:mouse-clicked _ (apply callback args))))
   5.127 +     (geometry [button]
   5.128 +       (let [face-geom (geometry face)]
   5.129 +         (->Size (+ (width face-geom) shadow-offset)
   5.130 +                 (+ (height face-geom) shadow-offset))))))))
   5.131 +
   5.132 +(def button1 (animated-button (label "Animated button 1")
   5.133 +                              println "Animated button 1 clicked"))
   5.134 +
   5.135 +(def button2 (animated-button (label "Animated button 2")
   5.136 +                              println "Animated button 2 clicked"))
   5.137 +
   5.138 +(def test-view1
   5.139 +  (reify
   5.140 +   View
   5.141 +   (render! [view]
   5.142 +     (with-handlers view
   5.143 +       (with-color (if (hovered? view) Color/ORANGE Color/RED)
   5.144 +         (.fillRect *graphics* 0 0 *width* *height*))
   5.145 +       (:mouse-entered e
   5.146 +        (repaint)
   5.147 +        (println e))
   5.148 +       (:mouse-exited e
   5.149 +        (repaint)
   5.150 +        (println e))
   5.151 +       (:mouse-moved e
   5.152 +        (println e))))
   5.153 +   (geometry [view]
   5.154 +     (->Size 30 20))))
   5.155 +
   5.156 +(def test-view1b (border 2 3 test-view1))
   5.157 +
   5.158 +(def test-view2
   5.159 +  (reify
   5.160 +   View
   5.161 +   (render! [view]
   5.162 +     (doto *graphics*
   5.163 +       (.setColor Color/YELLOW)
   5.164 +       (.fillRect 0 0 *width* *height*))
   5.165 +     (with-rotate 0.5 0 0
   5.166 +       (draw! 30 25 test-view1b))
   5.167 +     (draw! 55 5 test-view1))
   5.168 +   (geometry [view]
   5.169 +     (->Size 70 65))))
   5.170 +
   5.171 +(def test-view2m (miniature 30 30 test-view2))
   5.172 +
   5.173 +(def test-view3 (border (label :right :bottom "Sample\ntext")))
   5.174 +
   5.175 +(def root
   5.176 +  (reify
   5.177 +   View
   5.178 +   (render! [view]
   5.179 +     ;;(repaint)
   5.180 +     (doto *graphics*
   5.181 +       (.drawLine 0 0 *width* *height*)
   5.182 +       (.drawLine *width* 0 0 *height*)
   5.183 +       ;; Random color to see when repaint happens.
   5.184 +       (.setColor (rand-nth [Color/BLACK Color/BLUE Color/RED]))
   5.185 +       (.fillOval 5 5 20 20))
   5.186 +     (draw! 30 20 test-view2)
   5.187 +     (draw! 120 50 test-view2m)
   5.188 +     (draw! 100 100 80 50 test-view3)
   5.189 +     (draw! 50 160 button1)
   5.190 +     (with-rotate (/ Math/PI 6) 250 200
   5.191 +       (draw! 210 140 button1))
   5.192 +     (draw! 100 200 button2)
   5.193 +     (with-bounds 180 240 140 30
   5.194 +       (draw-button! :button
   5.195 +        (label :center :center "Immediate button")
   5.196 +        #(println "Button clicked!"))))
   5.197 +   (geometry [view]
   5.198 +     (->Size 400 300))))
   5.199 +
   5.200 +;; Main viewport
   5.201 +(def vp (viewport root))
   5.202 +
   5.203 +;; Miniature (rendered asynchronously)
   5.204 +(def vp-miniature (->> vp (viewport-miniature 100 75) border shadow))
   5.205 +
   5.206 +;; Main scene
   5.207 +(def scene
   5.208 +  (fps-view
   5.209 +   (decorate-view vp [_]
   5.210 +     (draw! vp)
   5.211 +     (draw-aligned!
   5.212 +      :left :bottom 5 (- *height* 5)
   5.213 +      (label (str "Drag mouse to pan," \newline
   5.214 +                  "use mouse wheel to zoom.")))
   5.215 +     (draw! (- *width* 105) 5 vp-miniature))))
   5.216 +
   5.217 +(defn show-frame [view]
   5.218 +  (doto (make-jframe "Test" view)
   5.219 +    (.setDefaultCloseOperation JFrame/DISPOSE_ON_CLOSE)
   5.220 +    (.setVisible true)))
   5.221 +
   5.222 +(defn -main []
   5.223 +  (show-frame scene))
   5.224 +
   5.225 +(comment
   5.226 +  (show-frame (viewport-miniature 200 150 vp)))

     6.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     6.2 +++ b/src/indyvon/viewport.clj	Mon Apr 14 20:01:00 2014 +0400
     6.3 @@ -0,0 +1,238 @@
     6.4 +;;
     6.5 +;; Copyright 2010-2014 Mikhail Kryshen <mikhail@kryshen.net>
     6.6 +;;
     6.7 +;; This file is part of Indyvon.
     6.8 +;;
     6.9 +;; Indyvon is free software: you can redistribute it and/or modify it
    6.10 +;; under the terms of the GNU Lesser General Public License version 3
    6.11 +;; only, as published by the Free Software Foundation.
    6.12 +;;
    6.13 +;; Indyvon is distributed in the hope that it will be useful, but
    6.14 +;; WITHOUT ANY WARRANTY; without even the implied warranty of
    6.15 +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
    6.16 +;; Lesser General Public License for more details.
    6.17 +;;
    6.18 +;; You should have received a copy of the GNU Lesser General Public
    6.19 +;; License along with Indyvon.  If not, see
    6.20 +;; <http://www.gnu.org/licenses/>.
    6.21 +;;
    6.22 +
    6.23 +(ns indyvon.viewport
    6.24 +  "Scrollable viewport and miniature."
    6.25 +  (:use
    6.26 +   (indyvon core async views))
    6.27 +  (:import
    6.28 +   java.awt.Cursor
    6.29 +   java.awt.geom.AffineTransform))
    6.30 +  
    6.31 +;;(defn- translate [^AffineTransform transform ^double x ^double y]
    6.32 +;;  (doto ^AffineTransform (.clone transform)
    6.33 +;;        (.translate x y)))
    6.34 +
    6.35 +(defn- scale [^AffineTransform transform ^double sx ^double sy]
    6.36 +    (doto ^AffineTransform (.clone transform)
    6.37 +        (.scale sx sy)))
    6.38 +
    6.39 +(defn- pre-translate [^AffineTransform transform ^double x ^double y]
    6.40 +  (if (== 0.0 x y)
    6.41 +    transform
    6.42 +    (doto (AffineTransform/getTranslateInstance x y)
    6.43 +      (.concatenate transform))))
    6.44 +
    6.45 +(def ^:dynamic *viewport-scaling-step* (double 3/4))
    6.46 +(def ^:dynamic *viewport-min-scale* 1E-6)
    6.47 +(def ^:dynamic *viewport-max-scale* 1E6)
    6.48 +
    6.49 +(def ^:dynamic *viewport* nil)
    6.50 +(def ^:dynamic ^AffineTransform *viewport-transform*)
    6.51 +
    6.52 +(declare scale-viewport!)
    6.53 +
    6.54 +(defrecord ViewportState [transform
    6.55 +                          fix-x fix-y
    6.56 +                          last-width last-height
    6.57 +                          last-anchor-x last-anchor-y])
    6.58 +
    6.59 +(defn- update-viewport [state content-geom h-align v-align]
    6.60 +  (let [w *width*
    6.61 +        h *height*
    6.62 +        cw (width content-geom)
    6.63 +        ch (height content-geom)
    6.64 +        ax (anchor-x content-geom h-align cw)
    6.65 +        ay (anchor-y content-geom v-align ch)
    6.66 +        ax1 (align-x h-align (:last-width state) w)
    6.67 +        ay1 (align-y v-align (:last-height state) h)
    6.68 +        ax2 (- (:last-anchor-x state) ax)
    6.69 +        ay2 (- (:last-anchor-y state) ay)
    6.70 +        transform (:transform state)
    6.71 +        transform (if (and (zero? ax1) (zero? ay1)
    6.72 +                           (zero? ax2) (zero? ay2))
    6.73 +                    transform
    6.74 +                    (doto
    6.75 +                        (AffineTransform/getTranslateInstance ax1 ay1)
    6.76 +                      (.concatenate transform)
    6.77 +                      (.translate ax2 ay2)))]
    6.78 +    (assoc state
    6.79 +      :last-width w
    6.80 +      :last-height h
    6.81 +      :last-anchor-x ax
    6.82 +      :last-anchor-y ay
    6.83 +      :transform transform)))
    6.84 +
    6.85 +(defrecord Viewport [content h-align v-align state]
    6.86 +  View
    6.87 +  (render! [view]
    6.88 +    (repaint-on-update view)
    6.89 +    (with-handlers view
    6.90 +      (let [geom (geometry content)
    6.91 +            new-state (swap! state update-viewport geom h-align v-align)
    6.92 +            transform (:transform new-state)]
    6.93 +        ;; TODO: notify observers when size changes.
    6.94 +        (binding [*viewport* view
    6.95 +                  *viewport-transform* transform]
    6.96 +          (with-transform transform
    6.97 +            (draw! 0 0 (width geom) (height geom) false content))))
    6.98 +      (:mouse-pressed e
    6.99 +       (swap! state assoc
   6.100 +              :fix-x (:x-on-screen e)
   6.101 +              :fix-y (:y-on-screen e))
   6.102 +       (set-cursor! (Cursor. Cursor/MOVE_CURSOR)))
   6.103 +      (:mouse-released e
   6.104 +       (set-cursor! (Cursor. Cursor/DEFAULT_CURSOR)))
   6.105 +      (:mouse-dragged e
   6.106 +       (swap! state
   6.107 +              (fn [s]
   6.108 +                (assoc s
   6.109 +                  :transform (pre-translate
   6.110 +                              (:transform s)
   6.111 +                              (- (:x-on-screen e) (:fix-x s))
   6.112 +                              (- (:y-on-screen e) (:fix-y s)))
   6.113 +                  :fix-x (:x-on-screen e)
   6.114 +                  :fix-y (:y-on-screen e))))
   6.115 +       (update view))
   6.116 +      (:mouse-wheel e
   6.117 +       (scale-viewport!
   6.118 +        view
   6.119 +        (Math/pow *viewport-scaling-step* (:wheel-rotation e))
   6.120 +        true (:x e) (:y e)))))
   6.121 +  (geometry [_]
   6.122 +    (geometry content)))
   6.123 +
   6.124 +(def ^:private viewport-initial-state
   6.125 +  (->ViewportState
   6.126 +   (AffineTransform.) ; transform
   6.127 +   0 0                ; fix-x fix-y
   6.128 +   0 0                ; last-width last-height
   6.129 +   0 0))
   6.130 +
   6.131 +(defn viewport
   6.132 +  "Creates scrollable viewport view."
   6.133 +  ([content]
   6.134 +     (viewport :left :top content))
   6.135 +  ([h-align v-align content]
   6.136 +     (->Viewport content h-align v-align (atom viewport-initial-state))))
   6.137 +
   6.138 +(defn- scale-viewport [state vp s relative? x y]
   6.139 +  (let [^AffineTransform tr (:transform state)
   6.140 +        sx (if relative? s (/ s (.getScaleX tr)))
   6.141 +        sy (if relative? s (/ s (.getScaleY tr)))
   6.142 +        x (or x (align-x (:h-align vp) (:last-width state)))
   6.143 +        y (or y (align-y (:v-align vp) (:last-height state)))
   6.144 +        x (- x (* x sx))
   6.145 +        y (- y (* y sy))
   6.146 +        scaled (doto (AffineTransform/getTranslateInstance x y)
   6.147 +                 (.scale sx sy)
   6.148 +                 (.concatenate tr))
   6.149 +        sx (.getScaleX scaled)
   6.150 +        sy (.getScaleY scaled)]
   6.151 +    (if (<= *viewport-min-scale*
   6.152 +            (min sx sy)
   6.153 +            (max sx sy)
   6.154 +            *viewport-max-scale*)
   6.155 +      (assoc state
   6.156 +        :transform scaled)
   6.157 +      state)))
   6.158 +
   6.159 +(defn scale-viewport!
   6.160 +  ([viewport s]
   6.161 +     (scale-viewport! viewport s true))
   6.162 +  ([viewport s relative?]
   6.163 +     (scale-viewport! viewport s relative? nil nil))
   6.164 +  ([viewport s relative? x y]
   6.165 +     (swap! (:state viewport) scale-viewport viewport s relative? x y)
   6.166 +     (update viewport)))
   6.167 +
   6.168 +(defn reset-viewport! [viewport]
   6.169 +  (reset! (:state viewport) viewport-initial-state)
   6.170 +  (update viewport))
   6.171 +
   6.172 +(defn ^AffineTransform viewport-transform [viewport]
   6.173 +  (:transform @(:state viewport)))
   6.174 +
   6.175 +(defn- scaling
   6.176 +  [width height max-width max-height]
   6.177 +  (min (/ max-width width)
   6.178 +       (/ max-height height)))
   6.179 +
   6.180 +(defn miniature
   6.181 +  "Creates a view that asynchronously renders the content view scaled to
   6.182 +  the specified size."
   6.183 +  [mw mh content]
   6.184 +  (async-view
   6.185 +   mw mh *miniature-thread-priority*
   6.186 +   (reify
   6.187 +    View
   6.188 +    (render! [this]
   6.189 +      (let [geom (geometry content)
   6.190 +            cw (width geom)
   6.191 +            ch (height geom)
   6.192 +            s (scaling cw ch mw mh)]
   6.193 +        (.scale *graphics* s s)
   6.194 +        (draw! (align-x :center cw (/ mw s))
   6.195 +               (align-y :center ch (/ mh s))
   6.196 +               cw ch
   6.197 +               content)))
   6.198 +    (geometry [_]
   6.199 +      (->Size mw mh)))))
   6.200 +
   6.201 +(defn viewport-miniature
   6.202 +  "Creates miniature view of the viewport's contents."
   6.203 +  [m-width m-height viewport]
   6.204 +  (let [miniature (miniature m-width m-height (:content viewport))]
   6.205 +    (decorate-view miniature [l]
   6.206 +      (repaint-on-update viewport)
   6.207 +      (let [geom (geometry (:content viewport))
   6.208 +            s (scaling (width geom) (height geom) m-width m-height)
   6.209 +            vp-state @(:state viewport)
   6.210 +            {:keys [transform last-width last-height]} @(:state viewport)
   6.211 +            ox (align-x :center (width geom) (/ m-width s))
   6.212 +            oy (align-y :center (height geom) (/ m-height s))
   6.213 +            inverse (.createInverse ^AffineTransform transform)
   6.214 +            transform (doto (AffineTransform.)
   6.215 +                        (.scale s s)
   6.216 +                        (.translate ox oy)
   6.217 +                        (.concatenate inverse))
   6.218 +            move-vp (fn [state x y]
   6.219 +                      (let [x (- (/ x s) ox)
   6.220 +                            y (- (/ y s) oy)
   6.221 +                            tr (:transform state)
   6.222 +                            [x y] (transform-point tr x y)
   6.223 +                            x (- x (/ (:last-width state) 2))
   6.224 +                            y (- y (/ (:last-height state) 2))]
   6.225 +                        (assoc state
   6.226 +                          :transform (pre-translate tr (- x) (- y)))))
   6.227 +            move-vp! (fn [x y]
   6.228 +                       (swap! (:state viewport) move-vp x y)
   6.229 +                       (update viewport))]
   6.230 +        (with-color :alt-back-color
   6.231 +          (.fillRect *graphics* 0 0 *width* *height*))
   6.232 +        (with-transform transform
   6.233 +          (with-color :back-color
   6.234 +            (.fillRect *graphics* 0 0 last-width last-height)))
   6.235 +        (with-handlers l
   6.236 +          (draw! miniature)
   6.237 +          (:mouse-pressed e (move-vp! (:x e) (:y e)))
   6.238 +          (:mouse-dragged e (move-vp! (:x e) (:y e))))
   6.239 +        (with-transform transform
   6.240 +          (with-color :border-color
   6.241 +            (.drawRect *graphics* 0 0 last-width last-height)))))))

     7.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     7.2 +++ b/src/indyvon/views.clj	Mon Apr 14 20:01:00 2014 +0400
     7.3 @@ -0,0 +1,410 @@
     7.4 +;;
     7.5 +;; Copyright 2010-2014 Mikhail Kryshen <mikhail@kryshen.net>
     7.6 +;;
     7.7 +;; This file is part of Indyvon.
     7.8 +;;
     7.9 +;; Indyvon is free software: you can redistribute it and/or modify it
    7.10 +;; under the terms of the GNU Lesser General Public License version 3
    7.11 +;; only, as published by the Free Software Foundation.
    7.12 +;;
    7.13 +;; Indyvon is distributed in the hope that it will be useful, but
    7.14 +;; WITHOUT ANY WARRANTY; without even the implied warranty of
    7.15 +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
    7.16 +;; Lesser General Public License for more details.
    7.17 +;;
    7.18 +;; You should have received a copy of the GNU Lesser General Public
    7.19 +;; License along with Indyvon.  If not, see
    7.20 +;; <http://www.gnu.org/licenses/>.
    7.21 +;;
    7.22 +
    7.23 +(ns indyvon.views
    7.24 +  "Implementations of the View protocol."
    7.25 +  (:use
    7.26 +   (indyvon core async))
    7.27 +  (:import
    7.28 +   (java.awt Font Image Toolkit)
    7.29 +   java.awt.image.ImageObserver
    7.30 +   (java.awt.geom Area AffineTransform Rectangle2D$Double Point2D
    7.31 +                  Point2D$Double)
    7.32 +   (java.awt.font FontRenderContext TextLayout)
    7.33 +   java.util.concurrent.TimeUnit
    7.34 +   (com.google.common.cache Cache CacheBuilder CacheLoader)))
    7.35 +
    7.36 +(defmacro decorate-view
    7.37 +  "Decorate the view replacing render! implementation."
    7.38 +  [view & render-tail]
    7.39 +  `(let [view# ~view]
    7.40 +     (reify
    7.41 +       View
    7.42 +       (render! ~@render-tail)
    7.43 +       (geometry [t#] (geometry view#)))))
    7.44 +
    7.45 +(defrecord Empty []
    7.46 +  View
    7.47 +  (render! [_])
    7.48 +  (geometry [_]
    7.49 +    (->Size 0 0)))
    7.50 +
    7.51 +(def empty-view (->Empty))
    7.52 +
    7.53 +;; TODO: change argument order for decorators, content should be the
    7.54 +;; last.
    7.55 +
    7.56 +(defn padding
    7.57 +  "Adds padding to the content view."
    7.58 +  ([distance content]
    7.59 +     (padding distance distance distance distance content))
    7.60 +  ([top left bottom right content]
    7.61 +     (if (== 0 top left bottom right)
    7.62 +       content
    7.63 +       (reify
    7.64 +        View
    7.65 +        (render! [l]
    7.66 +           (draw! left top
    7.67 +                  (- *width* left right)
    7.68 +                  (- *height* top bottom)
    7.69 +                  false
    7.70 +                  content))
    7.71 +        (geometry [l]
    7.72 +          (->NestedGeometry (geometry content) top left bottom right))))))
    7.73 +
    7.74 +(defn border
    7.75 +  "Adds a border to the content view."
    7.76 +  ([content]
    7.77 +     (border 1 content))
    7.78 +  ([thickness content]
    7.79 +     (border thickness 0 content))
    7.80 +  ([thickness gap content]
    7.81 +     (let [view (padding (+ thickness gap) content)
    7.82 +           t (double thickness)]
    7.83 +       (decorate-view view [_]
    7.84 +         (render! view)
    7.85 +         (with-color :border-color
    7.86 +           (let [w (double *width*)
    7.87 +                 h (double *height*)
    7.88 +                 outer (Area. (Rectangle2D$Double. 0.0 0.0 w h))
    7.89 +                 inner (Area. (Rectangle2D$Double. t t (- w t t) (- h t t)))]
    7.90 +             (.subtract outer inner)
    7.91 +             (.fill *graphics* outer)))))))
    7.92 +
    7.93 +;; TODO: opacity and blur.
    7.94 +(defn shadow
    7.95 +  "Adds a shadow to the content view."
    7.96 +  ([content]
    7.97 +     (shadow 1 1 content))
    7.98 +  ([x-offset y-offset content]
    7.99 +     (let [x (if (neg? x-offset) (- x-offset) 0)
   7.100 +           y (if (neg? y-offset) (- y-offset) 0)
   7.101 +           abs-x (if (neg? x-offset) (- x-offset) x-offset)
   7.102 +           abs-y (if (neg? y-offset) (- y-offset) y-offset)
   7.103 +           shadow-x (+ x-offset x)
   7.104 +           shadow-y (+ y-offset y)]
   7.105 +       (reify
   7.106 +        View
   7.107 +        (render! [_]
   7.108 +          (let [w (- *width* abs-x)
   7.109 +                h (- *height* abs-y)]
   7.110 +            (with-color :shadow-color
   7.111 +              (.fillRect *graphics* shadow-x shadow-y w h))
   7.112 +            (draw! x y w h content)))
   7.113 +        (geometry [_]
   7.114 +          (->NestedGeometry (geometry content)
   7.115 +                            y x shadow-y shadow-x))))))
   7.116 +
   7.117 +(defn panel
   7.118 +  "An opaque view using theme's alt-back-color or a custom background
   7.119 +  color."
   7.120 +  ([content]
   7.121 +     (panel :alt-back-color content))
   7.122 +  ([back-color content]
   7.123 +     (decorate-view content [_]
   7.124 +       (with-color back-color
   7.125 +         (.fill *graphics* (Rectangle2D$Double. 0.0 0.0 *width* *height*)))
   7.126 +       (render! content))))
   7.127 +
   7.128 +(defn hbox
   7.129 +  "Creates a view that draws the specified content views placing them
   7.130 +   horizontally."
   7.131 +  [& contents]
   7.132 +  (reify
   7.133 +   View
   7.134 +   (render! [_]
   7.135 +     (let [widths (map #(width (geometry %)) contents)
   7.136 +           xs (cons 0 (reductions + widths))
   7.137 +           widths-sum (last xs)
   7.138 +           scale (/ *width* widths-sum)]
   7.139 +       (doseq [[c w x] (map vector contents widths xs)]
   7.140 +         (draw! x 0 w *height* c))))
   7.141 +   (geometry [_]
   7.142 +     (reduce #(->Size (+ (width %1) (width %2))
   7.143 +                      (max (height %1) (height %2)))
   7.144 +             (->Size 0 0)
   7.145 +             (map geometry contents)))))
   7.146 +
   7.147 +(defn vbox
   7.148 +  "Creates a view that draws the specified content views placing them
   7.149 +   vertically."
   7.150 +  [& contents]
   7.151 +  (reify
   7.152 +   View
   7.153 +   (render! [_]
   7.154 +     (let [heights (map #(height (geometry %)) contents)
   7.155 +           ys (cons 0 (reductions + heights))
   7.156 +           heights-sum (last ys)
   7.157 +           scale (/ *height* heights-sum)]
   7.158 +       (doseq [[c h y] (map vector contents heights ys)]
   7.159 +         (draw! 0 y *width* h c))))
   7.160 +   (geometry [_]
   7.161 +     (reduce #(->Size (max (width %1) (width %2))
   7.162 +                      (+ (height %1) (height %2)))
   7.163 +             (->Size 0 0)
   7.164 +             (map geometry contents)))))
   7.165 +
   7.166 +(defn- re-split [^java.util.regex.Pattern re s]
   7.167 +  (seq (.split re s)))
   7.168 +
   7.169 +(def ^:private ^Cache text-layout-cache
   7.170 +  (-> (CacheBuilder/newBuilder)
   7.171 +      (.softValues)
   7.172 +      (.expireAfterAccess (long 1) TimeUnit/SECONDS)
   7.173 +      (.build)))
   7.174 +
   7.175 +(defn- get-text-layout
   7.176 +  [^String line ^Font font ^FontRenderContext font-context]
   7.177 +  (.get text-layout-cache [line font font-context]
   7.178 +        #(TextLayout. line font font-context)))
   7.179 +
   7.180 +(defn- layout-text
   7.181 +  [lines font font-context]
   7.182 +  (map #(get-text-layout % font font-context) lines))
   7.183 +
   7.184 +(defn- text-width [layouts]
   7.185 +  (reduce (fn [w ^TextLayout tl] (max w (.getAdvance tl))) 0 layouts))
   7.186 +
   7.187 +(defn- text-height [layouts]
   7.188 +  (reduce (fn [w ^TextLayout tl]
   7.189 +            (+ w (.getAscent tl)
   7.190 +               (.getDescent tl)
   7.191 +               (.getLeading tl)))
   7.192 +          0 layouts))
   7.193 +
   7.194 +(defn label
   7.195 +  "Creates a view to display multiline text."
   7.196 +  ([text]
   7.197 +     (label :left :top text))
   7.198 +  ([h-align v-align text]
   7.199 +     (let [lines (re-split #"\r\n|\n|\r|\u0085|\u2028|\u2029" (str text))]
   7.200 +       (reify View
   7.201 +        (render! [view]
   7.202 +          (let [w *width*
   7.203 +                h *height*
   7.204 +                font (.getFont *graphics*)
   7.205 +                layouts (layout-text lines font (font-context))
   7.206 +                y (align-y v-align (text-height layouts) h)]
   7.207 +            (loop [layouts layouts, y y]
   7.208 +              (when-first [^TextLayout layout layouts]
   7.209 +                (let [ascent (.getAscent layout)
   7.210 +                      lh (+ ascent (.getDescent layout) (.getLeading layout))
   7.211 +                      x (align-x h-align (.getAdvance layout) w)]
   7.212 +                  (.draw layout *graphics* x (+ y ascent))
   7.213 +                  (recur (next layouts) (+ y lh)))))))
   7.214 +        (geometry [view]
   7.215 +          (let [layouts (layout-text lines (:font *theme*) (font-context))
   7.216 +                w (text-width layouts)
   7.217 +                h (text-height layouts)]
   7.218 +            (->Size w h)))))))
   7.219 +
   7.220 +(defn- ^ImageObserver image-observer [view]
   7.221 +  (reify
   7.222 +   ImageObserver
   7.223 +   (imageUpdate [this img infoflags x y width height]
   7.224 +     (update view)
   7.225 +     (zero? (bit-and infoflags
   7.226 +                     (bit-or ImageObserver/ALLBITS
   7.227 +                             ImageObserver/ABORT))))))
   7.228 +
   7.229 +(defn image-view
   7.230 +  [image-or-uri]
   7.231 +  (let [^Image image (if (instance? Image image-or-uri)
   7.232 +                       image-or-uri
   7.233 +                       (.getImage (Toolkit/getDefaultToolkit)
   7.234 +                                  ^java.net.URL image-or-uri))]
   7.235 +    (.prepareImage (Toolkit/getDefaultToolkit) image -1 -1 nil)
   7.236 +    (reify
   7.237 +     View
   7.238 +     (render! [view]
   7.239 +       (repaint-on-update view)
   7.240 +       (.drawImage *graphics* image 0 0 (image-observer view)))
   7.241 +     (geometry [view]
   7.242 +       (let [observer (image-observer view)
   7.243 +             width (.getWidth image observer)
   7.244 +             height (.getHeight image observer)
   7.245 +             width (if (pos? width) width 1)
   7.246 +             height (if (pos? height) height 1)]
   7.247 +         (->Size width height))))))
   7.248 +
   7.249 +(def ^:dynamic *miniature-thread-priority* 2)
   7.250 +
   7.251 +(defn ref-view
   7.252 +  [view-ref]
   7.253 +  (let [l (reify
   7.254 +           View
   7.255 +           (render! [l]
   7.256 +             (repaint-on-update l)
   7.257 +             (if-let [view @view-ref]
   7.258 +               (render! view)))
   7.259 +           (geometry [_]
   7.260 +             (if-let [view @view-ref]
   7.261 +               (geometry view)
   7.262 +               (->Size 1 1))))]
   7.263 +    (add-watch view-ref l (fn [_ _ _ _] (update l)))
   7.264 +    l))
   7.265 +
   7.266 +;;
   7.267 +;; View context decorators
   7.268 +;;
   7.269 +
   7.270 +(defmacro handler [view & handlers]
   7.271 +  "Adds event handling to the view."
   7.272 +  `(let [view# ~view]
   7.273 +     (decorate-view view# [t#]
   7.274 +       (with-handlers t#
   7.275 +         (render! view#)
   7.276 +         ~@handlers))))
   7.277 +
   7.278 +(defn themed [view & map-or-keyvals]
   7.279 +  (let [theme (if (== (count map-or-keyvals) 1)
   7.280 +                (first map-or-keyvals)
   7.281 +                (apply array-map map-or-keyvals))]
   7.282 +    (reify
   7.283 +     View
   7.284 +     (render! [_]
   7.285 +       (with-theme theme
   7.286 +         (render! view)))
   7.287 +     (geometry [_]
   7.288 +       (with-theme theme
   7.289 +         (geometry view))))))
   7.290 +
   7.291 +(defn hinted [view & map-or-keyvals]
   7.292 +  (let [hints (if (== (count map-or-keyvals) 1)
   7.293 +                (first map-or-keyvals)
   7.294 +                (apply array-map map-or-keyvals))]
   7.295 +    (decorate-view view [_]
   7.296 +      (with-hints* hints render! view))))
   7.297 +
   7.298 +;;
   7.299 +;; Measuring time
   7.300 +;;
   7.301 +
   7.302 +(def ^:dynamic *interval*)
   7.303 +
   7.304 +(defn interval-view
   7.305 +  "Creates a view that measures time between repaints ant draws it's
   7.306 +  content with the *interval* var bound to the measured time."
   7.307 +  [content]
   7.308 +  (let [last-time (atom nil)]
   7.309 +    (decorate-view content [_]
   7.310 +      (compare-and-set! last-time nil *time*)
   7.311 +      (let [lt @last-time]
   7.312 +        (binding [*interval* (if (compare-and-set! last-time lt *time*)
   7.313 +                               (- *time* lt)
   7.314 +                               0)] ; already measured on parallel thread
   7.315 +          (render! content))))))
   7.316 +
   7.317 +(defn- fps-label [text]
   7.318 +  (padding 5 (label :right :bottom text)))
   7.319 +
   7.320 +(defn fps-view
   7.321 +  "Creates a view that draws content and displays the
   7.322 +  frames per second rate."
   7.323 +  [content]
   7.324 +  (let [update-interval 2E8 ; 0.2 s in nanoseconds
   7.325 +        frames (ref 0)
   7.326 +        prev-time (ref nil)
   7.327 +        display (ref (fps-label "fps n/a"))]
   7.328 +    (decorate-view content [_]
   7.329 +      (draw! content)
   7.330 +      (draw!
   7.331 +       (dosync
   7.332 +        (alter frames inc)
   7.333 +        (if @prev-time
   7.334 +          (let [elapsed (- *time* @prev-time)]
   7.335 +            (when (> elapsed update-interval)
   7.336 +              (let [fps (/ @frames (/ elapsed 1E9))]
   7.337 +                (ref-set display (fps-label (format "%.1f" fps)))
   7.338 +                (ref-set frames 0)
   7.339 +                (ref-set prev-time *time*))))
   7.340 +          (ref-set prev-time *time*))
   7.341 +        @display)))))
   7.342 +
   7.343 +;;
   7.344 +;; Overlays
   7.345 +;;
   7.346 +
   7.347 +(def ^:private ^:dynamic *above*)
   7.348 +
   7.349 +(defn- overlay* [f & args]
   7.350 +  (var-set #'*above* (conj *above* (apply partial f args))))
   7.351 +
   7.352 +(defn- ^Point2D to-graphics-coords
   7.353 +  [^AffineTransform transform x y]
   7.354 +  (let [p (Point2D$Double. x y)]
   7.355 +    (.transform transform p p)
   7.356 +    (.transform (.createInverse (.getTransform *graphics*)) p p)
   7.357 +    p))
   7.358 +
   7.359 +(defn- draw-relative!
   7.360 +  ([transform x y view]
   7.361 +     (let [p (to-graphics-coords transform x y)]
   7.362 +       (draw! (.getX p) (.getY p) view)))
   7.363 +  ([transform x y w h view]
   7.364 +     (let [p (to-graphics-coords transform x y)]
   7.365 +       (draw! (.getX p) (.getY p) w h view))))
   7.366 +
   7.367 +(defn- draw-relative-aligned!
   7.368 +  [transform h-align v-align x y view]
   7.369 +  (let [geom (geometry view)
   7.370 +        w (width geom)
   7.371 +        h (height geom)
   7.372 +        p (to-graphics-coords transform x y)
   7.373 +        x (- (.getX p) (anchor-x geom h-align w))
   7.374 +        y (- (.getY p) (anchor-y geom v-align h))]
   7.375 +    (draw! x y w h view)))
   7.376 +
   7.377 +(defn overlay!
   7.378 +  "Draws view in the overlay context above the other views."
   7.379 +  ([view]
   7.380 +     (overlay* draw-relative! (.getTransform *graphics*) 0 0 view))
   7.381 +  ([x y view]
   7.382 +     (overlay* draw-relative! (.getTransform *graphics*) x y view))
   7.383 +  ([x y w h view]
   7.384 +     (overlay* draw-relative! (.getTransform *graphics*) x y w h view)))
   7.385 +
   7.386 +(defn overlay-aligned! [h-align v-align x y view]
   7.387 +  (overlay* draw-relative-aligned!
   7.388 +            (.getTransform *graphics*)
   7.389 +            h-align v-align x y
   7.390 +            view))
   7.391 +
   7.392 +(defn with-overlays* [rec? f & args]
   7.393 +  (binding [*above* []]
   7.394 +    (apply f args)
   7.395 +    (if rec?
   7.396 +      (loop [above *above*]
   7.397 +        (when (seq above)
   7.398 +          (var-set #'*above* [])
   7.399 +          (doseq [f above]
   7.400 +            (f))
   7.401 +          (recur *above*)))
   7.402 +      (doseq [of *above*]
   7.403 +        (of)))))
   7.404 +
   7.405 +(defmacro with-overlays [rec? & body]
   7.406 +  `(with-overlays* ~rec? (fn [] ~@body)))
   7.407 +
   7.408 +(defn layered
   7.409 +  ([content]
   7.410 +     (layered true content))
   7.411 +  ([rec? content]
   7.412 +     (decorate-view content [_]
   7.413 +       (with-overlays* rec? render! content))))

     8.1 --- a/src/net/kryshen/indyvon/async.clj	Mon Apr 14 15:37:28 2014 +0400
     8.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
     8.3 @@ -1,178 +0,0 @@
     8.4 -;;
     8.5 -;; Copyright 2010-2014 Mikhail Kryshen <mikhail@kryshen.net>
     8.6 -;;
     8.7 -;; This file is part of Indyvon.
     8.8 -;;
     8.9 -;; Indyvon is free software: you can redistribute it and/or modify it
    8.10 -;; under the terms of the GNU Lesser General Public License version 3
    8.11 -;; only, as published by the Free Software Foundation.
    8.12 -;;
    8.13 -;; Indyvon is distributed in the hope that it will be useful, but
    8.14 -;; WITHOUT ANY WARRANTY; without even the implied warranty of
    8.15 -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
    8.16 -;; Lesser General Public License for more details.
    8.17 -;;
    8.18 -;; You should have received a copy of the GNU Lesser General Public
    8.19 -;; License along with Indyvon.  If not, see
    8.20 -;; <http://www.gnu.org/licenses/>.
    8.21 -;;
    8.22 -
    8.23 -(ns net.kryshen.indyvon.async
    8.24 -  "Asynchronous drawing."
    8.25 -  (:use
    8.26 -   net.kryshen.indyvon.core)
    8.27 -  (:import
    8.28 -   java.awt.GraphicsConfiguration
    8.29 -   (java.awt Image AlphaComposite Transparency)
    8.30 -   (java.awt.image BufferedImage)
    8.31 -   (java.util.concurrent ThreadFactory ThreadPoolExecutor
    8.32 -                         ThreadPoolExecutor$DiscardOldestPolicy
    8.33 -                         ArrayBlockingQueue TimeUnit)))
    8.34 -
    8.35 -(defrecord Buffer [id image readers state])
    8.36 -;; Buffer states:
    8.37 -;;   :front, readers > 0
    8.38 -;;      being copied on screen
    8.39 -;;   :back
    8.40 -;;      being rendered to (offscreen)
    8.41 -;;   :fresh
    8.42 -;;      most recently updated
    8.43 -;;   :free
    8.44 -;;      not in use
    8.45 -
    8.46 -(defn- create-image [async-view ^GraphicsConfiguration device-conf]
    8.47 -  ;; TODO: support different image types.
    8.48 -  (.createCompatibleImage device-conf
    8.49 -                          (:width async-view)
    8.50 -                          (:height async-view)
    8.51 -                          Transparency/TRANSLUCENT))
    8.52 -
    8.53 -(defn- create-buffer [async-view device-conf]
    8.54 -  (Buffer. (Object.) (create-image async-view device-conf) 0 :free))
    8.55 -
    8.56 -(defn- find-buffer
    8.57 -  "Find a buffer with the one of the specified states given
    8.58 -   in the order of preference."
    8.59 -  [buffers & states]
    8.60 -  (some identity
    8.61 -    (for [state states]
    8.62 -      (some #(if (= (:state %) state) % nil) buffers))))
    8.63 -
    8.64 -(defn- replace-buffer [buffers buffer]
    8.65 -  (conj (remove #(= (:id %) (:id buffer)) buffers)
    8.66 -        buffer))
    8.67 -
    8.68 -(defn- take-buffer [al type]
    8.69 -  (dosync
    8.70 -   (let [buffers @(:buffers al)
    8.71 -         b (case type
    8.72 -             :front (find-buffer buffers :front :fresh :free)
    8.73 -             :back (find-buffer buffers :free :fresh)
    8.74 -             (throw (IllegalArgumentException.)))
    8.75 -         readers (if (= type :front)
    8.76 -                   (inc (:readers b))
    8.77 -                   (:readers b))
    8.78 -         b (assoc b
    8.79 -             :state type
    8.80 -             :readers readers)]
    8.81 -     (alter (:buffers al) replace-buffer b)
    8.82 -     b)))
    8.83 -
    8.84 -(defn- release-buffer [al buffer]
    8.85 -  (dosync
    8.86 -   (let [state (:state buffer)
    8.87 -         readers (if (= state :front)
    8.88 -                   (dec (:readers buffer))
    8.89 -                   (:readers buffer))
    8.90 -         fresh (delay (find-buffer @(:buffers al) :fresh))
    8.91 -         state (cond
    8.92 -                (pos? readers) :front
    8.93 -                (= :back state) :fresh
    8.94 -                @fresh :free
    8.95 -                :default :fresh)]
    8.96 -     (if (and (= state :fresh) @fresh)
    8.97 -       ;; Change state of the prefiously fresh buffer to :free.
    8.98 -       (alter (:buffers al)
    8.99 -              replace-buffer (assoc @fresh
   8.100 -                               :state :free)))
   8.101 -     (alter (:buffers al)
   8.102 -            replace-buffer (assoc buffer
   8.103 -                             :state state
   8.104 -                             :readers readers)))))
   8.105 -
   8.106 -(defmacro with-buffer
   8.107 -  {:private true}
   8.108 -  [al type [name] & body]
   8.109 -  `(let [al# ~al
   8.110 -         ~name (take-buffer al# ~type)]
   8.111 -     (try
   8.112 -       ~@body
   8.113 -       (finally
   8.114 -        (release-buffer al# ~name)))))
   8.115 -
   8.116 -(defn- draw-offscreen [async-view]
   8.117 -  ;;(Thread/sleep 1000)
   8.118 -  (with-buffer async-view :back [b]
   8.119 -    (let [g (.createGraphics ^BufferedImage (:image b))]
   8.120 -      ;; Clear the buffer.
   8.121 -      (.setComposite g AlphaComposite/Clear)
   8.122 -      (.fillRect g 0 0 (:width async-view) (:height async-view))
   8.123 -      (.setComposite g AlphaComposite/Src)
   8.124 -      (draw-scene! (:scene async-view)
   8.125 -                   g
   8.126 -                   (:width async-view)
   8.127 -                   (:height async-view)))
   8.128 -    (update async-view)))
   8.129 -
   8.130 -(defn- draw-offscreen-async [async-view]
   8.131 -  (.execute ^ThreadPoolExecutor (:executor async-view)
   8.132 -            #(draw-offscreen async-view)))
   8.133 -
   8.134 -(defrecord AsyncView [scene width height executor buffers]
   8.135 -  View
   8.136 -  (render! [view]
   8.137 -    (repaint-on-update view)
   8.138 -    (add-context-observer scene (fn [_ _] (draw-offscreen-async view)))
   8.139 -    (when-not @buffers
   8.140 -      ;; TODO: dynamic size, recreate buffers when size increases.
   8.141 -      (let [device-conf (.getDeviceConfiguration *graphics*)
   8.142 -            new-buffers (repeatedly 2
   8.143 -                          (partial create-buffer view device-conf))]
   8.144 -        (dosync
   8.145 -         (ref-set buffers new-buffers)))
   8.146 -      (draw-offscreen-async view))
   8.147 -    (with-buffer view :front [b]
   8.148 -      (.drawImage *graphics* ^Image (:image b) 0 0 nil)))
   8.149 -  (geometry [view]
   8.150 -    (->Size width height)))
   8.151 -
   8.152 -(defn- create-thread-factory [priority]
   8.153 -  (reify
   8.154 -   ThreadFactory
   8.155 -   (newThread [_ runnable]
   8.156 -     (let [thread (Thread. runnable)]
   8.157 -       (when priority
   8.158 -         (.setPriority thread priority))
   8.159 -       (.setDaemon thread true)
   8.160 -       thread))))
   8.161 -
   8.162 -(defn- create-executor [priority]
   8.163 -  (doto (ThreadPoolExecutor.
   8.164 -         (int 1) (int 1)
   8.165 -         (long 0) TimeUnit/SECONDS
   8.166 -         (ArrayBlockingQueue. 1)
   8.167 -         (ThreadPoolExecutor$DiscardOldestPolicy.))
   8.168 -    (.setThreadFactory (create-thread-factory priority))))
   8.169 -
   8.170 -(defn async-view 
   8.171 -  "Creates a View that draws the content asynchronously using an
   8.172 -   offscreen buffer."
   8.173 -  ([width height content]
   8.174 -     (async-view width height nil content))
   8.175 -  ([width height priority content]
   8.176 -     ;; TODO: use operational event dispatcher.
   8.177 -     (->AsyncView (make-scene content)
   8.178 -                  width
   8.179 -                  height
   8.180 -                  (create-executor priority)
   8.181 -                  (ref nil))))

     9.1 --- a/src/net/kryshen/indyvon/component.clj	Mon Apr 14 15:37:28 2014 +0400
     9.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
     9.3 @@ -1,69 +0,0 @@
     9.4 -;;
     9.5 -;; Copyright 2010-2014 Mikhail Kryshen <mikhail@kryshen.net>
     9.6 -;;
     9.7 -;; This file is part of Indyvon.
     9.8 -;;
     9.9 -;; Indyvon is free software: you can redistribute it and/or modify it
    9.10 -;; under the terms of the GNU Lesser General Public License version 3
    9.11 -;; only, as published by the Free Software Foundation.
    9.12 -;;
    9.13 -;; Indyvon is distributed in the hope that it will be useful, but
    9.14 -;; WITHOUT ANY WARRANTY; without even the implied warranty of
    9.15 -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
    9.16 -;; Lesser General Public License for more details.
    9.17 -;;
    9.18 -;; You should have received a copy of the GNU Lesser General Public
    9.19 -;; License along with Indyvon.  If not, see
    9.20 -;; <http://www.gnu.org/licenses/>.
    9.21 -;;
    9.22 -
    9.23 -(ns net.kryshen.indyvon.component
    9.24 -  "Integrating Indyvon into AWT and Swing components."
    9.25 -  (:use
    9.26 -   net.kryshen.indyvon.core)
    9.27 -  (:import
    9.28 -   (java.awt Graphics Component Dimension Color)
    9.29 -   (java.awt.geom Rectangle2D$Double)
    9.30 -   (javax.swing JFrame JPanel JOptionPane)))
    9.31 -
    9.32 -(defn- paint-component [^Component c ^Graphics g scene]
    9.33 -  (let [w (.getWidth c)
    9.34 -        h (.getHeight c)]
    9.35 -    (.setColor g (:back-color *theme*))
    9.36 -    (.fillRect g 0 0 w h)
    9.37 -    (draw-scene! scene g w h)))
    9.38 -
    9.39 -(defn- preferred-size [^Component c scene]
    9.40 -  (let [geom (scene-geometry scene)]
    9.41 -    (Dimension. (width geom) (height geom))))
    9.42 -
    9.43 -(defn ^JPanel make-jpanel
    9.44 -  ([view]
    9.45 -     (make-jpanel view (root-event-dispatcher)))
    9.46 -  ([view event-dispatcher]
    9.47 -     (let [panel (proxy [JPanel] [])
    9.48 -           scene (make-scene
    9.49 -                  view event-dispatcher panel
    9.50 -                  (.getDesktopProperty (java.awt.Toolkit/getDefaultToolkit)
    9.51 -                                       "awt.font.desktophints"))]
    9.52 -       (update-proxy
    9.53 -        panel
    9.54 -        {"paintComponent" #(paint-component %1 %2 scene)
    9.55 -         "getPreferredSize" #(preferred-size % scene)})
    9.56 -       (.setBackground panel (:back-color *theme*))
    9.57 -       (add-observer panel scene (fn [w _]
    9.58 -                                   ;; Use the first observer argument
    9.59 -                                   ;; instead of closing over panel to
    9.60 -                                   ;; allow the panel and associated
    9.61 -                                   ;; observer to be gc'd.
    9.62 -                                   (.repaint ^Component w)))
    9.63 -       (listen! event-dispatcher panel)
    9.64 -       panel)))
    9.65 -
    9.66 -(defn ^JFrame make-jframe [^String title view]
    9.67 -  (doto (JFrame. title)
    9.68 -    (.. (getContentPane) (add (make-jpanel view)))
    9.69 -    (.pack)))
    9.70 -
    9.71 -(defn message [m]
    9.72 -  (JOptionPane/showMessageDialog (:component *scene*) m))

    10.1 --- a/src/net/kryshen/indyvon/core.clj	Mon Apr 14 15:37:28 2014 +0400
    10.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    10.3 @@ -1,881 +0,0 @@
    10.4 -;;
    10.5 -;; Copyright 2010-2014 Mikhail Kryshen <mikhail@kryshen.net>
    10.6 -;;
    10.7 -;; This file is part of Indyvon.
    10.8 -;;
    10.9 -;; Indyvon is free software: you can redistribute it and/or modify it
   10.10 -;; under the terms of the GNU Lesser General Public License version 3
   10.11 -;; only, as published by the Free Software Foundation.
   10.12 -;;
   10.13 -;; Indyvon is distributed in the hope that it will be useful, but
   10.14 -;; WITHOUT ANY WARRANTY; without even the implied warranty of
   10.15 -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
   10.16 -;; Lesser General Public License for more details.
   10.17 -;;
   10.18 -;; You should have received a copy of the GNU Lesser General Public
   10.19 -;; License along with Indyvon.  If not, see
   10.20 -;; <http://www.gnu.org/licenses/>.
   10.21 -;;
   10.22 -
   10.23 -(ns net.kryshen.indyvon.core
   10.24 -  (:import
   10.25 -   (java.awt Graphics2D RenderingHints Component Color Font Shape
   10.26 -             Rectangle Cursor EventQueue)
   10.27 -   (java.awt.geom AffineTransform Point2D$Double Rectangle2D$Double Area)
   10.28 -   (java.awt.event MouseListener MouseMotionListener
   10.29 -                   MouseWheelListener MouseWheelEvent)
   10.30 -   (java.awt.font FontRenderContext)
   10.31 -   java.util.concurrent.ConcurrentMap
   10.32 -   com.google.common.collect.MapMaker))
   10.33 -
   10.34 -;;
   10.35 -;; View context
   10.36 -;;
   10.37 -
   10.38 -(def ^:dynamic ^Graphics2D *graphics*)
   10.39 -
   10.40 -(def ^:dynamic ^FontRenderContext *font-context*
   10.41 -  "FontRenderContext to use when Graphics2D is not available."
   10.42 -  (FontRenderContext.
   10.43 -   nil
   10.44 -   RenderingHints/VALUE_TEXT_ANTIALIAS_DEFAULT
   10.45 -   RenderingHints/VALUE_FRACTIONALMETRICS_DEFAULT))
   10.46 -
   10.47 -(def ^:dynamic *width*
   10.48 -  "Width of the rendering area.")
   10.49 -
   10.50 -(def ^:dynamic *height*
   10.51 -  "Height of the rendering area.")
   10.52 -
   10.53 -(def ^:dynamic ^Shape *clip*)
   10.54 -
   10.55 -(def ^:dynamic ^Shape *input-clip*
   10.56 -  "Clipping area used for dispatching pointer events (intersected with
   10.57 -  *clip*). If nil, *clip* will be used.")
   10.58 -
   10.59 -(def ^:dynamic *time*
   10.60 -  "Timestamp of the current frame (in nanoseconds).")
   10.61 -
   10.62 -(def ^:dynamic *scene*
   10.63 -  "Encloses state that should be retained between repaints.")
   10.64 -
   10.65 -(def ^:dynamic *states*
   10.66 -  "Transient scene states, a map.")
   10.67 -
   10.68 -(def ^:dynamic *event-dispatcher*)
   10.69 -
   10.70 -(def ^:dynamic ^AffineTransform *initial-transform*
   10.71 -  "Initial transform associated with the graphics context.")
   10.72 -
   10.73 -(def ^:dynamic ^AffineTransform *inverse-initial-transform*
   10.74 -  "Inversion of the initial transform associated with the graphics
   10.75 -  context.")
   10.76 -
   10.77 -(defrecord Theme [fore-color back-color alt-back-color border-color
   10.78 -                  shadow-color font])
   10.79 -
   10.80 -;; REMIND: use system colors, see java.awt.SystemColor.
   10.81 -(defn default-theme []
   10.82 -  (Theme. Color/BLACK
   10.83 -          Color/WHITE
   10.84 -          (Color. 0xDD 0xDD 0xDD)
   10.85 -          (Color. 0 0 0xCC)
   10.86 -          (Color. 0x44 0x44 0x44)
   10.87 -          (Font. "Sans" Font/PLAIN 12)))
   10.88 -
   10.89 -(def ^:dynamic *theme* (default-theme))
   10.90 -
   10.91 -;;
   10.92 -;; Core protocols and types
   10.93 -;;
   10.94 -
   10.95 -(defprotocol View
   10.96 -  "Basic UI element."
   10.97 -  (render! [view]
   10.98 -    "Draws the view in the current *graphics* context.")
   10.99 -  (geometry [view]
  10.100 -    "Returns the preferred Geometry for the view."))
  10.101 -
  10.102 -(defprotocol Geometry
  10.103 -  "Describes geometry of a View.  Prefer using the available
  10.104 -  implementations (Size, FixedGeometry and NestedGeometry) over
  10.105 -  extending this protocol directly as it is likely to be changed in
  10.106 -  the future versions."
  10.107 -  (width [geom] [geom height])
  10.108 -  (height [geom] [geom width])
  10.109 -  (anchor-x [geom h-align width]
  10.110 -    "Returns the x coordinate of the anchor point for the specified
  10.111 -     horizontal alignment and width, h-align could be :left, :center
  10.112 -     or :right.")
  10.113 -  (anchor-y [geom v-align height]
  10.114 -    "Returns the y coordinate of the anchor point for the specified
  10.115 -    vertical alignment and height, v-align could be :top, :center
  10.116 -    or :bottom."))
  10.117 -
  10.118 -(defn- emit-align-xy [align size first center last]
  10.119 -  `(case ~align
  10.120 -         ~first 0
  10.121 -         ~center (/ ~size 2)
  10.122 -         ~last ~size))
  10.123 -
  10.124 -;; Define as macro to avoid unnecessary calculation of width or height.
  10.125 -(defmacro align-x
  10.126 -  ([align inner outer]
  10.127 -     `(align-x ~align (- ~outer ~inner)))
  10.128 -  ([align width]
  10.129 -     (emit-align-xy align width :left :center :right)))
  10.130 -
  10.131 -(defmacro align-y
  10.132 -  ([align inner outer]
  10.133 -     `(align-y ~align (- ~outer ~inner)))
  10.134 -  ([align height]
  10.135 -     (emit-align-xy align height :top :center :bottom)))
  10.136 -
  10.137 -(defrecord Size [width height]
  10.138 -  Geometry
  10.139 -  (width  [_] width)
  10.140 -  (width [_ _] width)
  10.141 -  (height [_] height)
  10.142 -  (height [_ _] height)
  10.143 -  (anchor-x [_ h-align width]
  10.144 -    (align-x h-align width))
  10.145 -  (anchor-y [_ v-align height]
  10.146 -    (align-y v-align height)))
  10.147 -
  10.148 -(defrecord FixedGeometry [ax ay width height]
  10.149 -  Geometry
  10.150 -  (width  [_] width)
  10.151 -  (width [_ _] width)
  10.152 -  (height [_] height)
  10.153 -  (height [_ _] height)
  10.154 -  (anchor-x [_ _ _] ax)
  10.155 -  (anchor-y [_ _ _] ay))
  10.156 -
  10.157 -(defrecord NestedGeometry [geometry top left bottom right]
  10.158 -  Geometry
  10.159 -  (width  [_]
  10.160 -    (+ left right (width geometry)))
  10.161 -  (width [_ h]
  10.162 -    (+ left right (width geometry (- h top bottom))))
  10.163 -  (height [_]
  10.164 -    (+ top bottom (height geometry)))
  10.165 -  (height [_ w]
  10.166 -    (+ top bottom (height geometry (- w left right))))
  10.167 -  (anchor-x [_ h-align w]
  10.168 -    (+ left (anchor-x geometry h-align (- w left right))))
  10.169 -  (anchor-y [_ v-align h]
  10.170 -    (+ top (anchor-y geometry v-align (- h top bottom)))))
  10.171 -
  10.172 -(defrecord ScaledGeometry [geometry sx sy]
  10.173 -  Geometry
  10.174 -  (width  [_]
  10.175 -    (* sx (width geometry)))
  10.176 -  (width [_ h]
  10.177 -    (* sx (width geometry (/ h sy))))
  10.178 -  (height [_]
  10.179 -    (* sy (height geometry)))
  10.180 -  (height [_ w]
  10.181 -    (* sy (height geometry (/ w sx))))
  10.182 -  (anchor-x [_ h-align w]
  10.183 -    (* sx (anchor-x geometry h-align (/ w sx))))
  10.184 -  (anchor-y [_ v-align h]
  10.185 -    (* sy (anchor-y geometry v-align (/ h sy)))))
  10.186 -
  10.187 -;; (defn ^:private to-integer
  10.188 -;;   ^long [align x]
  10.189 -;;   (if (integer? x)
  10.190 -;;     x
  10.191 -;;     (let [x (double x)]
  10.192 -;;       (Math/round
  10.193 -;;        (case align
  10.194 -;;          (:top :left) (Math/floor x)
  10.195 -;;          :center x
  10.196 -;;          (:bottom :right) (Math/ceil x))))))
  10.197 -
  10.198 -;; (defrecord IntegerGeometry [geometry]
  10.199 -;;   Geometry
  10.200 -;;   (width [_]
  10.201 -;;     (to-integer :right (width geometry)))
  10.202 -;;   (width [_ h]
  10.203 -;;     (to-integer :right (width geometry h)))
  10.204 -;;   (height [_]
  10.205 -;;     (to-integer :bottom (height geometry)))
  10.206 -;;   (height [_ w]
  10.207 -;;     (to-integer :bottom (height geometry w)))
  10.208 -;;   (anchor-x [_ h-align w]
  10.209 -;;     (to-integer h-align (anchor-x geometry h-align w)))
  10.210 -;;   (anchor-y [_ v-align h]
  10.211 -;;     (to-integer v-align (anchor-y geometry v-align h))))
  10.212 -
  10.213 -;; TODO: modifiers
  10.214 -(defrecord MouseEvent [id when x y x-on-screen y-on-screen button
  10.215 -                       wheel-rotation transform component])
  10.216 -
  10.217 -;; TODO: KeyEvent
  10.218 -
  10.219 -(defprotocol EventDispatcher
  10.220 -  (listen! [this component]
  10.221 -     "Listen for events on the specified AWT Component.")
  10.222 -  (create-dispatcher [this handle handlers]
  10.223 -     "Returns new event dispatcher associated with the specified event
  10.224 -      handlers (an event-id -> handler-fn map). Handle is used to
  10.225 -      match the contexts between commits.")
  10.226 -  (commit [this]
  10.227 -     "Apply the registered handlers for event processing.")
  10.228 -  (handle-picked? [this handle]
  10.229 -     "Returns true if the specified handle received the :mouse-pressed
  10.230 -      event and have not yet received :moused-released.")
  10.231 -  (handle-hovered? [this handle]
  10.232 -     "Returns true if the specified handle received the :mouse-entered
  10.233 -      event and have not yet received :mouse-exited."))
  10.234 -
  10.235 -(defn- assoc-cons [m key val]
  10.236 -  (->> (get m key) (cons val) (assoc m key)))
  10.237 -
  10.238 -;;
  10.239 -;; Observers
  10.240 -;; The mechanism used by views to request repaints
  10.241 -;;
  10.242 -
  10.243 -(def ^ConcurrentMap observers
  10.244 -     (-> (MapMaker.) (.weakKeys) (.makeMap)))
  10.245 -
  10.246 -(defn- cm-replace!
  10.247 -  "Wrap ConcurrentMap replace method to treat nil value as absent
  10.248 -   mapping. Use with maps that does not support nil values."
  10.249 -  [^ConcurrentMap cmap key old new]
  10.250 -  (if (nil? old)
  10.251 -    (nil? (.putIfAbsent cmap key new))
  10.252 -    (.replace cmap key old new)))
  10.253 -
  10.254 -(defn- cm-swap!
  10.255 -  "Atomically swaps the value associated with key in ConcurrentMap
  10.256 -   to be (apply f current-value args). Returns the new value."
  10.257 -  [^ConcurrentMap cmap key f & args]
  10.258 -  (loop []
  10.259 -    (let [old (.get cmap key)
  10.260 -          new (apply f old args)]
  10.261 -      (if (cm-replace! cmap key old new)
  10.262 -        new
  10.263 -        (recur)))))
  10.264 -
  10.265 -(defn add-observer
  10.266 -  "Add observer fn for the target. Watcher identifies the group of
  10.267 -  observers and could be used to remove the group. Watcher is weakly
  10.268 -  referenced, all associated observers will be removed when the
  10.269 -  wathcer is removed by gc. The observer fn will be called with
  10.270 -  watcher and target arguments and any additional arguments specified
  10.271 -  in update call."
  10.272 -  [watcher target f]
  10.273 -  (cm-swap! observers watcher assoc-cons target f)
  10.274 -  nil)
  10.275 -
  10.276 -(defn remove-observers
  10.277 -  "Remove group of observers associated with the specified watcher."
  10.278 -  [watcher]
  10.279 -  (.remove observers watcher)
  10.280 -  nil)
  10.281 -
  10.282 -(defn- replace-observers-watcher
  10.283 -  [old-watcher new-watcher]
  10.284 -  (if-let [old (.remove observers old-watcher)]
  10.285 -    (.put observers new-watcher old))
  10.286 -  nil)
  10.287 -
  10.288 -(defn update
  10.289 -  "Notify observers."
  10.290 -  [target & args]
  10.291 -  (doseq [entry observers
  10.292 -          f (get (val entry) target)]
  10.293 -    (apply f (key entry) target args)))
  10.294 -
  10.295 -(defn add-context-observer
  10.296 -  "Observer registered with this function will be automatically
  10.297 -  removed after the next repaint is complete."
  10.298 -  [target f]
  10.299 -  (add-observer *scene* target f))
  10.300 -
  10.301 -(defn repaint-on-update
  10.302 -  "Trigger repaint of the current scene when the target updates."
  10.303 -  [target]
  10.304 -  (let [scene *scene*]
  10.305 -    (if-not (identical? scene target)
  10.306 -      (add-observer scene target (fn [w _] (update w))))))
  10.307 -
  10.308 -(defn repaint
  10.309 -  "Requests repaint of the current scene. If handle and state are
  10.310 -  specified, the handle will be associated with the state in the
  10.311 -  *states* map for the next paint iteration."
  10.312 -  ([]
  10.313 -     (update *scene*))
  10.314 -  ([handle state]
  10.315 -     (let [scene *scene*]
  10.316 -       (swap! (:next-state scene) assoc handle state)
  10.317 -       (update scene))))
  10.318 -
  10.319 -;;
  10.320 -;; Rendering
  10.321 -;;
  10.322 -
  10.323 -(defn ^FontRenderContext font-context
  10.324 -  "Returns FontRenderContext for the current view context."
  10.325 -  []
  10.326 -  (if (bound? (var *graphics*))
  10.327 -    (.getFontRenderContext *graphics*)
  10.328 -    *font-context*))
  10.329 -
  10.330 -(defn ^AffineTransform relative-transform
  10.331 -  "Returns AffineTransform: view context -> AWT component."
  10.332 -  []
  10.333 -  (let [tr (.getTransform *graphics*)]
  10.334 -    (.preConcatenate tr *inverse-initial-transform*)
  10.335 -    tr))
  10.336 -
  10.337 -(defn ^AffineTransform inverse-relative-transform
  10.338 -  "Returns AffineTransform: AWT component -> view context."
  10.339 -  []
  10.340 -  (let [tr (.getTransform *graphics*)]
  10.341 -    (.invert tr)                          ; absolute -> view
  10.342 -    (.concatenate tr *initial-transform*) ; component -> absolute
  10.343 -    tr))
  10.344 -
  10.345 -(defn transform-point [^AffineTransform tr ^double x ^double y]
  10.346 -  (let [p (Point2D$Double. x y)]
  10.347 -    (.transform tr p p)
  10.348 -    [(.x p) (.y p)]))
  10.349 -
  10.350 -(defn inverse-transform-point [^AffineTransform tr ^double x ^double y]
  10.351 -  (let [p (Point2D$Double. x y)]
  10.352 -    (.inverseTransform tr p p)
  10.353 -    [(.x p) (.y p)]))
  10.354 -
  10.355 -;; (defn- clip
  10.356 -;;   "Intersect clipping area with the specified shape or bounds.
  10.357 -;;    Returns new clip (Shape or nil if empty)."
  10.358 -;;   ([x y w h]
  10.359 -;;      (clip (Rectangle2D$Double. x y w h)))
  10.360 -;;   ([shape]
  10.361 -;;      (let [a1 (Area. shape)
  10.362 -;;            a2 (if (instance? Area *clip*) *clip* (Area. *clip*))]
  10.363 -;;        (.transform a1 (relative-transform))
  10.364 -;;        (.intersect a1 a2)
  10.365 -;;        (if (.isEmpty a1)
  10.366 -;;          nil
  10.367 -;;          a1))))
  10.368 -
  10.369 -;; Use faster clipping calculation provided by Graphics2D.
  10.370 -(defn- clip
  10.371 -  "Intersect clipping area with the specified Shape in current
  10.372 -   transform coordinates. Returns new clip in the AWT component
  10.373 -   coordinates (Shape or nil if empty)."
  10.374 -  [^Shape shape]
  10.375 -  (let [^Graphics2D clip-g (.create *graphics*)]
  10.376 -    (try
  10.377 -      (doto clip-g
  10.378 -        (.setClip shape)
  10.379 -        (.setTransform *initial-transform*)
  10.380 -        (.clip *clip*))
  10.381 -      (if (.isEmpty (.getClipBounds clip-g))
  10.382 -        nil
  10.383 -        (.getClip clip-g))
  10.384 -      (finally
  10.385 -       (.dispose clip-g)))))
  10.386 -
  10.387 -(defn- ^Graphics2D apply-theme
  10.388 -  "Set graphics' color and font to match theme.
  10.389 -   Modifies and returns the first argument."
  10.390 -  ([]
  10.391 -     (apply-theme *graphics* *theme*))
  10.392 -  ([^Graphics2D graphics theme]
  10.393 -     (doto graphics
  10.394 -       (.setColor (:fore-color theme))
  10.395 -       (.setFont (:font theme)))))
  10.396 -
  10.397 -(defn- ^Graphics2D create-graphics
  10.398 -  ([]
  10.399 -     (apply-theme (.create *graphics*) *theme*))
  10.400 -  ([^long x ^long y ^long w ^long h]
  10.401 -     (apply-theme (.create *graphics* x y w h) *theme*)))
  10.402 -
  10.403 -(defn- with-bounds-noclip*
  10.404 -  [x y w h f & args]
  10.405 -  (let [graphics (create-graphics)]
  10.406 -    (try
  10.407 -      (.translate graphics (double x) (double y))
  10.408 -      (binding [*width* w
  10.409 -                *height* h
  10.410 -                *input-clip* (Rectangle2D$Double. 0.0 0.0 w h)
  10.411 -                *graphics* graphics]
  10.412 -        (apply f args))
  10.413 -      (finally
  10.414 -       (.dispose graphics)))))
  10.415 -
  10.416 -(defn with-bounds*
  10.417 -  [x y w h f & args]
  10.418 -  (let [x (double x)
  10.419 -        y (double y)
  10.420 -        bounds (Rectangle2D$Double. x y w h)]
  10.421 -    (when-let [clip (clip bounds)]
  10.422 -      (let [^Graphics2D graphics (create-graphics)]
  10.423 -        (try
  10.424 -          (.clip graphics bounds)
  10.425 -          (.translate graphics x y)
  10.426 -          (binding [*width* w
  10.427 -                    *height* h
  10.428 -                    *clip* clip
  10.429 -                    *input-clip* nil
  10.430 -                    *graphics* graphics]
  10.431 -            (apply f args))
  10.432 -          (finally
  10.433 -           (.dispose graphics)))))))
  10.434 -
  10.435 -(defmacro with-bounds
  10.436 -  [x y w h & body]
  10.437 -  `(with-bounds* ~x ~y ~w ~h (fn [] ~@body)))
  10.438 -
  10.439 -(defmacro with-theme
  10.440 -  [theme & body]
  10.441 -  `(binding [*theme* (merge *theme* ~theme)]
  10.442 -     ~@body))
  10.443 -
  10.444 -(defmacro with-color [color-or-key & body]
  10.445 -  `(let [color# ~color-or-key
  10.446 -         color# (get *theme* color# color#)
  10.447 -         g# *graphics*
  10.448 -         old-color# (.getColor g#)]
  10.449 -     (try
  10.450 -       (.setColor g# color#)
  10.451 -       ~@body
  10.452 -       (finally
  10.453 -         (.setColor g# old-color#)))))
  10.454 -
  10.455 -(defmacro with-stroke [stroke & body]
  10.456 -  `(let [g# *graphics*
  10.457 -         old-stroke# (.getStroke g#)]
  10.458 -     (try
  10.459 -       (.setStroke g# ~stroke)
  10.460 -       ~@body
  10.461 -       (finally
  10.462 -        (.setStroke g# old-stroke#)))))
  10.463 -
  10.464 -(defmacro with-hints
  10.465 -  [hints & body]
  10.466 -  `(let [h# ~hints
  10.467 -         g# *graphics*
  10.468 -         old# (.getRenderingHints g#)]
  10.469 -     (try
  10.470 -       (.addRenderingHints g# h#)
  10.471 -       ~@body
  10.472 -       (finally
  10.473 -        (.setRenderingHints g# old#)))))
  10.474 -
  10.475 -(defn with-hints* [hints f & args]
  10.476 -  (with-hints hints
  10.477 -    (apply f args)))
  10.478 -
  10.479 -;; TODO: constructor for AffineTransform.
  10.480 -;; (transform :scale 0.3 0.5
  10.481 -;;            :translate 5 10
  10.482 -;;            :rotate (/ Math/PI 2))
  10.483 -
  10.484 -(defmacro with-transform [transform & body]
  10.485 -  `(let [g# *graphics*
  10.486 -         old-t# (.getTransform g#)]
  10.487 -     (try
  10.488 -       (.transform g# ~transform)
  10.489 -       ~@body
  10.490 -       (finally
  10.491 -        (.setTransform g# old-t#)))))
  10.492 -
  10.493 -(defmacro with-rotate [theta ax ay & body]
  10.494 -  `(let [transform# (AffineTransform/getRotateInstance ~theta ~ax ~ay)]
  10.495 -     (with-transform transform# ~@body)))
  10.496 -
  10.497 -(defmacro with-translate [x y & body]
  10.498 -  `(let [x# ~x
  10.499 -         y# ~y
  10.500 -         g# *graphics*]
  10.501 -     (try
  10.502 -       (.translate g# x# y#)
  10.503 -       ~@body
  10.504 -       (finally
  10.505 -        (.translate g# (- x#) (- y#))))))
  10.506 -
  10.507 -(defn draw!
  10.508 -  "Draws the View."
  10.509 -  ([view]
  10.510 -     (let [graphics (create-graphics)]
  10.511 -       (try
  10.512 -         (binding [*graphics* graphics]
  10.513 -           (render! view))
  10.514 -         (finally
  10.515 -          (.dispose graphics)))))
  10.516 -  ([x y view]
  10.517 -     (draw! x y true view))
  10.518 -  ([x y clip? view]
  10.519 -     (let [geom (geometry view)]
  10.520 -       (draw! x y (width geom) (height geom) clip? view)))
  10.521 -  ([x y width height view]
  10.522 -     (draw! x y width height true view))
  10.523 -  ([x y width height clip? view]
  10.524 -     (if clip?
  10.525 -       (with-bounds* x y width height render! view)
  10.526 -       (with-bounds-noclip* x y width height render! view))))
  10.527 -
  10.528 -(defn draw-aligned!
  10.529 -  "Draws the View.  Location is relative to the view's anchor point
  10.530 -   for the specified alignment."
  10.531 -  ([h-align v-align x y view]
  10.532 -     (let [geom (geometry view)
  10.533 -           w (width geom)
  10.534 -           h (height geom)]
  10.535 -       (draw! (- x (anchor-x geom h-align w))
  10.536 -              (- y (anchor-y geom v-align h))
  10.537 -              w h
  10.538 -              view)))
  10.539 -  ([h-align v-align x y w h view]
  10.540 -     (let [geom (geometry view)]
  10.541 -       (draw! (- x (anchor-x geom h-align w))
  10.542 -              (- y (anchor-y geom v-align h))
  10.543 -              w h
  10.544 -              view))))
  10.545 -
  10.546 -;;
  10.547 -;; Event handling.
  10.548 -;;
  10.549 -
  10.550 -(defn with-handlers*
  10.551 -  [handle handlers f & args]
  10.552 -  (binding [*event-dispatcher* (create-dispatcher
  10.553 -                                *event-dispatcher* handle handlers)]
  10.554 -    (apply f args)))
  10.555 -
  10.556 -(defmacro with-handlers
  10.557 -  "specs => (:event-id name & handler-body)*
  10.558 -
  10.559 -  Execute form with the specified event handlers."
  10.560 -  [handle form & specs]
  10.561 -  `(with-handlers* ~handle
  10.562 -     ~(reduce (fn [m spec]
  10.563 -                (assoc m (first spec)
  10.564 -                       `(fn [~(second spec)]
  10.565 -                          ~@(nnext spec)))) {}
  10.566 -                          specs)
  10.567 -     (fn [] ~form)))
  10.568 -
  10.569 -(defn picked? [handle]
  10.570 -  (handle-picked? *event-dispatcher* handle))
  10.571 -
  10.572 -(defn hovered? [handle]
  10.573 -  (handle-hovered? *event-dispatcher* handle))
  10.574 -
  10.575 -;;
  10.576 -;; EventDispatcher implementation
  10.577 -;;
  10.578 -
  10.579 -(def awt-events
  10.580 -     {java.awt.event.MouseEvent/MOUSE_CLICKED  :mouse-clicked
  10.581 -      java.awt.event.MouseEvent/MOUSE_DRAGGED  :mouse-dragged
  10.582 -      java.awt.event.MouseEvent/MOUSE_ENTERED  :mouse-entered
  10.583 -      java.awt.event.MouseEvent/MOUSE_EXITED   :mouse-exited
  10.584 -      java.awt.event.MouseEvent/MOUSE_MOVED    :mouse-moved
  10.585 -      java.awt.event.MouseEvent/MOUSE_PRESSED  :mouse-pressed
  10.586 -      java.awt.event.MouseEvent/MOUSE_RELEASED :mouse-released
  10.587 -      java.awt.event.MouseEvent/MOUSE_WHEEL    :mouse-wheel})
  10.588 -
  10.589 -(def dummy-event-dispatcher
  10.590 -  (reify EventDispatcher
  10.591 -    (listen! [_ _])
  10.592 -    (create-dispatcher [this _ _] this)
  10.593 -    (commit [_])
  10.594 -    (handle-picked? [_ _])
  10.595 -    (handle-hovered? [_ _])))
  10.596 -
  10.597 -;; Not using defrecord to avoid unacceptable overhead of recursive
  10.598 -;; hash code calculation.
  10.599 -(deftype DispatcherNode [handle handlers parent
  10.600 -                         ^Shape clip ^AffineTransform transform
  10.601 -                         bindings]
  10.602 -  EventDispatcher
  10.603 -  (listen! [this component]
  10.604 -    (listen! parent component))
  10.605 -  (create-dispatcher [this handle handlers]
  10.606 -    (create-dispatcher parent handle handlers))
  10.607 -  (commit [this]
  10.608 -    (commit parent))
  10.609 -  (handle-picked? [this handle]
  10.610 -    (handle-picked? parent handle))
  10.611 -  (handle-hovered? [this handle]
  10.612 -    (handle-hovered? parent handle)))
  10.613 -
  10.614 -(defn- make-node [handle handlers]
  10.615 -  (let [clip (if *input-clip*
  10.616 -               (clip *input-clip*)
  10.617 -               *clip*)
  10.618 -        bindings (-> (get-thread-bindings)
  10.619 -                     (dissoc (var *graphics*))
  10.620 -                     (assoc (var *font-context*) (font-context)))]
  10.621 -    (DispatcherNode. handle handlers *event-dispatcher* clip
  10.622 -                     (relative-transform)
  10.623 -                     bindings)))
  10.624 -
  10.625 -(defn- add-node [tree ^DispatcherNode node]
  10.626 -  (assoc-cons tree (.parent node) node))
  10.627 -
  10.628 -(defn- nodes [tree]
  10.629 -  (apply concat (vals tree)))
  10.630 -
  10.631 -(defn- under-cursor
  10.632 -  "Returns a vector of child nodes under cursor."
  10.633 -  [node tree ^long x ^long y]
  10.634 -  (some (fn [^DispatcherNode n]
  10.635 -          (if (and (.clip n) (.contains ^Shape (.clip n) x y))
  10.636 -            (conj (vec (under-cursor n tree x y)) n)))
  10.637 -        (get tree node)))
  10.638 -
  10.639 -(defn- translate-mouse-event [^java.awt.event.MouseEvent event
  10.640 -                              ^AffineTransform tr id]
  10.641 -  (let [[x y] (inverse-transform-point tr (.getX event) (.getY event))
  10.642 -        rotation (if (instance? MouseWheelEvent event)
  10.643 -                   (.getWheelRotation ^MouseWheelEvent event)
  10.644 -                   nil)]
  10.645 -    (->MouseEvent id (.getWhen event) x y
  10.646 -                  (.getXOnScreen event) (.getYOnScreen event)
  10.647 -                  (.getButton event)
  10.648 -                  rotation
  10.649 -                  tr
  10.650 -                  (.getComponent event))))
  10.651 -
  10.652 -(defn- translate-and-dispatch
  10.653 -  ([nodes first-only ^java.awt.event.MouseEvent event]
  10.654 -     (translate-and-dispatch nodes first-only
  10.655 -                             event (awt-events (.getID event))))
  10.656 -  ([nodes first-only event id]
  10.657 -     (if-let [^DispatcherNode node (first nodes)]
  10.658 -       (let [handlers (.handlers node)
  10.659 -             handler (get handlers id)]
  10.660 -         (if handler
  10.661 -           (do
  10.662 -             (with-bindings* (.bindings node)
  10.663 -               handler
  10.664 -               (translate-mouse-event event (.transform node) id))
  10.665 -             (when-not first-only
  10.666 -               (recur (rest nodes) false event id)))
  10.667 -           (when-not (and (= id :mouse-dragged)
  10.668 -                          (or (contains? handlers :mouse-pressed)
  10.669 -                              (contains? handlers :mouse-released)))
  10.670 -             (recur (rest nodes) first-only event id)))))))
  10.671 -
  10.672 -(defn- process-mouse-event
  10.673 -  [dispatcher ^java.awt.event.MouseEvent source-event]
  10.674 -  (let [{active-ref :active
  10.675 -         hovered-ref :hovered
  10.676 -         picked-ref :picked
  10.677 -         last-ref :last-motion
  10.678 -         tree-ref :tree} dispatcher
  10.679 -         pressed (and source-event
  10.680 -                      (== (.getID source-event)
  10.681 -                          java.awt.event.MouseEvent/MOUSE_PRESSED))
  10.682 -         released (and source-event
  10.683 -                       (== (.getID source-event)
  10.684 -                           java.awt.event.MouseEvent/MOUSE_RELEASED))
  10.685 -         ^java.awt.event.MouseEvent last-event @last-ref
  10.686 -         ^java.awt.event.MouseEvent event (or source-event last-event)]
  10.687 -    (when event
  10.688 -      (let [x (.getX event)
  10.689 -            y (.getY event)
  10.690 -            active @active-ref
  10.691 -            active (if (and active
  10.692 -                            source-event
  10.693 -                            (== (.getX last-event) x)
  10.694 -                            (== (.getY last-event) y))
  10.695 -                     active
  10.696 -                     (ref-set active-ref
  10.697 -                              (under-cursor dispatcher @tree-ref x y)))
  10.698 -            acted (cond
  10.699 -                   pressed (ref-set picked-ref active)
  10.700 -                   released (let [picked @picked-ref]
  10.701 -                              (ref-set picked-ref nil)
  10.702 -                              picked)
  10.703 -                   :else active)
  10.704 -            picked (seq @picked-ref)
  10.705 -            pred #(= (.handle ^DispatcherNode %1) (.handle ^DispatcherNode %2))
  10.706 -            hovered (if picked
  10.707 -                      (filter #(some (partial pred %) picked) active)
  10.708 -                      active)
  10.709 -            remove-all (fn [c1 c2]
  10.710 -                         (filter #(not (some (partial pred %) c2)) c1))
  10.711 -            old-hovered @hovered-ref
  10.712 -            exited (remove-all old-hovered hovered)
  10.713 -            entered (remove-all hovered old-hovered)
  10.714 -            moved (or picked (remove-all hovered entered))]
  10.715 -        (ref-set hovered-ref hovered)
  10.716 -        (ref-set last-ref event)
  10.717 -        [exited entered moved acted event]))))
  10.718 -
  10.719 -(defn- dispatch-mouse-event
  10.720 -  [dispatcher source-event button?]
  10.721 -  (when-let [[exited
  10.722 -              entered
  10.723 -              moved
  10.724 -              acted
  10.725 -              event] (dosync (process-mouse-event dispatcher source-event))]
  10.726 -    (when button?
  10.727 -      (translate-and-dispatch acted true event))
  10.728 -    (translate-and-dispatch exited false event :mouse-exited)
  10.729 -    (translate-and-dispatch entered false event :mouse-entered)
  10.730 -    (when-not button?
  10.731 -      (translate-and-dispatch moved true source-event))))
  10.732 -
  10.733 -(defrecord RootEventDispatcher [tree-r  ;; register
  10.734 -                                tree    ;; dispatch
  10.735 -                                active  ;; nodes under cursor
  10.736 -                                hovered ;; mouse entered
  10.737 -                                picked  ;; mouse pressed
  10.738 -                                last-motion]
  10.739 -  EventDispatcher
  10.740 -  (listen! [dispatcher component]
  10.741 -    (doto ^Component component
  10.742 -          (.addMouseListener dispatcher)
  10.743 -          (.addMouseWheelListener dispatcher)
  10.744 -          (.addMouseMotionListener dispatcher)))
  10.745 -  (create-dispatcher [dispatcher handle handlers]
  10.746 -    (let [node (make-node handle handlers)]
  10.747 -      (dosync (alter tree-r add-node node))
  10.748 -      node))
  10.749 -  (commit [dispatcher]
  10.750 -    (let [[exited
  10.751 -           entered
  10.752 -           _ _
  10.753 -           event] (dosync
  10.754 -                   ;; TODO: retain contexts that do
  10.755 -                   ;; not intersect graphics
  10.756 -                   ;; clipping area in tree.
  10.757 -                   (ref-set tree @tree-r)
  10.758 -                   (ref-set tree-r {})
  10.759 -                   (process-mouse-event dispatcher nil))]
  10.760 -      ;; Send mouse entered and exited events if necessary due to
  10.761 -      ;; updated layout.
  10.762 -      (translate-and-dispatch exited false event :mouse-exited)
  10.763 -      (translate-and-dispatch entered false event :mouse-entered)))
  10.764 -  (handle-picked? [dispatcher handle]
  10.765 -    (some #(= handle (.handle ^DispatcherNode %)) @picked))
  10.766 -  (handle-hovered? [dispatcher handle]
  10.767 -    (some #(= handle (.handle ^DispatcherNode %)) @hovered))
  10.768 -  MouseListener
  10.769 -  (mouseEntered [dispatcher event]
  10.770 -    (dispatch-mouse-event dispatcher event false))
  10.771 -  (mouseExited [dispatcher event]
  10.772 -    (dispatch-mouse-event dispatcher event false))
  10.773 -  (mouseClicked [dispatcher event]
  10.774 -    (dispatch-mouse-event dispatcher event true))
  10.775 -  (mousePressed [dispatcher event]
  10.776 -    (dispatch-mouse-event dispatcher event true))
  10.777 -  (mouseReleased [dispatcher event]
  10.778 -    (dispatch-mouse-event dispatcher event true))
  10.779 -  MouseWheelListener
  10.780 -  (mouseWheelMoved [dispatcher event]
  10.781 -    (dispatch-mouse-event dispatcher event true))
  10.782 -  MouseMotionListener
  10.783 -  (mouseDragged [dispatcher event]
  10.784 -    (dispatch-mouse-event dispatcher event false))
  10.785 -  (mouseMoved [dispatcher event]
  10.786 -    (dispatch-mouse-event dispatcher event false)))
  10.787 -
  10.788 -(defn root-event-dispatcher []
  10.789 -  (->RootEventDispatcher
  10.790 -   (ref {}) (ref {})             ;; trees
  10.791 -   (ref nil) (ref nil) (ref nil) ;; node states
  10.792 -   (ref nil)))                   ;; last event
  10.793 -
  10.794 -;;
  10.795 -;; Scene
  10.796 -;;
  10.797 -
  10.798 -(defrecord Scene [view
  10.799 -                  event-dispatcher
  10.800 -                  component
  10.801 -                  rendering-hints
  10.802 -                  next-state])
  10.803 -
  10.804 -;; Define rendering hints that affect font metrics to make sure that
  10.805 -;; Graphics and Scene FontRenderContexts are consistent.
  10.806 -(def ^:private default-rendering-hints
  10.807 -  {RenderingHints/KEY_TEXT_ANTIALIASING
  10.808 -   RenderingHints/VALUE_TEXT_ANTIALIAS_DEFAULT,
  10.809 -   RenderingHints/KEY_FRACTIONALMETRICS
  10.810 -   RenderingHints/VALUE_FRACTIONALMETRICS_DEFAULT})
  10.811 -
  10.812 -(defn make-scene
  10.813 -  ([view]
  10.814 -     (make-scene view dummy-event-dispatcher nil))
  10.815 -  ([view event-dispatcher]
  10.816 -     (make-scene view event-dispatcher nil))
  10.817 -  ([view event-dispatcher ^Component component]
  10.818 -     (make-scene view event-dispatcher component nil))
  10.819 -  ([view event-dispatcher ^Component component hints]
  10.820 -     (let [hints (merge default-rendering-hints hints)]
  10.821 -       (->Scene view
  10.822 -                event-dispatcher
  10.823 -                component
  10.824 -                hints
  10.825 -                (atom nil)))))
  10.826 -
  10.827 -(defn- get-and-set!
  10.828 -  "Atomically sets the value of atom to newval and returns the old
  10.829 -  value."
  10.830 -  [atom newval]
  10.831 -  (loop [v @atom]
  10.832 -    (if (compare-and-set! atom v newval)
  10.833 -      v
  10.834 -      (recur @atom))))
  10.835 -
  10.836 -(defn draw-scene!
  10.837 -  [scene ^Graphics2D graphics width height]
  10.838 -  (.addRenderingHints graphics (:rendering-hints scene))
  10.839 -  (binding [*states* (get-and-set! (:next-state scene) nil)
  10.840 -            *scene* scene
  10.841 -            *graphics* graphics
  10.842 -            *initial-transform* (.getTransform graphics)
  10.843 -            *inverse-initial-transform* (-> graphics
  10.844 -                                            .getTransform
  10.845 -                                            .createInverse)
  10.846 -            *event-dispatcher* (:event-dispatcher scene)
  10.847 -            *width* width
  10.848 -            *height* height
  10.849 -            *clip* (Rectangle2D$Double. 0.0 0.0 width height)
  10.850 -            *input-clip* nil
  10.851 -            *time* (System/nanoTime)]
  10.852 -    (apply-theme)
  10.853 -    (let [tmp-watcher (Object.)]
  10.854 -      ;; Keep current context observers until the rendering is
  10.855 -      ;; complete. Some observers may be invoked twice if they
  10.856 -      ;; appear in both groups until tmp-watcher is removed.
  10.857 -      (replace-observers-watcher scene tmp-watcher)
  10.858 -      (try
  10.859 -        (render! (:view scene))
  10.860 -        (finally
  10.861 -         (remove-observers tmp-watcher)
  10.862 -         (commit (:event-dispatcher scene)))))))
  10.863 -
  10.864 -(defn- scene-font-context [scene]
  10.865 -  (let [hints (:rendering-hints scene)
  10.866 -        ^Component c (:component scene)
  10.867 -        t (if c (->> c
  10.868 -                     .getFont
  10.869 -                     (.getFontMetrics c)
  10.870 -                     .getFontRenderContext
  10.871 -                     .getTransform))]
  10.872 -    (FontRenderContext.
  10.873 -     t
  10.874 -     (get hints RenderingHints/KEY_TEXT_ANTIALIASING)
  10.875 -     (get hints RenderingHints/KEY_FRACTIONALMETRICS))))      
  10.876 -
  10.877 -(defn scene-geometry [scene]
  10.878 -  (binding [*scene* scene
  10.879 -            *font-context* (scene-font-context scene)]
  10.880 -    (geometry (:view scene))))
  10.881 -
  10.882 -(defn set-cursor! [^Cursor cursor]
  10.883 -  (when-let [^Component component (:component *scene*)]
  10.884 -    (EventQueue/invokeLater #(.setCursor component cursor))))

    11.1 --- a/src/net/kryshen/indyvon/demo.clj	Mon Apr 14 15:37:28 2014 +0400
    11.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    11.3 @@ -1,223 +0,0 @@
    11.4 -;;
    11.5 -;; Copyright 2010-2014 Mikhail Kryshen <mikhail@kryshen.net>
    11.6 -;;
    11.7 -;; This file is part of Indyvon.
    11.8 -;;
    11.9 -;; Indyvon is free software: you can redistribute it and/or modify it
   11.10 -;; under the terms of the GNU Lesser General Public License version 3
   11.11 -;; only, as published by the Free Software Foundation.
   11.12 -;;
   11.13 -;; Indyvon is distributed in the hope that it will be useful, but
   11.14 -;; WITHOUT ANY WARRANTY; without even the implied warranty of
   11.15 -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
   11.16 -;; Lesser General Public License for more details.
   11.17 -;;
   11.18 -;; You should have received a copy of the GNU Lesser General Public
   11.19 -;; License along with Indyvon.  If not, see
   11.20 -;; <http://www.gnu.org/licenses/>.
   11.21 -;;
   11.22 -
   11.23 -(ns net.kryshen.indyvon.demo
   11.24 -  "Indyvon demo and experiments."
   11.25 -  (:gen-class)
   11.26 -  (:use
   11.27 -   (net.kryshen.indyvon core views viewport component))
   11.28 -  (:import
   11.29 -   (java.awt Color)
   11.30 -   (javax.swing JFrame)))
   11.31 -
   11.32 -(defn draw-button!
   11.33 -  "Draws a button immediately (but uses callback for the action unlike
   11.34 -   IMGUI)."
   11.35 -  [id content callback & args]
   11.36 -  (with-handlers id
   11.37 -    (let [shadow-offset 2
   11.38 -          padding 4
   11.39 -          border-width 1
   11.40 -          offset (if (picked? id) (/ shadow-offset 2) 0)
   11.41 -          ^Color color (:alt-back-color *theme*)
   11.42 -          color (if (hovered? id) (.brighter color) color)
   11.43 -          width (- *width* shadow-offset)
   11.44 -          height (- *height* shadow-offset)]
   11.45 -      (with-color (:shadow-color *theme*)
   11.46 -        (.fillRect *graphics* shadow-offset shadow-offset width height))
   11.47 -      (with-color color
   11.48 -        (.fillRect *graphics* offset offset width height))
   11.49 -      (draw! offset offset width height
   11.50 -             (border border-width padding content)))
   11.51 -    ;; Event handlers
   11.52 -    (:mouse-entered _ (repaint))
   11.53 -    (:mouse-exited _ (repaint))
   11.54 -    (:mouse-pressed _ (repaint))
   11.55 -    (:mouse-released _ (repaint))
   11.56 -    (:mouse-clicked _ (apply callback args))))
   11.57 -
   11.58 -(defn combine-colors
   11.59 -  "Returns color between color1 and color2. When c (0 <= c <= 1.0) is
   11.60 -   closer to 0 the returned сolor is closer to color1."
   11.61 -  [^Color color1 ^Color color2 c]
   11.62 -  (case c
   11.63 -    0.0 color1
   11.64 -    1.0 color2
   11.65 -    (let [rgb1 (.getRGBComponents color1 nil)
   11.66 -          rgb2 (.getRGBComponents color2 nil)
   11.67 -          rgb (float-array (map #(+ (* (- 1 c) %1) (* c %2)) rgb1 rgb2))]
   11.68 -      (Color. (aget rgb 0) (aget rgb 1) (aget rgb 2) (aget rgb 3)))))
   11.69 -
   11.70 -(defn animate
   11.71 -  "Changes the value of atom according to the specified range, speed,
   11.72 -   and current frame interval.  Invokes repaint if change happens."
   11.73 -  [atom from to speed]
   11.74 -  (let [prev @atom
   11.75 -        state (cond
   11.76 -               (zero? speed) :stop
   11.77 -               (= prev from) (if (pos? speed) :start :stop)               
   11.78 -               (= prev to) (if (neg? speed) :start :stop)
   11.79 -               :default :continue)]
   11.80 -    (if (= state :stop)
   11.81 -       prev
   11.82 -       (let [interval (if (= state :start) 1 *interval*)
   11.83 -             step (* speed interval 1E-9)
   11.84 -             val (swap! atom #(-> % (+ step) (max from) (min to)))]
   11.85 -         (repaint)
   11.86 -         val))))
   11.87 -
   11.88 -(defn animated-button
   11.89 -  "Creates an animated button."
   11.90 -  [content callback & args]
   11.91 -  (let [padding 4
   11.92 -        border-width 1
   11.93 -        shadow-offset 2
   11.94 -        face (border padding border-width content)
   11.95 -        highlight (atom 0)
   11.96 -        animation-speed (atom 0)]
   11.97 -    (interval-view
   11.98 -     (reify
   11.99 -      View
  11.100 -      (render! [button]
  11.101 -        (with-handlers button
  11.102 -          (let [hovered (hovered? button)
  11.103 -                offset (if (picked? button) (/ shadow-offset 2) 0)
  11.104 -                color (combine-colors
  11.105 -                       (:alt-back-color *theme*) Color/WHITE
  11.106 -                       (animate highlight 0.0 1.0 @animation-speed))
  11.107 -                width (- *width* shadow-offset)
  11.108 -                height (- *height* shadow-offset)]
  11.109 -            (with-color (:shadow-color *theme*)
  11.110 -              (.fillRect *graphics*
  11.111 -                         shadow-offset shadow-offset
  11.112 -                         width height))
  11.113 -            (with-color color
  11.114 -              (.fillRect *graphics* offset offset width height))
  11.115 -            (draw! offset offset width height
  11.116 -                   (border border-width padding content)))
  11.117 -          ;; Event handlers
  11.118 -          (:mouse-entered _
  11.119 -            (reset! animation-speed 4)
  11.120 -            (repaint))
  11.121 -          (:mouse-exited _
  11.122 -            (reset! animation-speed -2)
  11.123 -            (repaint))
  11.124 -          (:mouse-pressed _ (repaint))
  11.125 -          (:mouse-released _ (repaint))
  11.126 -          (:mouse-clicked _ (apply callback args))))
  11.127 -     (geometry [button]
  11.128 -       (let [face-geom (geometry face)]
  11.129 -         (->Size (+ (width face-geom) shadow-offset)
  11.130 -                 (+ (height face-geom) shadow-offset))))))))
  11.131 -
  11.132 -(def button1 (animated-button (label "Animated button 1")
  11.133 -                              println "Animated button 1 clicked"))
  11.134 -
  11.135 -(def button2 (animated-button (label "Animated button 2")
  11.136 -                              println "Animated button 2 clicked"))
  11.137 -
  11.138 -(def test-view1
  11.139 -  (reify
  11.140 -   View
  11.141 -   (render! [view]
  11.142 -     (with-handlers view
  11.143 -       (with-color (if (hovered? view) Color/ORANGE Color/RED)
  11.144 -         (.fillRect *graphics* 0 0 *width* *height*))
  11.145 -       (:mouse-entered e
  11.146 -        (repaint)
  11.147 -        (println e))
  11.148 -       (:mouse-exited e
  11.149 -        (repaint)
  11.150 -        (println e))
  11.151 -       (:mouse-moved e
  11.152 -        (println e))))
  11.153 -   (geometry [view]
  11.154 -     (->Size 30 20))))
  11.155 -
  11.156 -(def test-view1b (border 2 3 test-view1))
  11.157 -
  11.158 -(def test-view2
  11.159 -  (reify
  11.160 -   View
  11.161 -   (render! [view]
  11.162 -     (doto *graphics*
  11.163 -       (.setColor Color/YELLOW)
  11.164 -       (.fillRect 0 0 *width* *height*))
  11.165 -     (with-rotate 0.5 0 0
  11.166 -       (draw! 30 25 test-view1b))
  11.167 -     (draw! 55 5 test-view1))
  11.168 -   (geometry [view]
  11.169 -     (->Size 70 65))))
  11.170 -
  11.171 -(def test-view2m (miniature 30 30 test-view2))
  11.172 -
  11.173 -(def test-view3 (border (label :right :bottom "Sample\ntext")))
  11.174 -
  11.175 -(def root
  11.176 -  (reify
  11.177 -   View
  11.178 -   (render! [view]
  11.179 -     ;;(repaint)
  11.180 -     (doto *graphics*
  11.181 -       (.drawLine 0 0 *width* *height*)
  11.182 -       (.drawLine *width* 0 0 *height*)
  11.183 -       ;; Random color to see when repaint happens.
  11.184 -       (.setColor (rand-nth [Color/BLACK Color/BLUE Color/RED]))
  11.185 -       (.fillOval 5 5 20 20))
  11.186 -     (draw! 30 20 test-view2)
  11.187 -     (draw! 120 50 test-view2m)
  11.188 -     (draw! 100 100 80 50 test-view3)
  11.189 -     (draw! 50 160 button1)
  11.190 -     (with-rotate (/ Math/PI 6) 250 200
  11.191 -       (draw! 210 140 button1))
  11.192 -     (draw! 100 200 button2)
  11.193 -     (with-bounds 180 240 140 30
  11.194 -       (draw-button! :button
  11.195 -        (label :center :center "Immediate button")
  11.196 -        #(println "Button clicked!"))))
  11.197 -   (geometry [view]
  11.198 -     (->Size 400 300))))
  11.199 -
  11.200 -;; Main viewport
  11.201 -(def vp (viewport root))
  11.202 -
  11.203 -;; Miniature (rendered asynchronously)
  11.204 -(def vp-miniature (->> vp (viewport-miniature 100 75) border shadow))
  11.205 -
  11.206 -;; Main scene
  11.207 -(def scene
  11.208 -  (fps-view
  11.209 -   (decorate-view vp [_]
  11.210 -     (draw! vp)
  11.211 -     (draw-aligned!
  11.212 -      :left :bottom 5 (- *height* 5)
  11.213 -      (label (str "Drag mouse to pan," \newline
  11.214 -                  "use mouse wheel to zoom.")))
  11.215 -     (draw! (- *width* 105) 5 vp-miniature))))
  11.216 -
  11.217 -(defn show-frame [view]
  11.218 -  (doto (make-jframe "Test" view)
  11.219 -    (.setDefaultCloseOperation JFrame/DISPOSE_ON_CLOSE)
  11.220 -    (.setVisible true)))
  11.221 -
  11.222 -(defn -main []
  11.223 -  (show-frame scene))
  11.224 -
  11.225 -(comment
  11.226 -  (show-frame (viewport-miniature 200 150 vp)))

    12.1 --- a/src/net/kryshen/indyvon/viewport.clj	Mon Apr 14 15:37:28 2014 +0400
    12.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    12.3 @@ -1,238 +0,0 @@
    12.4 -;;
    12.5 -;; Copyright 2010-2014 Mikhail Kryshen <mikhail@kryshen.net>
    12.6 -;;
    12.7 -;; This file is part of Indyvon.
    12.8 -;;
    12.9 -;; Indyvon is free software: you can redistribute it and/or modify it
   12.10 -;; under the terms of the GNU Lesser General Public License version 3
   12.11 -;; only, as published by the Free Software Foundation.
   12.12 -;;
   12.13 -;; Indyvon is distributed in the hope that it will be useful, but
   12.14 -;; WITHOUT ANY WARRANTY; without even the implied warranty of
   12.15 -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
   12.16 -;; Lesser General Public License for more details.
   12.17 -;;
   12.18 -;; You should have received a copy of the GNU Lesser General Public
   12.19 -;; License along with Indyvon.  If not, see
   12.20 -;; <http://www.gnu.org/licenses/>.
   12.21 -;;
   12.22 -
   12.23 -(ns net.kryshen.indyvon.viewport
   12.24 -  "Scrollable viewport and miniature."
   12.25 -  (:use
   12.26 -   (net.kryshen.indyvon core async views))
   12.27 -  (:import
   12.28 -   java.awt.Cursor
   12.29 -   java.awt.geom.AffineTransform))
   12.30 -  
   12.31 -;;(defn- translate [^AffineTransform transform ^double x ^double y]
   12.32 -;;  (doto ^AffineTransform (.clone transform)
   12.33 -;;        (.translate x y)))
   12.34 -
   12.35 -(defn- scale [^AffineTransform transform ^double sx ^double sy]
   12.36 -    (doto ^AffineTransform (.clone transform)
   12.37 -        (.scale sx sy)))
   12.38 -
   12.39 -(defn- pre-translate [^AffineTransform transform ^double x ^double y]
   12.40 -  (if (== 0.0 x y)
   12.41 -    transform
   12.42 -    (doto (AffineTransform/getTranslateInstance x y)
   12.43 -      (.concatenate transform))))
   12.44 -
   12.45 -(def ^:dynamic *viewport-scaling-step* (double 3/4))
   12.46 -(def ^:dynamic *viewport-min-scale* 1E-6)
   12.47 -(def ^:dynamic *viewport-max-scale* 1E6)
   12.48 -
   12.49 -(def ^:dynamic *viewport* nil)
   12.50 -(def ^:dynamic ^AffineTransform *viewport-transform*)
   12.51 -
   12.52 -(declare scale-viewport!)
   12.53 -
   12.54 -(defrecord ViewportState [transform
   12.55 -                          fix-x fix-y
   12.56 -                          last-width last-height
   12.57 -                          last-anchor-x last-anchor-y])
   12.58 -
   12.59 -(defn- update-viewport [state content-geom h-align v-align]
   12.60 -  (let [w *width*
   12.61 -        h *height*
   12.62 -        cw (width content-geom)
   12.63 -        ch (height content-geom)
   12.64 -        ax (anchor-x content-geom h-align cw)
   12.65 -        ay (anchor-y content-geom v-align ch)
   12.66 -        ax1 (align-x h-align (:last-width state) w)
   12.67 -        ay1 (align-y v-align (:last-height state) h)
   12.68 -        ax2 (- (:last-anchor-x state) ax)
   12.69 -        ay2 (- (:last-anchor-y state) ay)
   12.70 -        transform (:transform state)
   12.71 -        transform (if (and (zero? ax1) (zero? ay1)
   12.72 -                           (zero? ax2) (zero? ay2))
   12.73 -                    transform
   12.74 -                    (doto
   12.75 -                        (AffineTransform/getTranslateInstance ax1 ay1)
   12.76 -                      (.concatenate transform)
   12.77 -                      (.translate ax2 ay2)))]
   12.78 -    (assoc state
   12.79 -      :last-width w
   12.80 -      :last-height h
   12.81 -      :last-anchor-x ax
   12.82 -      :last-anchor-y ay
   12.83 -      :transform transform)))
   12.84 -
   12.85 -(defrecord Viewport [content h-align v-align state]
   12.86 -  View
   12.87 -  (render! [view]
   12.88 -    (repaint-on-update view)
   12.89 -    (with-handlers view
   12.90 -      (let [geom (geometry content)
   12.91 -            new-state (swap! state update-viewport geom h-align v-align)
   12.92 -            transform (:transform new-state)]
   12.93 -        ;; TODO: notify observers when size changes.
   12.94 -        (binding [*viewport* view
   12.95 -                  *viewport-transform* transform]
   12.96 -          (with-transform transform
   12.97 -            (draw! 0 0 (width geom) (height geom) false content))))
   12.98 -      (:mouse-pressed e
   12.99 -       (swap! state assoc
  12.100 -              :fix-x (:x-on-screen e)
  12.101 -              :fix-y (:y-on-screen e))
  12.102 -       (set-cursor! (Cursor. Cursor/MOVE_CURSOR)))
  12.103 -      (:mouse-released e
  12.104 -       (set-cursor! (Cursor. Cursor/DEFAULT_CURSOR)))
  12.105 -      (:mouse-dragged e
  12.106 -       (swap! state
  12.107 -              (fn [s]
  12.108 -                (assoc s
  12.109 -                  :transform (pre-translate
  12.110 -                              (:transform s)
  12.111 -                              (- (:x-on-screen e) (:fix-x s))
  12.112 -                              (- (:y-on-screen e) (:fix-y s)))
  12.113 -                  :fix-x (:x-on-screen e)
  12.114 -                  :fix-y (:y-on-screen e))))
  12.115 -       (update view))
  12.116 -      (:mouse-wheel e
  12.117 -       (scale-viewport!
  12.118 -        view
  12.119 -        (Math/pow *viewport-scaling-step* (:wheel-rotation e))
  12.120 -        true (:x e) (:y e)))))
  12.121 -  (geometry [_]
  12.122 -    (geometry content)))
  12.123 -
  12.124 -(def ^:private viewport-initial-state
  12.125 -  (->ViewportState
  12.126 -   (AffineTransform.) ; transform
  12.127 -   0 0                ; fix-x fix-y
  12.128 -   0 0                ; last-width last-height
  12.129 -   0 0))
  12.130 -
  12.131 -(defn viewport
  12.132 -  "Creates scrollable viewport view."
  12.133 -  ([content]
  12.134 -     (viewport :left :top content))
  12.135 -  ([h-align v-align content]
  12.136 -     (->Viewport content h-align v-align (atom viewport-initial-state))))
  12.137 -
  12.138 -(defn- scale-viewport [state vp s relative? x y]
  12.139 -  (let [^AffineTransform tr (:transform state)
  12.140 -        sx (if relative? s (/ s (.getScaleX tr)))
  12.141 -        sy (if relative? s (/ s (.getScaleY tr)))
  12.142 -        x (or x (align-x (:h-align vp) (:last-width state)))
  12.143 -        y (or y (align-y (:v-align vp) (:last-height state)))
  12.144 -        x (- x (* x sx))
  12.145 -        y (- y (* y sy))
  12.146 -        scaled (doto (AffineTransform/getTranslateInstance x y)
  12.147 -                 (.scale sx sy)
  12.148 -                 (.concatenate tr))
  12.149 -        sx (.getScaleX scaled)
  12.150 -        sy (.getScaleY scaled)]
  12.151 -    (if (<= *viewport-min-scale*
  12.152 -            (min sx sy)
  12.153 -            (max sx sy)
  12.154 -            *viewport-max-scale*)
  12.155 -      (assoc state
  12.156 -        :transform scaled)
  12.157 -      state)))
  12.158 -
  12.159 -(defn scale-viewport!
  12.160 -  ([viewport s]
  12.161 -     (scale-viewport! viewport s true))
  12.162 -  ([viewport s relative?]
  12.163 -     (scale-viewport! viewport s relative? nil nil))
  12.164 -  ([viewport s relative? x y]
  12.165 -     (swap! (:state viewport) scale-viewport viewport s relative? x y)
  12.166 -     (update viewport)))
  12.167 -
  12.168 -(defn reset-viewport! [viewport]
  12.169 -  (reset! (:state viewport) viewport-initial-state)
  12.170 -  (update viewport))
  12.171 -
  12.172 -(defn ^AffineTransform viewport-transform [viewport]
  12.173 -  (:transform @(:state viewport)))
  12.174 -
  12.175 -(defn- scaling
  12.176 -  [width height max-width max-height]
  12.177 -  (min (/ max-width width)
  12.178 -       (/ max-height height)))
  12.179 -
  12.180 -(defn miniature
  12.181 -  "Creates a view that asynchronously renders the content view scaled to
  12.182 -  the specified size."
  12.183 -  [mw mh content]
  12.184 -  (async-view
  12.185 -   mw mh *miniature-thread-priority*
  12.186 -   (reify
  12.187 -    View
  12.188 -    (render! [this]
  12.189 -      (let [geom (geometry content)
  12.190 -            cw (width geom)
  12.191 -            ch (height geom)
  12.192 -            s (scaling cw ch mw mh)]
  12.193 -        (.scale *graphics* s s)
  12.194 -        (draw! (align-x :center cw (/ mw s))
  12.195 -               (align-y :center ch (/ mh s))
  12.196 -               cw ch
  12.197 -               content)))
  12.198 -    (geometry [_]
  12.199 -      (->Size mw mh)))))
  12.200 -
  12.201 -(defn viewport-miniature
  12.202 -  "Creates miniature view of the viewport's contents."
  12.203 -  [m-width m-height viewport]
  12.204 -  (let [miniature (miniature m-width m-height (:content viewport))]
  12.205 -    (decorate-view miniature [l]
  12.206 -      (repaint-on-update viewport)
  12.207 -      (let [geom (geometry (:content viewport))
  12.208 -            s (scaling (width geom) (height geom) m-width m-height)
  12.209 -            vp-state @(:state viewport)
  12.210 -            {:keys [transform last-width last-height]} @(:state viewport)
  12.211 -            ox (align-x :center (width geom) (/ m-width s))
  12.212 -            oy (align-y :center (height geom) (/ m-height s))
  12.213 -            inverse (.createInverse ^AffineTransform transform)
  12.214 -            transform (doto (AffineTransform.)
  12.215 -                        (.scale s s)
  12.216 -                        (.translate ox oy)
  12.217 -                        (.concatenate inverse))
  12.218 -            move-vp (fn [state x y]
  12.219 -                      (let [x (- (/ x s) ox)
  12.220 -                            y (- (/ y s) oy)
  12.221 -                            tr (:transform state)
  12.222 -                            [x y] (transform-point tr x y)
  12.223 -                            x (- x (/ (:last-width state) 2))
  12.224 -                            y (- y (/ (:last-height state) 2))]
  12.225 -                        (assoc state
  12.226 -                          :transform (pre-translate tr (- x) (- y)))))
  12.227 -            move-vp! (fn [x y]
  12.228 -                       (swap! (:state viewport) move-vp x y)
  12.229 -                       (update viewport))]
  12.230 -        (with-color :alt-back-color
  12.231 -          (.fillRect *graphics* 0 0 *width* *height*))
  12.232 -        (with-transform transform
  12.233 -          (with-color :back-color
  12.234 -            (.fillRect *graphics* 0 0 last-width last-height)))
  12.235 -        (with-handlers l
  12.236 -          (draw! miniature)
  12.237 -          (:mouse-pressed e (move-vp! (:x e) (:y e)))
  12.238 -          (:mouse-dragged e (move-vp! (:x e) (:y e))))
  12.239 -        (with-transform transform
  12.240 -          (with-color :border-color
  12.241 -            (.drawRect *graphics* 0 0 last-width last-height)))))))

    13.1 --- a/src/net/kryshen/indyvon/views.clj	Mon Apr 14 15:37:28 2014 +0400
    13.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    13.3 @@ -1,410 +0,0 @@
    13.4 -;;
    13.5 -;; Copyright 2010-2014 Mikhail Kryshen <mikhail@kryshen.net>
    13.6 -;;
    13.7 -;; This file is part of Indyvon.
    13.8 -;;
    13.9 -;; Indyvon is free software: you can redistribute it and/or modify it
   13.10 -;; under the terms of the GNU Lesser General Public License version 3
   13.11 -;; only, as published by the Free Software Foundation.
   13.12 -;;
   13.13 -;; Indyvon is distributed in the hope that it will be useful, but
   13.14 -;; WITHOUT ANY WARRANTY; without even the implied warranty of
   13.15 -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
   13.16 -;; Lesser General Public License for more details.
   13.17 -;;
   13.18 -;; You should have received a copy of the GNU Lesser General Public
   13.19 -;; License along with Indyvon.  If not, see
   13.20 -;; <http://www.gnu.org/licenses/>.
   13.21 -;;
   13.22 -
   13.23 -(ns net.kryshen.indyvon.views
   13.24 -  "Implementations of the View protocol."
   13.25 -  (:use
   13.26 -   (net.kryshen.indyvon core async))
   13.27 -  (:import
   13.28 -   (java.awt Font Image Toolkit)
   13.29 -   java.awt.image.ImageObserver
   13.30 -   (java.awt.geom Area AffineTransform Rectangle2D$Double Point2D
   13.31 -                  Point2D$Double)
   13.32 -   (java.awt.font FontRenderContext TextLayout)
   13.33 -   java.util.concurrent.TimeUnit
   13.34 -   (com.google.common.cache Cache CacheBuilder CacheLoader)))
   13.35 -
   13.36 -(defmacro decorate-view
   13.37 -  "Decorate the view replacing render! implementation."
   13.38 -  [view & render-tail]
   13.39 -  `(let [view# ~view]
   13.40 -     (reify
   13.41 -       View
   13.42 -       (render! ~@render-tail)
   13.43 -       (geometry [t#] (geometry view#)))))
   13.44 -
   13.45 -(defrecord Empty []
   13.46 -  View
   13.47 -  (render! [_])
   13.48 -  (geometry [_]
   13.49 -    (->Size 0 0)))
   13.50 -
   13.51 -(def empty-view (->Empty))
   13.52 -
   13.53 -;; TODO: change argument order for decorators, content should be the
   13.54 -;; last.
   13.55 -
   13.56 -(defn padding
   13.57 -  "Adds padding to the content view."
   13.58 -  ([distance content]
   13.59 -     (padding distance distance distance distance content))
   13.60 -  ([top left bottom right content]
   13.61 -     (if (== 0 top left bottom right)
   13.62 -       content
   13.63 -       (reify
   13.64 -        View
   13.65 -        (render! [l]
   13.66 -           (draw! left top
   13.67 -                  (- *width* left right)
   13.68 -                  (- *height* top bottom)
   13.69 -                  false
   13.70 -                  content))
   13.71 -        (geometry [l]
   13.72 -          (->NestedGeometry (geometry content) top left bottom right))))))
   13.73 -
   13.74 -(defn border
   13.75 -  "Adds a border to the content view."
   13.76 -  ([content]
   13.77 -     (border 1 content))
   13.78 -  ([thickness content]
   13.79 -     (border thickness 0 content))
   13.80 -  ([thickness gap content]
   13.81 -     (let [view (padding (+ thickness gap) content)
   13.82 -           t (double thickness)]
   13.83 -       (decorate-view view [_]
   13.84 -         (render! view)
   13.85 -         (with-color :border-color
   13.86 -           (let [w (double *width*)
   13.87 -                 h (double *height*)
   13.88 -                 outer (Area. (Rectangle2D$Double. 0.0 0.0 w h))
   13.89 -                 inner (Area. (Rectangle2D$Double. t t (- w t t) (- h t t)))]
   13.90 -             (.subtract outer inner)
   13.91 -             (.fill *graphics* outer)))))))
   13.92 -
   13.93 -;; TODO: opacity and blur.
   13.94 -(defn shadow
   13.95 -  "Adds a shadow to the content view."
   13.96 -  ([content]
   13.97 -     (shadow 1 1 content))
   13.98 -  ([x-offset y-offset content]
   13.99 -     (let [x (if (neg? x-offset) (- x-offset) 0)
  13.100 -           y (if (neg? y-offset) (- y-offset) 0)
  13.101 -           abs-x (if (neg? x-offset) (- x-offset) x-offset)
  13.102 -           abs-y (if (neg? y-offset) (- y-offset) y-offset)
  13.103 -           shadow-x (+ x-offset x)
  13.104 -           shadow-y (+ y-offset y)]
  13.105 -       (reify
  13.106 -        View
  13.107 -        (render! [_]
  13.108 -          (let [w (- *width* abs-x)
  13.109 -                h (- *height* abs-y)]
  13.110 -            (with-color :shadow-color
  13.111 -              (.fillRect *graphics* shadow-x shadow-y w h))
  13.112 -            (draw! x y w h content)))
  13.113 -        (geometry [_]
  13.114 -          (->NestedGeometry (geometry content)
  13.115 -                            y x shadow-y shadow-x))))))
  13.116 -
  13.117 -(defn panel
  13.118 -  "An opaque view using theme's alt-back-color or a custom background
  13.119 -  color."
  13.120 -  ([content]
  13.121 -     (panel :alt-back-color content))
  13.122 -  ([back-color content]
  13.123 -     (decorate-view content [_]
  13.124 -       (with-color back-color
  13.125 -         (.fill *graphics* (Rectangle2D$Double. 0.0 0.0 *width* *height*)))
  13.126 -       (render! content))))
  13.127 -
  13.128 -(defn hbox
  13.129 -  "Creates a view that draws the specified content views placing them
  13.130 -   horizontally."
  13.131 -  [& contents]
  13.132 -  (reify
  13.133 -   View
  13.134 -   (render! [_]
  13.135 -     (let [widths (map #(width (geometry %)) contents)
  13.136 -           xs (cons 0 (reductions + widths))
  13.137 -           widths-sum (last xs)
  13.138 -           scale (/ *width* widths-sum)]
  13.139 -       (doseq [[c w x] (map vector contents widths xs)]
  13.140 -         (draw! x 0 w *height* c))))
  13.141 -   (geometry [_]
  13.142 -     (reduce #(->Size (+ (width %1) (width %2))
  13.143 -                      (max (height %1) (height %2)))
  13.144 -             (->Size 0 0)
  13.145 -             (map geometry contents)))))
  13.146 -
  13.147 -(defn vbox
  13.148 -  "Creates a view that draws the specified content views placing them
  13.149 -   vertically."
  13.150 -  [& contents]
  13.151 -  (reify
  13.152 -   View
  13.153 -   (render! [_]
  13.154 -     (let [heights (map #(height (geometry %)) contents)
  13.155 -           ys (cons 0 (reductions + heights))
  13.156 -           heights-sum (last ys)
  13.157 -           scale (/ *height* heights-sum)]
  13.158 -       (doseq [[c h y] (map vector contents heights ys)]
  13.159 -         (draw! 0 y *width* h c))))
  13.160 -   (geometry [_]
  13.161 -     (reduce #(->Size (max (width %1) (width %2))
  13.162 -                      (+ (height %1) (height %2)))
  13.163 -             (->Size 0 0)
  13.164 -             (map geometry contents)))))
  13.165 -
  13.166 -(defn- re-split [^java.util.regex.Pattern re s]
  13.167 -  (seq (.split re s)))
  13.168 -
  13.169 -(def ^:private ^Cache text-layout-cache
  13.170 -  (-> (CacheBuilder/newBuilder)
  13.171 -      (.softValues)
  13.172 -      (.expireAfterAccess (long 1) TimeUnit/SECONDS)
  13.173 -      (.build)))
  13.174 -
  13.175 -(defn- get-text-layout
  13.176 -  [^String line ^Font font ^FontRenderContext font-context]
  13.177 -  (.get text-layout-cache [line font font-context]
  13.178 -        #(TextLayout. line font font-context)))
  13.179 -
  13.180 -(defn- layout-text
  13.181 -  [lines font font-context]
  13.182 -  (map #(get-text-layout % font font-context) lines))
  13.183 -
  13.184 -(defn- text-width [layouts]
  13.185 -  (reduce (fn [w ^TextLayout tl] (max w (.getAdvance tl))) 0 layouts))
  13.186 -
  13.187 -(defn- text-height [layouts]
  13.188 -  (reduce (fn [w ^TextLayout tl]
  13.189 -            (+ w (.getAscent tl)
  13.190 -               (.getDescent tl)
  13.191 -               (.getLeading tl)))
  13.192 -          0 layouts))
  13.193 -
  13.194 -(defn label
  13.195 -  "Creates a view to display multiline text."
  13.196 -  ([text]
  13.197 -     (label :left :top text))
  13.198 -  ([h-align v-align text]
  13.199 -     (let [lines (re-split #"\r\n|\n|\r|\u0085|\u2028|\u2029" (str text))]
  13.200 -       (reify View
  13.201 -        (render! [view]
  13.202 -          (let [w *width*
  13.203 -                h *height*
  13.204 -                font (.getFont *graphics*)
  13.205 -                layouts (layout-text lines font (font-context))
  13.206 -                y (align-y v-align (text-height layouts) h)]
  13.207 -            (loop [layouts layouts, y y]
  13.208 -              (when-first [^TextLayout layout layouts]
  13.209 -                (let [ascent (.getAscent layout)
  13.210 -                      lh (+ ascent (.getDescent layout) (.getLeading layout))
  13.211 -                      x (align-x h-align (.getAdvance layout) w)]
  13.212 -                  (.draw layout *graphics* x (+ y ascent))
  13.213 -                  (recur (next layouts) (+ y lh)))))))
  13.214 -        (geometry [view]
  13.215 -          (let [layouts (layout-text lines (:font *theme*) (font-context))
  13.216 -                w (text-width layouts)
  13.217 -                h (text-height layouts)]
  13.218 -            (->Size w h)))))))
  13.219 -
  13.220 -(defn- ^ImageObserver image-observer [view]
  13.221 -  (reify
  13.222 -   ImageObserver
  13.223 -   (imageUpdate [this img infoflags x y width height]
  13.224 -     (update view)
  13.225 -     (zero? (bit-and infoflags
  13.226 -                     (bit-or ImageObserver/ALLBITS
  13.227 -                             ImageObserver/ABORT))))))
  13.228 -
  13.229 -(defn image-view
  13.230 -  [image-or-uri]
  13.231 -  (let [^Image image (if (instance? Image image-or-uri)
  13.232 -                       image-or-uri
  13.233 -                       (.getImage (Toolkit/getDefaultToolkit)
  13.234 -                                  ^java.net.URL image-or-uri))]
  13.235 -    (.prepareImage (Toolkit/getDefaultToolkit) image -1 -1 nil)
  13.236 -    (reify
  13.237 -     View
  13.238 -     (render! [view]
  13.239 -       (repaint-on-update view)
  13.240 -       (.drawImage *graphics* image 0 0 (image-observer view)))
  13.241 -     (geometry [view]
  13.242 -       (let [observer (image-observer view)
  13.243 -             width (.getWidth image observer)
  13.244 -             height (.getHeight image observer)
  13.245 -             width (if (pos? width) width 1)
  13.246 -             height (if (pos? height) height 1)]
  13.247 -         (->Size width height))))))
  13.248 -
  13.249 -(def ^:dynamic *miniature-thread-priority* 2)
  13.250 -
  13.251 -(defn ref-view
  13.252 -  [view-ref]
  13.253 -  (let [l (reify
  13.254 -           View
  13.255 -           (render! [l]
  13.256 -             (repaint-on-update l)
  13.257 -             (if-let [view @view-ref]
  13.258 -               (render! view)))
  13.259 -           (geometry [_]
  13.260 -             (if-let [view @view-ref]
  13.261 -               (geometry view)
  13.262 -               (->Size 1 1))))]
  13.263 -    (add-watch view-ref l (fn [_ _ _ _] (update l)))
  13.264 -    l))
  13.265 -
  13.266 -;;
  13.267 -;; View context decorators
  13.268 -;;
  13.269 -
  13.270 -(defmacro handler [view & handlers]
  13.271 -  "Adds event handling to the view."
  13.272 -  `(let [view# ~view]
  13.273 -     (decorate-view view# [t#]
  13.274 -       (with-handlers t#
  13.275 -         (render! view#)
  13.276 -         ~@handlers))))
  13.277 -
  13.278 -(defn themed [view & map-or-keyvals]
  13.279 -  (let [theme (if (== (count map-or-keyvals) 1)
  13.280 -                (first map-or-keyvals)
  13.281 -                (apply array-map map-or-keyvals))]
  13.282 -    (reify
  13.283 -     View
  13.284 -     (render! [_]
  13.285 -       (with-theme theme
  13.286 -         (render! view)))
  13.287 -     (geometry [_]
  13.288 -       (with-theme theme
  13.289 -         (geometry view))))))
  13.290 -
  13.291 -(defn hinted [view & map-or-keyvals]
  13.292 -  (let [hints (if (== (count map-or-keyvals) 1)
  13.293 -                (first map-or-keyvals)
  13.294 -                (apply array-map map-or-keyvals))]
  13.295 -    (decorate-view view [_]
  13.296 -      (with-hints* hints render! view))))
  13.297 -
  13.298 -;;
  13.299 -;; Measuring time
  13.300 -;;
  13.301 -
  13.302 -(def ^:dynamic *interval*)
  13.303 -
  13.304 -(defn interval-view
  13.305 -  "Creates a view that measures time between repaints ant draws it's
  13.306 -  content with the *interval* var bound to the measured time."
  13.307 -  [content]
  13.308 -  (let [last-time (atom nil)]
  13.309 -    (decorate-view content [_]
  13.310 -      (compare-and-set! last-time nil *time*)
  13.311 -      (let [lt @last-time]
  13.312 -        (binding [*interval* (if (compare-and-set! last-time lt *time*)
  13.313 -                               (- *time* lt)
  13.314 -                               0)] ; already measured on parallel thread
  13.315 -          (render! content))))))
  13.316 -
  13.317 -(defn- fps-label [text]
  13.318 -  (padding 5 (label :right :bottom text)))
  13.319 -
  13.320 -(defn fps-view
  13.321 -  "Creates a view that draws content and displays the
  13.322 -  frames per second rate."
  13.323 -  [content]
  13.324 -  (let [update-interval 2E8 ; 0.2 s in nanoseconds
  13.325 -        frames (ref 0)
  13.326 -        prev-time (ref nil)
  13.327 -        display (ref (fps-label "fps n/a"))]
  13.328 -    (decorate-view content [_]
  13.329 -      (draw! content)
  13.330 -      (draw!
  13.331 -       (dosync
  13.332 -        (alter frames inc)
  13.333 -        (if @prev-time
  13.334 -          (let [elapsed (- *time* @prev-time)]
  13.335 -            (when (> elapsed update-interval)
  13.336 -              (let [fps (/ @frames (/ elapsed 1E9))]
  13.337 -                (ref-set display (fps-label (format "%.1f" fps)))
  13.338 -                (ref-set frames 0)
  13.339 -                (ref-set prev-time *time*))))
  13.340 -          (ref-set prev-time *time*))
  13.341 -        @display)))))
  13.342 -
  13.343 -;;
  13.344 -;; Overlays
  13.345 -;;
  13.346 -
  13.347 -(def ^:private ^:dynamic *above*)
  13.348 -
  13.349 -(defn- overlay* [f & args]
  13.350 -  (var-set #'*above* (conj *above* (apply partial f args))))
  13.351 -
  13.352 -(defn- ^Point2D to-graphics-coords
  13.353 -  [^AffineTransform transform x y]
  13.354 -  (let [p (Point2D$Double. x y)]
  13.355 -    (.transform transform p p)
  13.356 -    (.transform (.createInverse (.getTransform *graphics*)) p p)
  13.357 -    p))
  13.358 -
  13.359 -(defn- draw-relative!
  13.360 -  ([transform x y view]
  13.361 -     (let [p (to-graphics-coords transform x y)]
  13.362 -       (draw! (.getX p) (.getY p) view)))
  13.363 -  ([transform x y w h view]
  13.364 -     (let [p (to-graphics-coords transform x y)]
  13.365 -       (draw! (.getX p) (.getY p) w h view))))
  13.366 -
  13.367 -(defn- draw-relative-aligned!
  13.368 -  [transform h-align v-align x y view]
  13.369 -  (let [geom (geometry view)
  13.370 -        w (width geom)
  13.371 -        h (height geom)
  13.372 -        p (to-graphics-coords transform x y)
  13.373 -        x (- (.getX p) (anchor-x geom h-align w))
  13.374 -        y (- (.getY p) (anchor-y geom v-align h))]
  13.375 -    (draw! x y w h view)))
  13.376 -
  13.377 -(defn overlay!
  13.378 -  "Draws view in the overlay context above the other views."
  13.379 -  ([view]
  13.380 -     (overlay* draw-relative! (.getTransform *graphics*) 0 0 view))
  13.381 -  ([x y view]
  13.382 -     (overlay* draw-relative! (.getTransform *graphics*) x y view))
  13.383 -  ([x y w h view]
  13.384 -     (overlay* draw-relative! (.getTransform *graphics*) x y w h view)))
  13.385 -
  13.386 -(defn overlay-aligned! [h-align v-align x y view]
  13.387 -  (overlay* draw-relative-aligned!
  13.388 -            (.getTransform *graphics*)
  13.389 -            h-align v-align x y
  13.390 -            view))
  13.391 -
  13.392 -(defn with-overlays* [rec? f & args]
  13.393 -  (binding [*above* []]
  13.394 -    (apply f args)
  13.395 -    (if rec?
  13.396 -      (loop [above *above*]
  13.397 -        (when (seq above)
  13.398 -          (var-set #'*above* [])
  13.399 -          (doseq [f above]
  13.400 -            (f))
  13.401 -          (recur *above*)))
  13.402 -      (doseq [of *above*]
  13.403 -        (of)))))
  13.404 -
  13.405 -(defmacro with-overlays [rec? & body]
  13.406 -  `(with-overlays* ~rec? (fn [] ~@body)))
  13.407 -
  13.408 -(defn layered
  13.409 -  ([content]
  13.410 -     (layered true content))
  13.411 -  ([rec? content]
  13.412 -     (decorate-view content [_]
  13.413 -       (with-overlays* rec? render! content))))