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,