Mercurial > hg > indyvon
view src/indyvon/event.clj @ 12:cd8a378414d1
Support mouse button events.
author | Mikhail Kryshen <mikhail@kryshen.net> |
---|---|
date | Mon, 14 Jun 2010 05:04:03 +0400 |
parents | 9af27ccccfac |
children | 0a2fafca72d8 |
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))) (defmulti handle-layer-event (fn [layer context event] [layer (.getID event)])) (defmethod handle-layer-event :default [layer 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 [c contexts] (handle-layer-event (:layer c) c (translate-mouse-event event (:x c) (:y c) 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)))))