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

(ns indyvon.event
  (:use indyvon.core)
  (:import (java.awt.event MouseEvent MouseListener MouseMotionListener)
           java.lang.ref.WeakReference))

;; map event-id -> [layer-weak-ref1 fn1, layer-weak-ref2 fn2...]
(def listeners-map (ref {}))

(defn- assoc-conj [map key & vals]
  (assoc map key (apply conj (vec (get map key)) vals)))

(defn add-listener
  "The supplied function will be invoked with context, event and
  additional args when an event with the specified id occurs on the
  specified layer."
  [layer event-id f & args]
  (let [f (if args #(apply f %1 %2 args) f)]
    (dosync
     (alter listeners-map assoc-conj event-id (WeakReference. layer) f))
    nil))

(defn- listeners
  "Returns list of listener fns for event and target-layer. Listeners
  for garbage-collected layers are removed."
  [event-id target-layer]
  (dosync
   (loop [ref-vec (@listeners-map event-id) cleared-ref-vec [] listeners []]
     (if-let [layer-ref (first ref-vec)]
       (if-let [layer (.get layer-ref)]
         (let [lfn (second ref-vec)]
           (recur (nnext ref-vec)
                  (conj cleared-ref-vec layer-ref lfn)
                  (if (= layer target-layer)
                    (conj listeners lfn)
                    listeners)))
         (recur (nnext ref-vec) cleared-ref-vec listeners))
       (do
         (alter listeners-map assoc event-id cleared-ref-vec)
         listeners)))))

(defn dispatch-event [context event]
  (doseq [listener (listeners (.getID event) (:layer context))]
    (listener context event)))

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

(defn register-context [context]
  (register (:dispatcher context) context))

(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 (conj (context-tree parent) context)
           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-and-dispatch
  ([contexts event]
     (translate-and-dispatch contexts event (.getID event)))
  ([contexts event id]
  (doseq [context contexts]
    (dispatch-event
     context
     (translate-mouse-event event (:x context) (:y context) 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 MouseEvent/MOUSE_EXITED)
    (translate-and-dispatch entered event MouseEvent/MOUSE_ENTERED)
    (translate-and-dispatch moved event MouseEvent/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 context-tree event]
  (translate-and-dispatch hovered event)
  (if (= (.getID event) MouseEvent/MOUSE_PRESSED)
    hovered
    nil))
  
(defn- dispatch-mouse-button
  [picked-ref hovered-ref context-tree event]
  (dosync
   (alter picked-ref dispatch-mouse-button*
          @hovered-ref context-tree 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]
        (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 context-tree event))
     (mousePressed [this event]
        (dispatch-mouse-button picked hovered context-tree event))
     (mouseReleased [this event]
        (dispatch-mouse-button picked hovered context-tree event))
     MouseMotionListener
     (mouseDragged [this event]
        (translate-and-dispatch @picked event))
     (mouseMoved [this event]
        (dispatch-mouse-motion hovered context-tree event)))))