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,