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

(ns net.kryshen.indyvon.core
  (:import
   (java.awt Graphics2D RenderingHints Component Color Font Shape
             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))

;;
;; Layer context
;;

(def ^{:dynamic true
       :tag Graphics2D}
  *graphics*)

(def ^{:dynamic true
       :tag FontRenderContext}
  *font-context*)

(def ^{:dynamic true
       :doc "Width of the rendering area."}
  *width*)

(def ^{:dynamic true
       :doc "Height of the rendering area."}
  *height*)

(def ^{:dynamic true
       :tag Shape}
  *clip*)

(def ^{:dynamic true
       :doc "Time in nanoseconds when the rendering of the current
             frame starts."}
  *time*)

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

(def ^{:dynamic true}
  *event-dispatcher*)

(def ^{:dynamic true
       :tag AffineTransform
       :doc "Initial transform associated with the graphics context."}
  *initial-transform*)

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

(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. 0xC8 0xD2 0xD8)
          (Color. 0 0 0xC8)
          (Color. 0x44 0x44 0x44)
          (Font. "Sans" Font/PLAIN 12)))

(def ^{:dynamic true} *theme* (default-theme))

;;
;; Core protocols and types
;;

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

(defprotocol Geometry
  "Describes geometry of a Layer. 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."))

(defrecord Size [width height]
  Geometry
  (width  [_] width)
  (width [_ _] width)
  (height [_] height)
  (height [_ _] height)
  (anchor-x [_ h-align width]
    (case h-align
      :left 0
      :center (/ width 2)
      :right width))
  (anchor-y [_ v-align height]
    (case v-align
      :top 0
      :center (/ height 2)
      :bottom 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)))))

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

;; 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 layers 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
  "Repaint the current scene."
  []
  (update *scene*))

;;
;; Rendering
;;

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

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

