;;
;; Copyright 2010-2014 Mikhail Kryshen <mikhail@kryshen.net>
;;
;; This file is part of Indyvon.
;;
;; Indyvon is free software: you can redistribute it and/or modify it
;; under the terms of the GNU Lesser General Public License version 3
;; only, as published by the Free Software Foundation.
;;
;; Indyvon is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; Lesser General Public License for more details.
;;
;; You should have received a copy of the GNU Lesser General Public
;; License along with Indyvon.  If not, see
;; <http://www.gnu.org/licenses/>.
;;

(ns indyvon.core
  (:import
   (java.awt Graphics2D RenderingHints Component Color Font Shape
             Rectangle Cursor EventQueue)
   (java.awt.geom AffineTransform Point2D$Double Rectangle2D$Double Area)
   (java.awt.event MouseListener MouseMotionListener
                   MouseWheelListener MouseWheelEvent)
   (java.awt.font FontRenderContext)
   java.util.concurrent.ConcurrentMap
   com.google.common.collect.MapMaker))

;;
;; View context
;;

(def ^:dynamic ^Graphics2D *graphics*)

(def ^:dynamic ^FontRenderContext *font-context*
  "FontRenderContext to use when Graphics2D is not available."
  (FontRenderContext.
   nil
   RenderingHints/VALUE_TEXT_ANTIALIAS_DEFAULT
   RenderingHints/VALUE_FRACTIONALMETRICS_DEFAULT))

(def ^:dynamic *width*
  "Width of the rendering area.")

(def ^:dynamic *height*
  "Height of the rendering area.")

(def ^:dynamic ^Shape *clip*)

(def ^:dynamic ^Shape *input-clip*
  "Clipping area used for dispatching pointer events (intersected with
  *clip*). If nil, *clip* will be used.")

(def ^:dynamic *time*
  "Timestamp of the current frame (in nanoseconds).")

(def ^:dynamic *scene*
  "Encloses state that should be retained between repaints.")

(def ^:dynamic *states*
  "Transient scene states, a map.")

(def ^:dynamic *event-dispatcher*)

(def ^:dynamic ^AffineTransform *initial-transform*
  "Initial transform associated with the graphics context.")

