Mercurial > hg > indyvon
changeset 6:5a858158cd9e
Tree structure for event dispatching.
author | Mikhail Kryshen <mikhail@kryshen.net> |
---|---|
date | Fri, 11 Jun 2010 04:31:27 +0400 |
parents | 74f1f265c3d9 |
children | f6d10a68b01d |
files | src/indyvon/core.clj |
diffstat | 1 files changed, 61 insertions(+), 34 deletions(-) [+] |
line diff
1.1 --- a/src/indyvon/core.clj Thu Jun 10 05:35:56 2010 +0400 1.2 +++ b/src/indyvon/core.clj Fri Jun 11 04:31:27 2010 +0400 1.3 @@ -4,10 +4,15 @@ 1.4 MouseListener MouseMotionListener))) 1.5 1.6 (defprotocol Layer 1.7 - (render! [this context]) 1.8 + (render! [this context graphics]) 1.9 (size [this context]) 1.10 (anchor [this context])) 1.11 1.12 +(defrecord LayerContext [layer parent rx ry width height update-fn dispatcher]) 1.13 + 1.14 +(defn default-context [] 1.15 + (LayerContext. nil nil 0 0 0 0 nil nil)) 1.16 + 1.17 (defmacro reify-layer [& fns] 1.18 (let [method-map {'size [['_ '_] [0 0]] 1.19 'anchor [['_ '_] [0 0]]} 1.20 @@ -29,33 +34,36 @@ 1.21 1.22 (defn render-layer! 1.23 "Render layer in a new graphics context." 1.24 - ([context layer] 1.25 - (render-layer! context layer 0 0 *width* *height*)) 1.26 - ([context layer x y] 1.27 - (render-layer! context layer x y true)) 1.28 - ([context layer x y clip] 1.29 + ([context layer graphics] 1.30 + (render-layer! context layer graphics 1.31 + 0 0 (:width context) (:height context))) 1.32 + ([context layer graphics x y] 1.33 + (render-layer! context layer graphics x y true)) 1.34 + ([context layer graphics x y clip] 1.35 (let [s (size layer context)] 1.36 - (render-layer! context layer x y (.width s) (.height s) clip))) 1.37 - ([context layer x y w h] 1.38 - (render-layer! context layer x y w h true)) 1.39 - ([context layer x y w h clip] 1.40 - (render! layer 1.41 - (assoc context 1.42 - :prev context 1.43 - :graphics (make-graphics (:graphics context) 1.44 - x y w h clip) 1.45 - :rx (+ (:rx context) x) 1.46 - :ry (+ (:ry context) y) 1.47 - :width w 1.48 - :height h)))) 1.49 + (render-layer! context layer graphics 1.50 + x y (.width s) (.height s) clip))) 1.51 + ([context layer graphics x y w h] 1.52 + (render-layer! context layer graphics 1.53 + x y w h true)) 1.54 + ([context layer graphics x y w h clip] 1.55 + (let [graphics (make-graphics graphics x y w h clip)] 1.56 + (try 1.57 + (render! layer 1.58 + (assoc context 1.59 + :layer layer 1.60 + :parent context 1.61 + :rx (+ (:rx context) x) 1.62 + :ry (+ (:ry context) y) 1.63 + :width w 1.64 + :height h) 1.65 + graphics) 1.66 + (finally 1.67 + (.dispose graphics)))))) 1.68 1.69 ;; 1.70 ;; Event handling 1.71 ;; 1.72 -;; LayerContext сам реализует EventDispatcher. 1.73 -;; Дерево диспетчеров-контекстов. 1.74 -;; Передача события от корня. 1.75 -;; 1.76 1.77 (defmulti handle-layer-event 1.78 (fn [layer context event] 1.79 @@ -64,18 +72,37 @@ 1.80 (defmethod handle-layer-event :default [layer context event]) 1.81 1.82 (defprotocol EventDispatcher 1.83 - (register [this layer]) 1.84 + (register [this context]) 1.85 (commit [this])) 1.86 1.87 -(defrecord LayerContext [prev rx ry width height update-fn dispatcher]) 1.88 +(defn- assoc-conj [vmap key val] 1.89 + "Add val to the sequence associated with key in vmap." 1.90 + (assoc vmap key (conj (get vmap key) val))) 1.91 + 1.92 +(defn- registered-parent 1.93 + "Returns first context parent registered for event processing." 1.94 + [context-tree context] 1.95 + (let [parent (:parent context)] 1.96 + (cond 1.97 + (nil? parent) nil 1.98 + (contains? context-tree parent) parent 1.99 + :default (recur context-tree parent)))) 1.100 1.101 (defn make-event-dispatcher [] 1.102 - (let [tree (ref {})] 1.103 + (let [context-tree-r (ref {}) ; register 1.104 + context-tree (ref {}) ; dispatch 1.105 + hovered (ref []) 1.106 + picked (ref [])] 1.107 (reify 1.108 EventDispatcher 1.109 - (register [this layer]) 1.110 - (commit [this])))) 1.111 - 1.112 + (register [this context] 1.113 + (dosync 1.114 + (alter context-tree-r assoc-conj 1.115 + (registered-parent context) context))) 1.116 + (commit [this] 1.117 + (dosync (ref-set context-tree @context-tree-r) 1.118 + (ref-set context-tree-r {})))))) 1.119 + 1.120 ;; (defn make-event-dispatcher [] 1.121 ;; (let [contexts-r (ref []) ; register 1.122 ;; contexts (ref []) ; dispatch 1.123 @@ -141,12 +168,12 @@ 1.124 (paint [g] 1.125 (let [size (.getSize this) 1.126 width (.width size) 1.127 - height (.height size)] 1.128 - (binding [*graphics* g 1.129 - *update-fn* (make-update-fn this)] 1.130 - (render-layer! layer 0 0 width height false)))) 1.131 + height (.height size) 1.132 + context (assoc (default-context) 1.133 + :update-fn (make-update-fn this))] 1.134 + (render-layer! context layer g 0 0 width height false))) 1.135 (getPreferredSize [] 1.136 - (let [s (size layer)] 1.137 + (let [s (size layer nil)] ;; TODO: supply context 1.138 (Dimension. (s 0) (s 1)))) 1.139 (processEvent [event])) 1.140 ;; No way to call protected final evenbleEvents even in gen-class,