(defn transform-point [^AffineTransform tr x y]
  (let [p (Point2D$Double. x y)]
    (.transform 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 bounds in current
   transform coordinates. Returns new clip in the AWT component
   coordinates (Shape or nil if empty)."
  [x y w h]
  (let [^Graphics2D clip-g (.create *graphics*)]
    (doto clip-g
      (.setClip x y w h)
      (.setTransform *initial-transform*)
      (.clip *clip*))
    (try
      (if (.isEmpty (.getClipBounds clip-g))
        nil
        (.getClip clip-g))
      (finally
       (.dispose clip-g)))))

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

(defn- ^Graphics2D create-graphics
  ([]
     (apply-theme (.create *graphics*) *theme*))
  ([x y w 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 (int x) (int y))
      (binding [*width* w
                *height* h
                *graphics* graphics]
        (apply f args))
      (finally
       (.dispose graphics)))))

(defn with-bounds*
  [x y w h f & args]
  (when-let [clip (clip x y w h)]
    (let [graphics (create-graphics x y w h)]
      (try
        (binding [*width* w
                  *height* h
                  *clip* clip
                  *graphics* graphics]
          (apply f args))
        (finally
         (.dispose graphics))))))

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

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

(defmacro with-color
  [color-or-keyword & body]
  (let [color-form (if (keyword? color-or-keyword)
                     `(~color-or-keyword *theme*)
                     color-or-keyword)]
    `(let [color# ~color-form
           old-color# (.getColor *graphics*)]
       (try
         (.setColor *graphics* color#)
         ~@body
         (finally
          (.setColor *graphics* old-color#))))))

(defn with-hints*
  [hints f & args]
  (if hints
    (let [g *graphics*
          old (.getRenderingHints g)]
      (try
        (.addRenderingHints g hints)
        (binding [*font-context* (.getFontRenderContext g)]
          (apply f args))
        (finally
         (.setRenderingHints g old))))
    (apply f args)))

(defmacro with-hints
  [hints & body]
  `(with-hints ~hints (fn [] ~@body)))

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

(defmacro with-transform [transform & body]
  `(let [old-t# (.getTransform *graphics*)]
     (try
       (.transform *graphics* ~transform)
       ~@body
       (finally
        (.setTransform *graphics* 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]
     (try
       (.translate *graphics* x# y#)
       ~@body
       (finally
        (.translate *graphics* (- x#) (- y#))))))

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

(defn draw-aligned!
  "Draws layer. Location is relative to the layer's anchor point for
   the specified alignment."
  ([layer h-align v-align x y]
     (let [geom (geometry layer)
           w (width geom)
           h (height geom)]
       (draw! layer
              (- x (anchor-x geom h-align w))
              (- y (anchor-y geom v-align h))
              w h)))
  ([layer h-align v-align x y w h]
     (let [geom (geometry layer)]
       (draw! layer
              (- 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? [_ _])))

(defrecord 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]
  (DispatcherNode. handle handlers *event-dispatcher* *clip*
                   (inverse-relative-transform)
                   (get-thread-bindings)))

(defn- add-node [tree 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."
  [x y tree node]
  (some #(if (.contains ^Shape (:clip %) x y)
           (conj (vec (under-cursor x y tree %)) %))
        (get tree node)))

(defn- remove-all [coll1 coll2 pred]
  (filter #(not (some (partial pred %) coll2)) coll1))

(defn- translate-mouse-event [^java.awt.event.MouseEvent event
                              ^AffineTransform tr id]
  (let [[x y] (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)))

(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 [node (first nodes)]
       (if-let [handler (get (:handlers node) id)]
         (do
           (let [translated (translate-mouse-event event (:transform node) id)]
             (with-bindings* (:bindings node)
               handler translated))
           (if-not first-only
             (recur (rest nodes) false event id)))
         (recur (rest nodes) first-only event id)))))

(defn- dispatch-mouse-motion
  "Dispatches mouse motion events."
  [hovered-ref tree root ^java.awt.event.MouseEvent event]
  (let [x (.getX event)
        y (.getY event)
        [hovered hovered2] (dosync
                            [@hovered-ref
                             (ref-set hovered-ref
                                      (under-cursor x y tree root))])
        pred #(= (:handle %1) (:handle %2))
        exited (remove-all hovered hovered2 pred)
        entered (remove-all hovered2 hovered pred)
        moved (remove-all hovered2 entered pred)]
    (translate-and-dispatch exited false event :mouse-exited)
    (translate-and-dispatch entered false event :mouse-entered)
    (translate-and-dispatch moved true event :mouse-moved)))

(defn- dispatch-mouse-button
  [picked-ref hovered-ref ^java.awt.event.MouseEvent event]
  (let [id (awt-events (.getID event))
        nodes (case id
               :mouse-pressed
               (dosync
                (ref-set picked-ref @hovered-ref))
               :mouse-released
               (dosync
                (let [picked @picked-ref]
                  (ref-set picked-ref nil)
                  picked))
               @hovered-ref)]
    (translate-and-dispatch nodes true event id)))

(defn root-event-dispatcher []
  (let [tree-r (ref {})   ; register
        tree (ref {})     ; dispatch
        hovered (ref '())
        picked (ref '())]
    (reify
     EventDispatcher
     (listen! [this component]
       (doto ^Component component
         (.addMouseListener this)
         (.addMouseWheelListener this)
         (.addMouseMotionListener this)))
     (create-dispatcher [this handle handlers]
       (let [node (make-node handle handlers)]
         (dosync (alter tree-r add-node node))
         node))
     (commit [this]
       ;; TODO: retain contexts that do not intersect graphics
       ;; clipping area in tree.
       (dosync (ref-set tree @tree-r)
               (ref-set tree-r {})))
     (handle-picked? [this handle]
       (some #(= handle (:handle %)) @picked))
     (handle-hovered? [this handle]
       (some #(= handle (:handle %)) @hovered))
     MouseListener
     (mouseEntered [this event]
       (dispatch-mouse-motion hovered @tree this event))
     (mouseExited [this event]
       (dispatch-mouse-motion hovered @tree this event))
     (mouseClicked [this event]
       (dispatch-mouse-button picked hovered event))
     (mousePressed [this event]
       (dispatch-mouse-button picked hovered event))
     (mouseReleased [this event]
       (dispatch-mouse-button picked hovered event))
     MouseWheelListener
     (mouseWheelMoved [this event]
       (dispatch-mouse-button picked hovered event))
     MouseMotionListener
     (mouseDragged [this event]
       (translate-and-dispatch @picked true event))
     (mouseMoved [this event]
       (dispatch-mouse-motion hovered @tree this event)))))

;;
;; Scene
;;

(defrecord Scene [layer event-dispatcher component])

(defn make-scene
  ([layer]
     (make-scene layer dummy-event-dispatcher nil))
  ([layer event-dispatcher]
     (make-scene layer event-dispatcher nil))
  ([layer event-dispatcher component]
     (->Scene layer event-dispatcher component)))

(defn draw-scene!
  [scene ^Graphics2D graphics width height]
  ;; (.setRenderingHint graphics
  ;;                    RenderingHints/KEY_INTERPOLATION
  ;;                    RenderingHints/VALUE_INTERPOLATION_BILINEAR)
  ;; (.setRenderingHint graphics
  ;;                    RenderingHints/KEY_ALPHA_INTERPOLATION
  ;;                    RenderingHints/VALUE_ALPHA_INTERPOLATION_QUALITY)
  ;; (.setRenderingHint graphics
  ;;                    RenderingHints/KEY_ANTIALIASING
  ;;                    RenderingHints/VALUE_ANTIALIAS_ON)
  ;; (.setRenderingHint graphics
  ;;                    RenderingHints/KEY_TEXT_ANTIALIASING
  ;;                    RenderingHints/VALUE_TEXT_ANTIALIAS_ON)
  (binding [*scene* scene
            *graphics* graphics
            *font-context* (.getFontRenderContext 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 width height)
            *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! (:layer scene))
        (finally
         (remove-observers tmp-watcher)
         (commit (:event-dispatcher scene)))))))
  
(defn scene-geometry [scene font-context]
  (binding [*scene* scene
            *font-context* font-context]
    (geometry (:layer scene))))

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