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 wrap: on
line diff
--- a/src/indyvon/core.clj Thu Jun 10 05:35:56 2010 +0400 +++ b/src/indyvon/core.clj Fri Jun 11 04:31:27 2010 +0400 @@ -4,10 +4,15 @@ MouseListener MouseMotionListener))) (defprotocol Layer - (render! [this context]) + (render! [this context graphics]) (size [this context]) (anchor [this context])) +(defrecord LayerContext [layer parent rx ry width height update-fn dispatcher]) + +(defn default-context [] + (LayerContext. nil nil 0 0 0 0 nil nil)) + (defmacro reify-layer [& fns] (let [method-map {'size [['_ '_] [0 0]] 'anchor [['_ '_] [0 0]]} @@ -29,33 +34,36 @@ (defn render-layer! "Render layer in a new graphics context." - ([context layer] - (render-layer! context layer 0 0 *width* *height*)) - ([context layer x y] - (render-layer! context layer x y true)) - ([context layer x y clip] + ([context layer graphics] + (render-layer! context layer graphics + 0 0 (:width context) (:height context))) + ([context layer graphics x y] + (render-layer! context layer graphics x y true)) + ([context layer graphics x y clip] (let [s (size layer context)] - (render-layer! context layer x y (.width s) (.height s) clip))) - ([context layer x y w h] - (render-layer! context layer x y w h true)) - ([context layer x y w h clip] - (render! layer - (assoc context - :prev context - :graphics (make-graphics (:graphics context) - x y w h clip) - :rx (+ (:rx context) x) - :ry (+ (:ry context) y) - :width w - :height h)))) + (render-layer! context layer graphics + x y (.width s) (.height s) clip))) + ([context layer graphics x y w h] + (render-layer! context layer graphics + x y w h true)) + ([context layer graphics x y w h clip] + (let [graphics (make-graphics graphics x y w h clip)] + (try + (render! layer + (assoc context + :layer layer + :parent context + :rx (+ (:rx context) x) + :ry (+ (:ry context) y) + :width w + :height h) + graphics) + (finally + (.dispose graphics)))))) ;; ;; Event handling ;; -;; LayerContext сам реализует EventDispatcher. -;; Дерево диспетчеров-контекстов. -;; Передача события от корня. -;; (defmulti handle-layer-event (fn [layer context event] @@ -64,18 +72,37 @@ (defmethod handle-layer-event :default [layer context event]) (defprotocol EventDispatcher - (register [this layer]) + (register [this context]) (commit [this])) -(defrecord LayerContext [prev rx ry width height update-fn dispatcher]) +(defn- assoc-conj [vmap key val] + "Add val to the sequence associated with key in vmap." + (assoc vmap key (conj (get vmap key) val))) + +(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 make-event-dispatcher [] - (let [tree (ref {})] + (let [context-tree-r (ref {}) ; register + context-tree (ref {}) ; dispatch + hovered (ref []) + picked (ref [])] (reify EventDispatcher - (register [this layer]) - (commit [this])))) - + (register [this context] + (dosync + (alter context-tree-r assoc-conj + (registered-parent context) context))) + (commit [this] + (dosync (ref-set context-tree @context-tree-r) + (ref-set context-tree-r {})))))) + ;; (defn make-event-dispatcher [] ;; (let [contexts-r (ref []) ; register ;; contexts (ref []) ; dispatch @@ -141,12 +168,12 @@ (paint [g] (let [size (.getSize this) width (.width size) - height (.height size)] - (binding [*graphics* g - *update-fn* (make-update-fn this)] - (render-layer! layer 0 0 width height false)))) + height (.height size) + context (assoc (default-context) + :update-fn (make-update-fn this))] + (render-layer! context layer g 0 0 width height false))) (getPreferredSize [] - (let [s (size layer)] + (let [s (size layer nil)] ;; TODO: supply context (Dimension. (s 0) (s 1)))) (processEvent [event])) ;; No way to call protected final evenbleEvents even in gen-class,