Mercurial > hg > indyvon
view src/indyvon/event.clj @ 21:a70609bad3a4
Simpler event dispatching.
author | Mikhail Kryshen <mikhail@kryshen.net> |
---|---|
date | Sat, 19 Jun 2010 04:27:29 +0400 |
parents | 43f0d78057a9 |
children | dc81033d4122 |
line wrap: on
line source
;; ;; 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)) (defprotocol EventDispatcher (listen! [this component]) (register-mouse-handler [this context handler]) (commit [this]) (hovered? [this layer]) (picked? [this layer])) (defn mouse-handler [context handler & args] "The supplied handler function will be invoked with context, event and additional args when mouse event occurs on the context." (let [handler (if args #(apply handler %1 %2 args) handler)] (register-mouse-handler (:dispatcher context) context handler))) (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- dispatch-event [handlers context event] ((handlers context) context event)) (defn- translate-and-dispatch ([contexts handlers event] (translate-and-dispatch contexts handlers event (.getID event))) ([contexts handlers event id] (doseq [context contexts] (dispatch-event handlers 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 handlers 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 handlers event MouseEvent/MOUSE_EXITED) (translate-and-dispatch entered handlers event MouseEvent/MOUSE_ENTERED) (translate-and-dispatch moved handlers event MouseEvent/MOUSE_MOVED) hovered2)) (defn- dispatch-mouse-motion [hovered-ref context-tree handlers event] (dosync (alter hovered-ref dispatch-mouse-motion* context-tree handlers 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 handlers event] (translate-and-dispatch hovered handlers event) (if (= (.getID event) MouseEvent/MOUSE_PRESSED) hovered nil)) (defn- dispatch-mouse-button [picked-ref hovered-ref handlers event] (dosync (alter picked-ref dispatch-mouse-button* @hovered-ref handlers event))) (defn make-event-dispatcher [] (let [context-tree-r (ref {}) ; register handlers-r (ref {}) ; context-tree (ref {}) ; dispatch handlers (ref {}) ; hovered (ref '()) picked (ref '())] (reify EventDispatcher (listen! [this component] (doto component (.addMouseListener this) (.addMouseMotionListener this))) (register-mouse-handler [this context handler] (dosync (alter context-tree-r add-context context) (alter handlers-r assoc context handler))) (commit [this] (dosync (ref-set context-tree @context-tree-r) (ref-set context-tree-r {}) (ref-set handlers @handlers-r) (ref-set handlers-r {}))) (picked? [this layer] false) (hovered? [this layer] false) MouseListener (mouseEntered [this event] (dispatch-mouse-motion hovered context-tree handlers event)) (mouseExited [this event] (dispatch-mouse-motion hovered context-tree handlers event)) (mouseClicked [this event] (dispatch-mouse-button picked hovered handlers event)) (mousePressed [this event] (dispatch-mouse-button picked hovered handlers event)) (mouseReleased [this event] (dispatch-mouse-button picked hovered handlers event)) MouseMotionListener (mouseDragged [this event] (translate-and-dispatch @picked handlers event)) (mouseMoved [this event] (dispatch-mouse-motion hovered context-tree handlers event)))))