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

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

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

(def *graphics*)
(def *font-context*)
(def *bounds*)
(def *target*)
(def *update*)
(def *event-dispatcher*)
(def *path*)

(defrecord Theme [fore-color back-color border-color font])
     
(defn- default-theme []
  (Theme. Color/BLACK Color/WHITE Color/BLUE (Font. "Sans" Font/PLAIN 12)))

(def *theme* (default-theme))

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

(defn layer? [x]
  (satisfies? Layer x)) 

(defprotocol EventDispatcher
  (listen! [this component])
  (register [this handle-path])
  (handler [this handle-path event-id f])
  (commit [this]))

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

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

(defn with-translate* [x y w h f & args]
  (let [graphics (apply-theme (.create *graphics* x y w h))]
    (try
      (apply with-bindings* {#'*bounds* (Bounds. (+ x (:x *bounds*))
                                                 (+ y (:y *bounds*))
                                                 w h)
                             #'*graphics* graphics}
             f args)
      (finally
       (.dispose graphics)))))

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

(defn with-handle* [handle f & args]
  (let [path (cons handle *path*)]
    (register *event-dispatcher* path)
    (apply with-bindings* {#'*path* path} f args)))

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

(defn handle-event* [event-id f & args]
  (let [f (if args #(f % args) f)]
    (handler *event-dispatcher* *path* event-id f)))

(defmacro handle-event [event-id name & body]
  `(handle-event* ~event-id (fn [~name] ~@body)))

(defn- geometry-vec [geometry]
  (if (vector? geometry)
    geometry
    [(:x geometry) (:y geometry) (:width geometry) (:height geometry)]))

(defn draw! [layer geometry & args]
  "Draw a layer. Geometry is either a map or vector [x y] or
   [x y width height]."
  (let [[x y w h] (geometry-vec geometry)
        size (if-not (and w h) (size layer args))
        w (or w (:width size))
        h (or h (:height size))]
    (with-translate* x y w h render! layer args)))

;;
;; EventDispatcher
;;

(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 [id bounds children handlers])

(defn- add-child [node child]
  (assoc node :children (cons child (:children node))))

(defn- add-path [tree path]
  (let [parent-path (next path)
        parent-node (get tree parent-path)
        node (DispatcherNode. path *bounds* nil
                              (get-in tree [path :handlers]))]
    (assoc tree
      parent-path (add-child parent-node node)
      path node)))

(defn add-handler [tree path event-id f]
  (let [keys [path :handlers event-id]]
  (assoc-in tree keys (cons f (get-in tree keys)))))

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

(defn- under-cursor
  "Returns a sequence of nodes under cursor."
  ([tree x y]
     (under-cursor tree x y nil))
  ([tree x y node]
     (some #(if (inside? x y (:bounds %))
              (conj (under-cursor tree x y %) %))
           (get tree (:children node)))))

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

(defn- translate-mouse-event
  [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 event]
     (translate-and-dispatch nodes event (awt-events (.getID event))))
  ([nodes event id]
     (doseq [node nodes
             :let [bounds (:bounds node)
                   event (translate-mouse-event event
                           (:x bounds) (:y bounds) id)]
             handler (get (:handlers node) id)]
       ;; TODO restore more of the original context.
       (with-bindings* {#'*bounds* bounds} handler event))
     id))

(defn- dispatch-mouse-motion*
  "Dispatches mouse motion events. Returns a new set of nodes which
  currently are under cursor."
  [hovered tree event]
  (let [x (.getX event)
        y (.getY event)
        hovered2 (under-cursor tree x y)
        pred #(= (:id %1) (:id %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 event]
  (dosync
   (alter hovered-ref dispatch-mouse-motion* tree 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 make-event-dispatcher []
  (let [root-node (DispatcherNode. nil nil nil nil)
        tree-i {nil root-node} ; initial
        tree-r (ref tree-i)    ; register
        tree (ref tree-i)      ; dispatch
        hovered (ref '())
        picked (ref '())]
    (reify
     EventDispatcher
     (listen! [this component]
        (doto component
          (.addMouseListener this)
          (.addMouseMotionListener this)))
     (register [this path]
        (dosync (alter tree-r add-path path)))
     (handler [this path event-id f]
        (dosync (alter tree-r add-handler path event-id f)))
     (commit [this]
        (dosync (ref-set tree @tree-r)
                (ref-set tree-r tree-i)))
     MouseListener
     (mouseEntered [this event]
        (dispatch-mouse-motion hovered @tree event))
     (mouseExited [this event]
        (dispatch-mouse-motion hovered @tree 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 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")))))
;;