;;
;; Copyright 2010 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)
   (java.awt.geom AffineTransform Point2D$Double Rectangle2D$Double Area)
   (java.awt.event MouseListener MouseMotionListener)
   (java.awt.font FontRenderContext)))

;;
;; Layer context
;;

(def ^Graphics2D *graphics*)

(def ^FontRenderContext *font-context*)

(def ^{:tag Component
       :doc "Target AWT component, may be nil if drawing off-screen."}
     *target*)

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

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

(def ^Shape *clip*)

(def ^{:doc "The root (background) layer of the scene."}
     *root*)

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

(def *event-dispatcher*)

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

(def ^{: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 font])

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

(def *theme* (default-theme))

(defrecord Location [x y])
(defrecord Size [width height])
(defrecord Bounds [x y width height])

;;
;; Core protocols and types
;;

(defprotocol Layer
  "Basic UI element."
  (render! [this])
  (layer-size [this]))

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

;; TODO: KeyEvent

(defprotocol EventDispatcher
  (listen! [this ^Component 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."))

(defprotocol Anchored
  "Provide anchor point for Layers. Used by viewport."
  (anchor [this h-align v-align]
     "Anchor point: [x y], h-align could be :left, :center or :right,
      v-align is :top, :center or :bottom"))

(defn default-anchor [layer h-align v-align]
  (if (and (= h-align :left)
           (= v-align :top))
    (Location. 0 0)
    (let [size (layer-size layer)]
      (Location.
       (case h-align
             :top 0
             :center (/ (:width size) 2)
             :right (:width size))
       (case v-align
             :left 0
             :center (/ (:height size) 2)
             :bottom (:height size))))))

;; Default implementation of Anchored for any Layer.
(extend-protocol Anchored
  net.kryshen.indyvon.core.Layer
  (anchor [this h-align v-align]
    (default-anchor this h-align v-align)))

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

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

;;
;; Observers
;;

(def observers (atom nil))

;; TODO: groups should be weakly referenced.
(defn add-observer
  "Add observer fn for the target to the specified group."
  [group target f]
  (swap! observers assoc-in-cons [group target] f)
  nil)

(defn remove-observer-group
  "Remove group of observers."
  [group]
  (swap! observers dissoc group)
  nil)

(defn- replace-observer-group*
  [observers old-id new-id]
  (let [group (get observers old-id)]
    (assoc (dissoc observers old-id)
      new-id group)))

(defn- replace-observer-group
  [old-id new-id]
  (swap! observers replace-observer-group* old-id new-id))

(defn update
  "Notify observers."
  [target & args]
  (doseq [f (reduce #(concat %1 (get %2 target)) nil (vals @observers))]
    (apply f target args)))

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

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

(defn repaint
  "Repaint the current scene."
  []
  (update *root*))

;;
;; Rendering
;;

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

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

(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))))

(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
  ([]
     (create-graphics 0 0 *width* *height*))
  ([x y w h]
     (apply-theme (.create *graphics* x y w h) *theme*)))

(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#))))))

;; 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)))

(defn draw!
  "Draws layer."
  ([layer]
     (let [graphics (create-graphics)]
       (try
         (binding [*graphics* graphics]
           (render! layer))
         (finally
          (.dispose graphics)))))
  ([layer x y]
     (let [size (layer-size layer)]
       (draw! layer x y (:width size) (:height size))))
  ([layer x y width height]
     (with-bounds* x y width height render! layer)))

(defn draw-anchored!
  "Draws layer. Location is relative to the layer's anchor point for
   the specified alignment."
  ([layer h-align v-align x y]
     (let [anchor (anchor layer h-align v-align)]
       (draw! layer (- x (:x anchor)) (- y (:y anchor)))))
  ([layer h-align v-align x y w h]
     (let [anchor (anchor layer h-align v-align)]
       (draw! layer (- x (:x anchor)) (- y (:y anchor)) w h))))

(defn draw-root!
  "Draws the root layer."
  ([layer graphics width height event-dispatcher]
     (draw-root! layer graphics width height event-dispatcher nil))
  ([layer ^Graphics2D graphics width height event-dispatcher target]
     (binding [*root* layer
               *target* target
               *graphics* graphics
               *font-context* (.getFontRenderContext graphics)
               *initial-transform* (.getTransform graphics)
               *inverse-initial-transform*
                 (-> graphics .getTransform .createInverse)
               *event-dispatcher* event-dispatcher
               *width* width
               *height* height
               *clip* (Rectangle2D$Double. 0 0 width height)
               *time* (System/nanoTime)]
       ;; (.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)
       (apply-theme)
       (with-color (:back-color *theme*)
         (.fillRect graphics 0 0 width height))
       (let [tmp-group (Object.)]
         ;; Keep current context observers until the rendering is complete.
         ;; Some observers may be invoked twice if they appear in both
         ;; groups until tmp-group is removed.
         (replace-observer-group layer tmp-group)
         (try
           (render! layer)
           (finally
            (remove-observer-group tmp-group)
            (commit event-dispatcher)))))))

(defn root-size
  ([layer font-context]
     (root-size layer font-context nil))
  ([layer font-context target]
     (binding [*root* layer
               *target* target
               *font-context* font-context]
       (layer-size layer))))

;;
;; 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})

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

(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- 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- transform [^AffineTransform tr x y]
  (let [p (Point2D$Double. x y)]
    (.transform tr p p)
    [(.x p) (.y p)]))

(defn- translate-mouse-event [^java.awt.event.MouseEvent event
                              ^AffineTransform tr id]
  (let [[x y] (transform tr (.getX event) (.getY event))]
    (MouseEvent. id (.getWhen event) x y
                 (.getXOnScreen event) (.getYOnScreen event)
                 (.getButton 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 [node (first nodes)]
       (if-let [handler (get (:handlers node) id)]
         (do
           (with-bindings* (:bindings node)
             handler
             (translate-mouse-event event (:transform node) id))
           (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
         (.addMouseListener this)
         (.addMouseMotionListener this)))
     (create-dispatcher [this handle handlers]
       (let [node (make-node handle handlers)]
         (dosync (alter tree-r add-node node))
         node))
     (commit [this]
       (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))
     MouseMotionListener
     (mouseDragged [this event]
       (translate-and-dispatch @picked true event))
     (mouseMoved [this event]
       (dispatch-mouse-motion hovered @tree this event)))))