(def ^:dynamic ^AffineTransform *inverse-initial-transform*
  "Inversion of the initial transform associated with the graphics
  context.")

(defrecord Theme [fore-color back-color alt-back-color border-color
                  shadow-color font])

;; REMIND: use system colors, see java.awt.SystemColor.
(defn default-theme []
  (Theme. Color/BLACK
          Color/WHITE
          (Color. 0xDD 0xDD 0xDD)
          (Color. 0 0 0xCC)
          (Color. 0x44 0x44 0x44)
          (Font. "Sans" Font/PLAIN 12)))

(def ^:dynamic *theme* (default-theme))

;;
;; Core protocols and types
;;

(defprotocol View
  "Basic UI element."
  (render! [view]
    "Draws the view in the current *graphics* context.")
  (geometry [view]
    "Returns the preferred Geometry for the view."))

(defprotocol Geometry
  "Describes geometry of a View.  Prefer using the available
  implementations (Size, FixedGeometry and NestedGeometry) over
  extending this protocol directly as it is likely to be changed in
  the future versions."
  (width [geom] [geom height])
  (height [geom] [geom width])
  (anchor-x [geom h-align width]
    "Returns the x coordinate of the anchor point for the specified
    horizontal alignment and width, h-align could be :left, :center
    or :right.")
  (anchor-y [geom v-align height]
    "Returns the y coordinate of the anchor point for the specified
    vertical alignment and height, v-align could be :top, :center
    or :bottom."))

(defn- emit-align-xy [align size first center last]
  `(case ~align
         ~first 0
         ~center (/ ~size 2)
         ~last ~size))

;; Define as macro to avoid unnecessary calculation of width or height.
(defmacro align-x
  ([align inner outer]
     `(align-x ~align (- ~outer ~inner)))
  ([align width]
     (emit-align-xy align width :left :center :right)))

(defmacro align-y
  ([align inner outer]
     `(align-y ~align (- ~outer ~inner)))
  ([align height]
     (emit-align-xy align height :top :center :bottom)))

(defrecord Size [width height]
  Geometry
  (width  [_] width)
  (width [_ _] width)
  (height [_] height)
  (height [_ _] height)
  (anchor-x [_ h-align width]
    (align-x h-align width))
  (anchor-y [_ v-align height]
    (align-y v-align height)))

(defrecord FixedGeometry [ax ay width height]
  Geometry
  (width  [_] width)
  (width [_ _] width)
  (height [_] height)
  (height [_ _] height)
  (anchor-x [_ _ _] ax)
  (anchor-y [_ _ _] ay))

(defrecord NestedGeometry [geometry top left bottom right]
  Geometry
  (width  [_]
    (+ left right (width geometry)))
  (width [_ h]
    (+ left right (width geometry (- h top bottom))))
  (height [_]
    (+ top bottom (height geometry)))
  (height [_ w]
    (+ top bottom (height geometry (- w left right))))
  (anchor-x [_ h-align w]
    (+ left (anchor-x geometry h-align (- w left right))))
  (anchor-y [_ v-align h]
    (+ top (anchor-y geometry v-align (- h top bottom)))))

(defrecord ScaledGeometry [geometry sx sy]
  Geometry
  (width  [_]
    (* sx (width geometry)))
  (width [_ h]
    (* sx (width geometry (/ h sy))))
  (height [_]
    (* sy (height geometry)))
  (height [_ w]
    (* sy (height geometry (/ w sx))))
  (anchor-x [_ h-align w]
    (* sx (anchor-x geometry h-align (/ w sx))))
  (anchor-y [_ v-align h]
    (* sy (anchor-y geometry v-align (/ h sy)))))

;; (defn ^:private to-integer
;;   ^long [align x]
;;   (if (integer? x)
;;     x
;;     (let [x (double x)]
;;       (Math/round
;;        (case align
;;          (:top :left) (Math/floor x)
;;          :center x
;;          (:bottom :right) (Math/ceil x))))))

;; (defrecord IntegerGeometry [geometry]
;;   Geometry
;;   (width [_]
;;     (to-integer :right (width geometry)))
;;   (width [_ h]
;;     (to-integer :right (width geometry h)))
;;   (height [_]
;;     (to-integer :bottom (height geometry)))
;;   (height [_ w]
;;     (to-integer :bottom (height geometry w)))
;;   (anchor-x [_ h-align w]
;;     (to-integer h-align (anchor-x geometry h-align w)))
;;   (anchor-y [_ v-align h]
;;     (to-integer v-align (anchor-y geometry v-align h))))

;; TODO: modifiers
(defrecord MouseEvent [id when x y x-on-screen y-on-screen button
                       wheel-rotation transform component])

;; TODO: KeyEvent

(defprotocol EventDispatcher
  (listen! [this component]
     "Listen for events on the specified AWT Component.")
  (create-dispatcher [this handle handlers]
     "Returns new event dispatcher associated with the specified event
     handlers (an event-id -> handler-fn map). Handle is used to match
     the contexts between commits.")
  (commit [this]
     "Apply the registered handlers for event processing.")
  (handle-picked? [this handle]
     "Returns true if the specified handle received the :mouse-pressed
     event and have not yet received :moused-released.")
  (handle-hovered? [this handle]
     "Returns true if the specified handle received the :mouse-entered
     event and have not yet received :mouse-exited."))

(defn- assoc-cons [m key val]
  (->> (get m key) (cons val) (assoc m key)))

;;
;; Observers
;; The mechanism used by views to request repaints
;;

(def ^ConcurrentMap observers
     (-> (MapMaker.) (.weakKeys) (.makeMap)))

(defn- cm-replace!
  "Wrap ConcurrentMap replace method to treat nil value as absent
   mapping. Use with maps that does not support nil values."
  [^ConcurrentMap cmap key old new]
  (if (nil? old)
    (nil? (.putIfAbsent cmap key new))
    (.replace cmap key old new)))

(defn- cm-swap!
  "Atomically swaps the value associated with key in ConcurrentMap
   to be (apply f current-value args). Returns the new value."
  [^ConcurrentMap cmap key f & args]
  (loop []
    (let [old (.get cmap key)
          new (apply f old args)]
      (if (cm-replace! cmap key old new)
        new
        (recur)))))

(defn add-observer
  "Add observer fn for the target. Watcher identifies the group of
  observers and could be used to remove the group. Watcher is weakly
  referenced, all associated observers will be removed when the
  wathcer is removed by gc. The observer fn will be called with
  watcher and target arguments and any additional arguments specified
  in update call."
  [watcher target f]
  (cm-swap! observers watcher assoc-cons target f)
  nil)

(defn remove-observers
  "Remove group of observers associated with the specified watcher."
  [watcher]
  (.remove observers watcher)
  nil)

(defn- replace-observers-watcher
  [old-watcher new-watcher]
  (if-let [old (.remove observers old-watcher)]
    (.put observers new-watcher old))
  nil)

(defn update
  "Notify observers."
  [target & args]
  (doseq [entry observers
          f (get (val entry) target)]
    (apply f (key entry) target args)))

(defn add-context-observer
  "Observer registered with this function will be automatically
  removed after the next repaint is complete."
  [target f]
  (add-observer *scene* target f))

(defn repaint-on-update
  "Trigger repaint of the current scene when the target updates."
  [target]
  (let [scene *scene*]
    (if-not (identical? scene target)
      (add-observer scene target (fn [w _] (update w))))))

(defn repaint
  "Requests repaint of the current scene. If handle and state are
  specified, the handle will be associated with the state in the
  *states* map for the next paint iteration."
  ([]
     (update *scene*))
  ([handle state]
     (let [scene *scene*]
       (swap! (:next-state scene) assoc handle state)
       (update scene))))

;;
;; Rendering
;;

(defn ^FontRenderContext font-context
  "Returns FontRenderContext for the current view context."
  []
  (if (bound? (var *graphics*))
    (.getFontRenderContext *graphics*)
    *font-context*))

(defn ^AffineTransform relative-transform
  "Returns AffineTransform: view context -> AWT component."
  []
  (let [tr (.getTransform *graphics*)]
    (.preConcatenate tr *inverse-initial-transform*)
    tr))

(defn ^AffineTransform inverse-relative-transform
  "Returns AffineTransform: AWT component -> view context."
  []
  (let [tr (.getTransform *graphics*)]
    (.invert tr)                          ; absolute -> view
    (.concatenate tr *initial-transform*) ; component -> absolute
    tr))

(defn transform-point [^AffineTransform tr ^double x ^double y]
  (let [p (Point2D$Double. x y)]
    (.transform tr p p)
    [(.x p) (.y p)]))

(defn inverse-transform-point [^AffineTransform tr ^double x ^double y]
  (let [p (Point2D$Double. x y)]
    (.inverseTransform tr p p)
    [(.x p) (.y p)]))

;; (defn- clip
;;   "Intersect clipping area with the specified shape or bounds.
;;    Returns new clip (Shape or nil if empty)."
;;   ([x y w h]
;;      (clip (Rectangle2D$Double. x y w h)))
;;   ([shape]
;;      (let [a1 (Area. shape)
;;            a2 (if (instance? Area *clip*) *clip* (Area. *clip*))]
;;        (.transform a1 (relative-transform))
;;        (.intersect a1 a2)
;;        (if (.isEmpty a1)
;;          nil
;;          a1))))

;; Use faster clipping calculation provided by Graphics2D.
(defn- clip
  "Intersect clipping area with the specified Shape in current
  transform coordinates. Returns new clip in the AWT component
  coordinates (Shape or nil if empty)."
  [^Shape shape]
  (let [^Graphics2D clip-g (.create *graphics*)]
    (try
      (doto clip-g
        (.setClip shape)
        (.setTransform *initial-transform*)
        (.clip *clip*))
      (if (.isEmpty (.getClipBounds clip-g))
        nil
        (.getClip clip-g))
      (finally
       (.dispose clip-g)))))

(defn- theme-get*
  ([theme key]
     (theme-get* theme key nil))
  ([theme key not-found]
     (if-let [e (find theme key)]
       (loop [k (val e)]
         (if-let [e1 (and (keyword? k)
                          (find theme k))]
           (recur (val e1))
           k))
       not-found)))

(defn theme-get
  ([key]
     (theme-get* *theme* key))
  ([key not-found]
     (theme-get* *theme* key not-found)))

(defn ^Graphics2D apply-theme
  "Set graphics' color and font to match theme.
  Modifies and returns the first argument."
  ([]
     (apply-theme *graphics* *theme*))
  ([^Graphics2D graphics theme]
     (doto graphics
       (.setColor (theme-get :fore-color))
       (.setBackground (theme-get :back-color))
       (.setFont (theme-get :font)))))

(defn- ^Graphics2D create-graphics
  ([]
     (apply-theme (.create *graphics*) *theme*))
  ([^long x ^long y ^long w ^long h]
     (apply-theme (.create *graphics* x y w h) *theme*)))

(defn- with-bounds-noclip*
  [x y w h f & args]
  (let [graphics (create-graphics)]
    (try
      (.translate graphics (double x) (double y))
      (binding [*width* w
                *height* h
                *input-clip* (Rectangle2D$Double. 0.0 0.0 w h)
                *graphics* graphics]
        (apply f args))
      (finally
       (.dispose graphics)))))

(defn with-bounds*
  [x y w h f & args]
  (let [x (double x)
        y (double y)
        bounds (Rectangle2D$Double. x y w h)]
    (when-let [clip (clip bounds)]
      (let [^Graphics2D graphics (create-graphics)]
        (try
          (.clip graphics bounds)
          (.translate graphics x y)
          (binding [*width* w
                    *height* h
                    *clip* clip
                    *input-clip* nil
                    *graphics* graphics]
            (apply f args))
          (finally
           (.dispose graphics)))))))

(defmacro with-bounds
  [x y w h & body]
  `(with-bounds* ~x ~y ~w ~h (fn [] ~@body)))

(defmacro with-theme
  [theme & body]
  `(binding [*theme* (merge *theme* ~theme)]
     ~@body))

(defn with-theme* [theme f & args]
  (with-theme theme
    (apply f args)))

(defmacro with-color [color-or-key & body]
  `(let [color# ~color-or-key
         color# (theme-get color# color#)
         g# *graphics*
         old-color# (.getColor g#)]
     (try
       (.setColor g# color#)
       ~@body
       (finally
         (.setColor g# old-color#)))))

(defmacro with-font [font-or-key & body]
  `(let [font# ~font-or-key
         font# (theme-get font# font#)
         g# *graphics*
         old-font# (.getFont g#)]
     (try
       (.setFont g# font#)
       ~@body
       (finally
         (.setColor g# old-font#)))))

(defmacro with-stroke [stroke & body]
  `(let [g# *graphics*
         old-stroke# (.getStroke g#)]
     (try
       (.setStroke g# ~stroke)
       ~@body
       (finally
        (.setStroke g# old-stroke#)))))

(defmacro with-hints
  [hints & body]
  `(let [h# ~hints
         g# *graphics*
         old# (.getRenderingHints g#)]
     (try
       (.addRenderingHints g# h#)
       ~@body
       (finally
        (.setRenderingHints g# old#)))))

(defn with-hints* [hints f & args]
  (with-hints hints
    (apply f args)))

;; TODO: constructor for AffineTransform.
;; (transform :scale 0.3 0.5
;;            :translate 5 10
;;            :rotate (/ Math/PI 2))

(defmacro with-transform [transform & body]
  `(let [g# *graphics*
         old-t# (.getTransform g#)]
     (try
       (.transform g# ~transform)
       ~@body
       (finally
        (.setTransform g# old-t#)))))

(defmacro with-rotate [theta ax ay & body]
  `(let [transform# (AffineTransform/getRotateInstance ~theta ~ax ~ay)]
     (with-transform transform# ~@body)))

(defmacro with-translate [x y & body]
  `(let [x# ~x
         y# ~y
         g# *graphics*]
     (try
       (.translate g# x# y#)
       ~@body
       (finally
        (.translate g# (- x#) (- y#))))))

(defn draw!
  "Draws the View."
  ([view]
     (let [graphics (create-graphics)]
       (try
         (binding [*graphics* graphics]
           (render! view))
         (finally
          (.dispose graphics)))))
  ([view x y]
     (draw! view x y true))
  ([view x y clip?]
     (let [geom (geometry view)]
       (draw! view x y (width geom) (height geom) clip?)))
  ([view x y width height]
     (draw! view x y width height true))
  ([view x y width height clip?]
     (if clip?
       (with-bounds* x y width height render! view)
       (with-bounds-noclip* x y width height render! view))))

(defn draw-aligned!
  "Draws the View.  Location is relative to the view's anchor point
  for the specified alignment."
  ([view h-align v-align x y]
     (let [geom (geometry view)
           w (width geom)
           h (height geom)]
       (draw! view
              (- x (anchor-x geom h-align w))
              (- y (anchor-y geom v-align h))
              w h)))
  ([view h-align v-align x y w h]
     (let [geom (geometry view)]
       (draw! view
              (- x (anchor-x geom h-align w))
              (- y (anchor-y geom v-align h))
              w h))))

;;
;; Event handling.
;;

(defn with-handlers*
  [handle handlers f & args]
  (binding [*event-dispatcher* (create-dispatcher
                                *event-dispatcher* handle handlers)]
    (apply f args)))

(defmacro with-handlers
  "specs => (:event-id name & handler-body)*

  Execute form with the specified event handlers."
  [handle form & specs]
  `(with-handlers* ~handle
     ~(reduce (fn [m spec]
                (assoc m (first spec)
                       `(fn [~(second spec)]
                          ~@(nnext spec)))) {}
                          specs)
     (fn [] ~form)))

(defn picked? [handle]
  (handle-picked? *event-dispatcher* handle))

(defn hovered? [handle]
  (handle-hovered? *event-dispatcher* handle))

;;
;; EventDispatcher implementation
;;

(def awt-events
     {java.awt.event.MouseEvent/MOUSE_CLICKED  :mouse-clicked
      java.awt.event.MouseEvent/MOUSE_DRAGGED  :mouse-dragged
      java.awt.event.MouseEvent/MOUSE_ENTERED  :mouse-entered
      java.awt.event.MouseEvent/MOUSE_EXITED   :mouse-exited
      java.awt.event.MouseEvent/MOUSE_MOVED    :mouse-moved
      java.awt.event.MouseEvent/MOUSE_PRESSED  :mouse-pressed
      java.awt.event.MouseEvent/MOUSE_RELEASED :mouse-released
      java.awt.event.MouseEvent/MOUSE_WHEEL    :mouse-wheel})

(def dummy-event-dispatcher
  (reify EventDispatcher
    (listen! [_ _])
    (create-dispatcher [this _ _] this)
    (commit [_])
    (handle-picked? [_ _])
    (handle-hovered? [_ _])))

;; Not using defrecord to avoid unacceptable overhead of recursive
;; hash code calculation.
(deftype DispatcherNode [handle handlers parent
                         ^Shape clip ^AffineTransform transform
                         bindings]
  EventDispatcher
  (listen! [this component]
    (listen! parent component))
  (create-dispatcher [this handle handlers]
    (create-dispatcher parent handle handlers))
  (commit [this]
    (commit parent))
  (handle-picked? [this handle]
    (handle-picked? parent handle))
  (handle-hovered? [this handle]
    (handle-hovered? parent handle)))

(defn- make-node [handle handlers]
  (let [clip (if *input-clip*
               (clip *input-clip*)
               *clip*)
        bindings (-> (get-thread-bindings)
                     (dissoc (var *graphics*))
                     (assoc (var *font-context*) (font-context)))]
    (DispatcherNode. handle handlers *event-dispatcher* clip
                     (relative-transform)
                     bindings)))

(defn- add-node [tree ^DispatcherNode node]
  (assoc-cons tree (.parent node) node))

(defn- nodes [tree]
  (apply concat (vals tree)))

(defn- under-cursor
  "Returns a vector of child nodes under cursor."
  [node tree ^long x ^long y]
  (some (fn [^DispatcherNode n]
          (if (and (.clip n) (.contains ^Shape (.clip n) x y))
            (conj (vec (under-cursor n tree x y)) n)))
        (get tree node)))

(defn- translate-mouse-event [^java.awt.event.MouseEvent event
                              ^AffineTransform tr id]
  (let [[x y] (inverse-transform-point tr (.getX event) (.getY event))
        rotation (if (instance? MouseWheelEvent event)
                   (.getWheelRotation ^MouseWheelEvent event)
                   nil)]
    (->MouseEvent id (.getWhen event) x y
                  (.getXOnScreen event) (.getYOnScreen event)
                  (.getButton event)
                  rotation
                  tr
                  (.getComponent event))))

(defn- translate-and-dispatch
  ([nodes first-only ^java.awt.event.MouseEvent event]
     (translate-and-dispatch nodes first-only
                             event (awt-events (.getID event))))
  ([nodes first-only event id]
     (if-let [^DispatcherNode node (first nodes)]
       (let [handlers (.handlers node)
             handler (get handlers id)]
         (if handler
           (do
             (with-bindings* (.bindings node)
               handler
               (translate-mouse-event event (.transform node) id))
             (when-not first-only
               (recur (rest nodes) false event id)))
           (when-not (and (= id :mouse-dragged)
                          (or (contains? handlers :mouse-pressed)
                              (contains? handlers :mouse-released)))
             (recur (rest nodes) first-only event id)))))))

(defn- process-mouse-event
  [dispatcher ^java.awt.event.MouseEvent source-event]
  (let [{active-ref :active
         hovered-ref :hovered
         picked-ref :picked
         last-ref :last-motion
         tree-ref :tree} dispatcher
         pressed (and source-event
                      (== (.getID source-event)
                          java.awt.event.MouseEvent/MOUSE_PRESSED))
         released (and source-event
                       (== (.getID source-event)
                           java.awt.event.MouseEvent/MOUSE_RELEASED))
         ^java.awt.event.MouseEvent last-event @last-ref
         ^java.awt.event.MouseEvent event (or source-event last-event)]
    (when event
      (let [x (.getX event)
            y (.getY event)
            active @active-ref
            active (if (and active
                            source-event
                            (== (.getX last-event) x)
                            (== (.getY last-event) y))
                     active
                     (ref-set active-ref
                              (under-cursor dispatcher @tree-ref x y)))
            acted (cond
                   pressed (ref-set picked-ref active)
                   released (let [picked @picked-ref]
                              (ref-set picked-ref nil)
                              picked)
                   :else active)
            picked (seq @picked-ref)
            pred #(= (.handle ^DispatcherNode %1) (.handle ^DispatcherNode %2))
            hovered (if picked
                      (filter #(some (partial pred %) picked) active)
                      active)
            remove-all (fn [c1 c2]
                         (filter #(not (some (partial pred %) c2)) c1))
            old-hovered @hovered-ref
            exited (remove-all old-hovered hovered)
            entered (remove-all hovered old-hovered)
            moved (or picked (remove-all hovered entered))]
        (ref-set hovered-ref hovered)
        (ref-set last-ref event)
        [exited entered moved acted event]))))

(defn- dispatch-mouse-event
  [dispatcher source-event button?]
  (when-let [[exited
              entered
              moved
              acted
              event] (dosync (process-mouse-event dispatcher source-event))]
    (when button?
      (translate-and-dispatch acted true event))
    (translate-and-dispatch exited false event :mouse-exited)
    (translate-and-dispatch entered false event :mouse-entered)
    (when-not button?
      (translate-and-dispatch moved true source-event))))

(defrecord RootEventDispatcher [tree-r  ;; register
                                tree    ;; dispatch
                                active  ;; nodes under cursor
                                hovered ;; mouse entered
                                picked  ;; mouse pressed
                                last-motion]
  EventDispatcher
  (listen! [dispatcher component]
    (doto ^Component component
          (.addMouseListener dispatcher)
          (.addMouseWheelListener dispatcher)
          (.addMouseMotionListener dispatcher)))
  (create-dispatcher [dispatcher handle handlers]
    (let [node (make-node handle handlers)]
      (dosync (alter tree-r add-node node))
      node))
  (commit [dispatcher]
    (let [[exited
           entered
           _ _
           event] (dosync
                   ;; TODO: retain contexts that do
                   ;; not intersect graphics
                   ;; clipping area in tree.
                   (ref-set tree @tree-r)
                   (ref-set tree-r {})
                   (process-mouse-event dispatcher nil))]
      ;; Send mouse entered and exited events if necessary due to
      ;; updated layout.
      (translate-and-dispatch exited false event :mouse-exited)
      (translate-and-dispatch entered false event :mouse-entered)))
  (handle-picked? [dispatcher handle]
    (some #(= handle (.handle ^DispatcherNode %)) @picked))
  (handle-hovered? [dispatcher handle]
    (some #(= handle (.handle ^DispatcherNode %)) @hovered))
  MouseListener
  (mouseEntered [dispatcher event]
    (dispatch-mouse-event dispatcher event false))
  (mouseExited [dispatcher event]
    (dispatch-mouse-event dispatcher event false))
  (mouseClicked [dispatcher event]
    (dispatch-mouse-event dispatcher event true))
  (mousePressed [dispatcher event]
    (dispatch-mouse-event dispatcher event true))
  (mouseReleased [dispatcher event]
    (dispatch-mouse-event dispatcher event true))
  MouseWheelListener
  (mouseWheelMoved [dispatcher event]
    (dispatch-mouse-event dispatcher event true))
  MouseMotionListener
  (mouseDragged [dispatcher event]
    (dispatch-mouse-event dispatcher event false))
  (mouseMoved [dispatcher event]
    (dispatch-mouse-event dispatcher event false)))

(defn root-event-dispatcher []
  (->RootEventDispatcher
   (ref {}) (ref {})             ;; trees
   (ref nil) (ref nil) (ref nil) ;; node states
   (ref nil)))                   ;; last event

;;
;; Scene
;;

(defrecord Scene [view
                  event-dispatcher
                  component
                  rendering-hints
                  next-state])

;; Define rendering hints that affect font metrics to make sure that
;; Graphics and Scene FontRenderContexts are consistent.
(def ^:private default-rendering-hints
  {RenderingHints/KEY_TEXT_ANTIALIASING
   RenderingHints/VALUE_TEXT_ANTIALIAS_DEFAULT,
   RenderingHints/KEY_FRACTIONALMETRICS
   RenderingHints/VALUE_FRACTIONALMETRICS_DEFAULT})

(defn make-scene
  ([view]
     (make-scene view dummy-event-dispatcher nil))
  ([view event-dispatcher]
     (make-scene view event-dispatcher nil))
  ([view event-dispatcher ^Component component]
     (make-scene view event-dispatcher component nil))
  ([view event-dispatcher ^Component component hints]
     (let [hints (merge default-rendering-hints hints)]
       (->Scene view
                event-dispatcher
                component
                hints
                (atom nil)))))

(defn- get-and-set!
  "Atomically sets the value of atom to newval and returns the old
  value."
  [atom newval]
  (loop [v @atom]
    (if (compare-and-set! atom v newval)
      v
      (recur @atom))))

(defn draw-scene!
  [scene ^Graphics2D graphics width height]
  (.addRenderingHints graphics (:rendering-hints scene))
  (binding [*states* (get-and-set! (:next-state scene) nil)
            *scene* scene
            *graphics* graphics
            *initial-transform* (.getTransform graphics)
            *inverse-initial-transform* (-> graphics
                                            .getTransform
                                            .createInverse)
            *event-dispatcher* (:event-dispatcher scene)
            *width* width
            *height* height
            *clip* (Rectangle2D$Double. 0.0 0.0 width height)
            *input-clip* nil
            *time* (System/nanoTime)]
    (apply-theme)
    (let [tmp-watcher (Object.)]
      ;; Keep current context observers until the rendering is
      ;; complete. Some observers may be invoked twice if they
      ;; appear in both groups until tmp-watcher is removed.
      (replace-observers-watcher scene tmp-watcher)
      (try
        (render! (:view scene))
        (finally
         (remove-observers tmp-watcher)
         (commit (:event-dispatcher scene)))))))

(defn- scene-font-context [scene]
  (let [hints (:rendering-hints scene)
        ^Component c (:component scene)
        t (if c (->> c
                     .getFont
                     (.getFontMetrics c)
                     .getFontRenderContext
                     .getTransform))]
    (FontRenderContext.
     t
     (get hints RenderingHints/KEY_TEXT_ANTIALIASING)
     (get hints RenderingHints/KEY_FRACTIONALMETRICS))))      

(defn scene-geometry [scene]
  (binding [*scene* scene
            *font-context* (scene-font-context scene)]
    (geometry (:view scene))))

(defn set-cursor! [^Cursor cursor]
  (when-let [^Component component (:component *scene*)]
    (EventQueue/invokeLater #(.setCursor component cursor))))