changeset 30:a8821f4b5ade

Event dispatcher creates new context.
author Mikhail Kryshen <mikhail@kryshen.net>
date Wed, 07 Jul 2010 03:10:22 +0400
parents 4cb70c5a6e0d
children 8ac3a21955db
files src/indyvon/core.clj
diffstat 1 files changed, 49 insertions(+), 53 deletions(-) [+]
line diff
     1.1 --- a/src/indyvon/core.clj	Tue Jul 06 06:05:28 2010 +0400
     1.2 +++ b/src/indyvon/core.clj	Wed Jul 07 03:10:22 2010 +0400
     1.3 @@ -20,9 +20,14 @@
     1.4  (defrecord MouseEvent [id when x y x-on-screen y-on-screen button])
     1.5  
     1.6  (defprotocol EventDispatcher
     1.7 -  (listen! [this component])
     1.8 -  (register [this context handlers])
     1.9 -  (commit [this]))
    1.10 +  (listen! [this component]
    1.11 +           "Listen for events on the specified AWT Component.")
    1.12 +  (register [this context handle handlers]
    1.13 +            "Returns new context associated with the specified event
    1.14 +            handlers (an event-id -> handler-fn map). Handle is used
    1.15 +            to match the contexts between commits.")
    1.16 +  (commit [this]
    1.17 +          "Apply the registered handlers for event processing."))
    1.18  
    1.19  (defprotocol Anchored
    1.20    "Provide anchor point for Layers. Used by viewport."
    1.21 @@ -53,11 +58,11 @@
    1.22  (defn default-theme []
    1.23    (Theme. Color/BLACK Color/WHITE Color/BLUE (Font. "Sans" Font/PLAIN 12)))
    1.24    
    1.25 -(defrecord LayerContext [layer parent x y width height update-fn
    1.26 -  dispatcher font-context theme target])
    1.27 +(defrecord LayerContext [x y width height update-fn font-context
    1.28 +                         theme target dispatcher node])
    1.29  
    1.30  (defn default-context []
    1.31 -  (LayerContext. nil nil 0 0 0 0 nil nil nil (default-theme) nil))
    1.32 +  (LayerContext. 0 0 0 0 nil nil (default-theme) nil nil nil))
    1.33  
    1.34  (defn update [context]
    1.35    ((:update-fn context)))
    1.36 @@ -102,18 +107,22 @@
    1.37           (finally
    1.38            (.dispose graphics))))))
    1.39  
    1.40 -(defn listen* [context & handlers]
    1.41 -  (register (:dispatcher context) context (apply array-map handlers)))
    1.42 +(defmacro handlers [handle bindings & specs]
    1.43 +  "bindings => binding-form context
    1.44 +   specs => (:event-id name & handler-body)* form
    1.45  
    1.46 -;; (listen context
    1.47 -;;   (:mouse-entered e (println e))
    1.48 -;;   (:mouse-exited e (println e)))
    1.49 -(defmacro listen [context & specs]
    1.50 -  `(register (:dispatcher ~context) ~context
    1.51 -             ~(reduce #(assoc %1
    1.52 -                         (first %2)
    1.53 -                         `(fn [~(second %2)] ~@(nnext %2)))
    1.54 -                      {} specs)))
    1.55 +  Execute form with the specified event handlers."
    1.56 +  (let [[binding context] bindings
    1.57 +        context (or context binding)]
    1.58 +    `(let [context# ~context
    1.59 +           ~binding
    1.60 +           (register (:dispatcher context#) context# handle
    1.61 +                     ~(reduce (fn [m spec]
    1.62 +                                (assoc m (first spec)
    1.63 +                                       `(fn [~(second spec)]
    1.64 +                                          ~@(nnext spec)))) {}
    1.65 +                                          (butlast specs)))]
    1.66 +       ~(last specs))))
    1.67  
    1.68  ;;
    1.69  ;; EventDispatcher implementation
    1.70 @@ -128,33 +137,17 @@
    1.71        java.awt.event.MouseEvent/MOUSE_PRESSED  :mouse-pressed
    1.72        java.awt.event.MouseEvent/MOUSE_RELEASED :mouse-released})
    1.73  
    1.74 -(defrecord DispatcherNode [layer x y width height handlers children])
    1.75 +(defrecord DispatcherNode [handle handlers parent x y width height])
    1.76  
    1.77 -(defrecord DispatcherRootNode [children])
    1.78 +(defn- make-node [c handle handlers]
    1.79 +  (DispatcherNode. handle handlers (:node c)
    1.80 +                   (:x c) (:y c) (:width c) (:height c)))
    1.81  
    1.82 -(defn- make-node [c handlers]
    1.83 -  (DispatcherNode. (:layer c) (:x c) (:y c) (:width c) (:height c)
    1.84 -                   handlers nil))
    1.85 +(defn- assoc-cons [m key val]
    1.86 +  (assoc m key (cons val (get m key))))
    1.87  
    1.88 -(defn- add-child [node child]
    1.89 -  (assoc node :children (cons child (:children node))))
    1.90 -
    1.91 -(defn- registered-parent
    1.92 -  "Returns first context parent registered for event processing."
    1.93 -  [tree context]
    1.94 -  (let [parent (:parent context)]
    1.95 -    (cond
    1.96 -     (nil? parent) nil
    1.97 -     (contains? tree parent) parent
    1.98 -     :default (recur tree parent))))
    1.99 -
   1.100 -(defn- add-context
   1.101 -  [tree context handlers]
   1.102 -  (let [parent (registered-parent tree context)
   1.103 -        node (make-node context handlers)]
   1.104 -    (assoc tree
   1.105 -      parent (add-child (tree parent) node)
   1.106 -      context node)))
   1.107 +(defn- add-node [tree node]
   1.108 +  (assoc-cons tree (:parent node) node))
   1.109  
   1.110  (defn- inside?
   1.111    ([x y node]
   1.112 @@ -168,10 +161,12 @@
   1.113  
   1.114  (defn- under-cursor
   1.115    "Returns a sequence of child nodes under cursor."
   1.116 -  [x y node]
   1.117 -  (some #(if (inside? x y %)
   1.118 -           (conj (under-cursor x y %) %))
   1.119 -        (:children node)))
   1.120 +  ([x y tree]
   1.121 +     (under-cursor x y tree nil))
   1.122 +  ([x y tree node]
   1.123 +     (some #(if (inside? x y %)
   1.124 +              (conj (under-cursor x y %) %))
   1.125 +           (get tree node))))
   1.126  
   1.127  (defn- remove-all [coll1 coll2 pred]
   1.128    (filter #(not (some (partial pred %) coll2)) coll1))
   1.129 @@ -199,8 +194,8 @@
   1.130    [hovered tree event]
   1.131    (let [x (.getX event)
   1.132          y (.getY event)
   1.133 -        hovered2 (under-cursor x y (get tree nil))
   1.134 -        pred #(= (:layer %1) (:layer %2))
   1.135 +        hovered2 (under-cursor x y tree)
   1.136 +        pred #(= (:handle %1) (:handle %2))
   1.137          exited (remove-all hovered hovered2 pred)
   1.138          entered (remove-all hovered2 hovered pred)
   1.139          moved (remove-all hovered2 entered pred)]
   1.140 @@ -228,9 +223,8 @@
   1.141     (alter picked-ref dispatch-mouse-button* @hovered-ref event)))
   1.142  
   1.143  (defn make-event-dispatcher []
   1.144 -  (let [tree-i {nil (DispatcherRootNode. nil)} ; initial
   1.145 -        tree-r (ref tree-i)                    ; register
   1.146 -        tree (ref tree-i)                      ; dispatch
   1.147 +  (let [tree-r (ref {})   ; register
   1.148 +        tree (ref {})     ; dispatch
   1.149          hovered (ref '())
   1.150          picked (ref '())]
   1.151      (reify
   1.152 @@ -239,11 +233,13 @@
   1.153          (doto component
   1.154            (.addMouseListener this)
   1.155            (.addMouseMotionListener this)))
   1.156 -     (register [this context handlers]
   1.157 -        (dosync (alter tree-r add-context context handlers)))
   1.158 +     (register [this context handle handlers]
   1.159 +        (let [node (make-node context handle handlers)]
   1.160 +          (dosync (alter tree-r add-node node))
   1.161 +          (assoc context :node node)))
   1.162       (commit [this]
   1.163          (dosync (ref-set tree @tree-r)
   1.164 -                (ref-set tree-r tree-i)))
   1.165 +                (ref-set tree-r {})))
   1.166       MouseListener
   1.167       (mouseEntered [this event]
   1.168          (dispatch-mouse-motion hovered @tree event))