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

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

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

(defprotocol MouseHandler
  "Layers that also satisfy this protocol will recieve mouse events."
  (handle-mouse [this context event]))

(defprotocol EventDispatcher
  (listen! [this component])
  (register [this context])
  (commit [this])
  (hovered? [this layer])
  (picked? [this layer]))

(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))
            [0 0]
            (let [size (size this context)]
              [(case h-align
                 :top 0
                 :center (/ (size 0) 2)
                 :right (size 0))
               (case v-align
                 :left 0
                 :center (/ (size 1) 2)
                 :bottom (size 1))]))))

(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 [layer parent x y width height update-fn
  dispatcher font-context theme target])

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

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

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

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

(defn draw!
  "Render layer in a new graphics context."
  ([layer context graphics]
     (draw! layer context graphics
                    0 0 (:width context) (:height context)))
  ([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 (s 0) (s 1) 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
         (register (:dispatcher context) context)
         (render! layer context graphics)
         (finally
          (.dispose graphics))))))

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

(defn- registered-parent
  "Returns first context parent registered for event processing."
  [context-tree context]
  (let [parent (:parent context)]
    (cond
     (nil? parent) nil
     (contains? context-tree parent) parent
     :default (recur context-tree parent))))

(defn- add-context
  [context-tree context]
  (let [parent (registered-parent context-tree context)]
    (assoc context-tree parent (cons context (context-tree parent))
           context nil)))

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

(defn- under-cursor
  "Returns a sequence of contexts under cursor."
  ([context-tree x y]
     (under-cursor context-tree x y nil))
  ([context-tree x y context]
     (some #(if (inside? x y %)
              (conj (under-cursor context-tree x y %) %))
           (context-tree context))))

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

;; (defn- translate-mouse-event
;;   [event x y id]
;;   (proxy [MouseEvent] [(.getComponent event)
;;                        id
;;                        (.getWhen event)
;;                        (.getModifiers event)
;;                        (- (.getX event) x)
;;                        (- (.getY event) y)
;;                        (.getClickCount event)
;;                        (.isPopupTrigger event)]
;;     (getXOnScreen [] (.getXOnScreen event))
;;     (getYOnScreen [] (.getYOnScreen event))))

(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
  ([contexts event]
     (translate-and-dispatch contexts event (awt-events (.getID event))))
  ([contexts event id]
     (doseq [context contexts]
       (handle-mouse
        (:layer context) context 
        (translate-mouse-event event (:x context) (:y context) id)))
     id))

(defn- dispatch-mouse-motion*
  "Dispatches mouse motion events. Returns a new set of contexts which
  currently are under cursor."
  [hovered context-tree event]
  (let [x (.getX event)
        y (.getY event)
        hovered2 (under-cursor context-tree x y)
        pred #(= (:layer %1) (:layer %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 context-tree event]
  (dosync
   (alter hovered-ref dispatch-mouse-motion* context-tree event)))

(defn- dispatch-mouse-button*
  "Dispatches mouse button events. Returns a new set of contexts 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 [context-tree-r (ref {}) ; register
        context-tree (ref {})   ; dispatch
        hovered (ref '())
        picked (ref '())]
    (reify
     EventDispatcher
     (listen! [this component]
        (doto component
          (.addMouseListener this)
          (.addMouseMotionListener this)))
     (register [this context]
        (when (satisfies? MouseHandler (:layer context))
          (dosync (alter context-tree-r add-context context))))
     (commit [this]
        (dosync (ref-set context-tree @context-tree-r)
                (ref-set context-tree-r {})))
     (picked? [this layer] false)
     (hovered? [this layer] false)
     MouseListener
     (mouseEntered [this event]
        (dispatch-mouse-motion hovered @context-tree event))
     (mouseExited [this event]
        (dispatch-mouse-motion hovered @context-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 @context-tree event)))))