;;
;; Copyright (C) 2010 Mikhail Kryshen <mikhail@kryshen.net>
;;
;; This file is part of Indyvon.
;;

(ns indyvon.core
  (:import (java.awt Graphics Component Color Font)
           (java.awt.event MouseListener MouseMotionListener)))

(defprotocol Layer
  "Basic UI element."
  (render! [this context graphics])
  (size [this context]))

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

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

(defprotocol EventDispatcher
  (listen! [this ^Component component]
     "Listen for events on the specified AWT Component.")
  (create-dispatcher [this context 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."))

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

;; Default implementation of Anchored for any Layer.
(extend-protocol Anchored
  indyvon.core.Layer
  (anchor [this context h-align v-align]
          (if (and (= h-align :left)
                   (= v-align :top))
            (Location. 0 0)
            (let [size (size this context)]
              (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)))))))

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

(defn default-theme []
  (Theme. Color/BLACK Color/WHITE Color/BLUE (Font. "Sans" Font/PLAIN 12)))
  
(defrecord LayerContext [x y width height update-fn font-context
                         theme target event-dispatcher])

(defn default-context []
  (LayerContext. 0 0 0 0 nil nil (default-theme) nil nil))

(defn update [context]
  ((:update-fn context)))

(defn- ^Graphics make-graphics [^Graphics graphics x y w h clip]
  (if clip
    (.create graphics x y w h)
    (doto (.create graphics)
      (.translate x y))))

(defn- ^Graphics apply-theme [^Graphics graphics theme]
  (doto graphics
    (.setColor (:fore-color theme))
    (.setFont (:font theme))))

(defn draw!
  "Render layer in a new graphics context."
  ([layer context graphics]
     (render! layer context graphics))
  ([layer context graphics x y]
     (draw! layer context graphics x y true))
  ([layer context graphics x y clip]
     (let [s (size layer context)]
       (draw! layer context graphics
              x y (:width s) (:height s) clip)))
  ([layer context graphics x y w h]
     (draw! layer context graphics
            x y w h true))
  ([layer context graphics x y w h clip]
     (let [context (assoc context
                     :layer layer
                     :parent context
                     :x (+ (:x context) x)
                     :y (+ (:y context) y)
                     :width w
                     :height h)
           graphics (make-graphics graphics x y w h clip)
           graphics (apply-theme graphics (:theme context))]
       (try
         (render! layer context graphics)
         (finally
          (.dispose graphics))))))

(defn add-handlers [context handle handlers]
  "Returns new context with the specified event handlers."
  (assoc context
    :event-dispatcher
    (create-dispatcher (:event-dispatcher context) context
                       handle handlers)))

(defmacro let-handlers [handle bindings & specs]
  "bindings => [binding-form context] or [context-symbol]
   specs => (:event-id name & handler-body)* form

  Execute form with the specified event handlers."
  (let [[binding context] bindings
        context (or context binding)]
    `(let [context# ~context
           ~binding
           (add-handlers context# ~handle
             ~(reduce (fn [m spec]
                        (assoc m (first spec)
                               `(fn [~(second spec)]
                                  ~@(nnext spec)))) {}
                                  (butlast specs)))]
           ~(last specs))))

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

(defrecord DispatcherNode [handle handlers parent x y width height]
  EventDispatcher
  (listen! [this component]
     (listen! parent component))
  (create-dispatcher [this context handle handlers]
     (create-dispatcher parent context handle handlers))
  (commit [this]
     (commit parent)))

(defn- make-node [c handle handlers]
  (DispatcherNode. handle handlers (:event-dispatcher c)
                   (:x c) (:y c) (:width c) (:height c)))

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

(defn- add-node [tree node]
  (assoc-cons tree (:parent node) node))

(defn- inside?
  ([x y node]
     (inside? x y (:x node) (:y node)
              (:width node) (:height node)))
  ([px py x y w h]
     (and (>= px x)
          (>= py y)
          (< px (+ x w))
          (< py (+ y h)))))

(defn- under-cursor
  "Returns a sequence of child nodes under cursor."
  [x y tree node]
  (some #(if (inside? x y %)
           (conj (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 x y id]
  (MouseEvent. id (.getWhen event)
               (- (.getX event) x) (- (.getY event) y)
               (.getXOnScreen event) (.getYOnScreen event)
               (.getButton event)))

(defn- translate-and-dispatch
  ([nodes ^java.awt.event.MouseEvent event]
     (translate-and-dispatch nodes event (awt-events (.getID event))))
  ([nodes event id]
     (doseq [node nodes]
       (when-let [handler (get (:handlers node) id)]
         (handler
          (translate-mouse-event event (:x node) (:y node) id))))
     id))

(defn- dispatch-mouse-motion*
  "Dispatches mouse motion events. Returns a new set of nodes which
  currently are under cursor."
  [hovered tree root ^java.awt.event.MouseEvent event]
  (let [x (.getX event)
        y (.getY event)
        hovered2 (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 event :mouse-exited)
    (translate-and-dispatch entered event :mouse-entered)
    (translate-and-dispatch moved event :mouse-moved)
    hovered2))

(defn- dispatch-mouse-motion
  [hovered-ref tree root event]
  (dosync
   (alter hovered-ref dispatch-mouse-motion* tree root event)))

(defn- dispatch-mouse-button*
  "Dispatches mouse button events. Returns a new set of nodes which
  currently are picked with a pressed button."
  [picked hovered event]
  (if (= (translate-and-dispatch hovered event) :mouse-pressed)
    hovered
    nil))

(defn- dispatch-mouse-button
  [picked-ref hovered-ref event]
  (dosync
   (alter picked-ref dispatch-mouse-button* @hovered-ref event)))

(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 context handle handlers]
        (let [node (make-node context handle handlers)]
          (dosync (alter tree-r add-node node))
          node))
     (commit [this]
        (dosync (ref-set tree @tree-r)
                (ref-set tree-r {})))
     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 event))
     (mouseMoved [this event]
        (dispatch-mouse-motion hovered @tree this event)))))

;;
;; ИДЕИ:
;;
;; Контекст: биндинги или запись?
;;
;; Установка обработчиков (в контексте слоя):
;;
;; (listen
;;   (:mouse-entered e
;;     ...)
;;   (:mouse-exited e
;;     ...))
;;
;; Не надо IMGUI.
;; Построение сцены путем декорирования слоев:
;;
;; (listener
;;  (:action e (println e))
;;  (:mouse-dragged e (println e))
;;  (theme :font "Helvetica-14"
;;    (vbox
;;      (button (text-layer "Button 1"))
;;      (button (text-layer "Button 2")))))
;;