1.1 --- a/src/indyvon/component.clj	Sun Jul 04 06:03:48 2010 +0400
     1.2 +++ b/src/indyvon/component.clj	Mon Jul 05 06:11:42 2010 +0400
     1.3 @@ -5,46 +5,45 @@
     1.4  ;;
     1.5  
     1.6  (ns indyvon.component
     1.7 -  (:use indyvon.core indyvon.layers)
     1.8 +  (:use indyvon.core)
     1.9    (:import (java.awt Component Dimension Color)
    1.10             (javax.swing JFrame JPanel)))
    1.11  
    1.12  (defn- font-context [component]
    1.13    (.getFontRenderContext (.getFontMetrics component (.getFont component))))
    1.14  
    1.15 -(defn paint-component [component layer context graphics]
    1.16 +(defn paint-component [component layer graphics event-dispatcher]
    1.17    (let [size (.getSize component)
    1.18          width (.width size)
    1.19 -        height (.height size)
    1.20 -        context (assoc context
    1.21 -                  :target component
    1.22 -                  :font-context (.getFontRenderContext graphics)
    1.23 -                  :update-fn #(.repaint component))]
    1.24 +        height (.height size)]
    1.25      (.clearRect graphics 0 0 width height)
    1.26 -    (draw! layer context graphics 0 0 width height false))
    1.27 -  (commit (:dispatcher context)))
    1.28 +    (binding [*path* nil
    1.29 +              *graphics* graphics
    1.30 +              *font-context*' (.getFontRenderContext graphics)
    1.31 +              *event-dispatcher* event-dispatcher
    1.32 +              *update* #(.repaint component)
    1.33 +              *bounds* (indyvon.core.Bounds. 0 0 width height)]
    1.34 +      (render! layer nil)
    1.35 +      (commit event-dispatcher))))
    1.36  
    1.37 -(defn preferred-size [component layer context]
    1.38 -  (let [context (assoc context
    1.39 -                  :target component
    1.40 -                  :font-context (font-context component))
    1.41 -        s (size layer context)]
    1.42 -    (Dimension. (s 0) (s 1))))
    1.43 +(defn preferred-size [component layer]
    1.44 +  (binding [*path* nil
    1.45 +            *font-context*' (font-context component)]
    1.46 +    (let [s (size layer nil)]
    1.47 +      (Dimension. (:width s) (:height s)))))
    1.48  
    1.49  (defn make-jpanel
    1.50    ([layer]
    1.51       (make-jpanel layer (make-event-dispatcher)))
    1.52    ([layer event-dispatcher]
    1.53 -     (let [context (default-context)
    1.54 -           context (assoc context :dispatcher event-dispatcher)
    1.55 -           panel
    1.56 +     (let [panel
    1.57             (proxy [JPanel] []
    1.58               (paintComponent [g]
    1.59 -                (paint-component this layer context g))
    1.60 +                (paint-component this layer g event-dispatcher))
    1.61               (getPreferredSize []
    1.62 -                (preferred-size this layer context)))]
    1.63 +                (preferred-size this layer)))]
    1.64 +       (.setBackground panel (:back-color *theme*))
    1.65         (listen! event-dispatcher panel)
    1.66 -       (.setBackground panel (-> context :theme :back-color))
    1.67         panel)))
    1.68  
    1.69  (comment

     2.1 --- a/src/indyvon/core.clj	Sun Jul 04 06:03:48 2010 +0400
     2.2 +++ b/src/indyvon/core.clj	Mon Jul 05 06:11:42 2010 +0400
     2.3 @@ -8,145 +8,92 @@
     2.4    (:import (java.awt Color Font)
     2.5             (java.awt.event MouseListener MouseMotionListener)))
     2.6  
     2.7 -(def *context*)
     2.8 -(def *graphics*)
     2.9 -
    2.10 +(defrecord Location [x y])
    2.11  (defrecord Size [width height])
    2.12  (defrecord Bounds [x y width height])
    2.13  
    2.14 +(def *graphics*)
    2.15  (def *font-context*)
    2.16  (def *bounds*)
    2.17 -(def *theme*)
    2.18  (def *target*)
    2.19  (def *update*)
    2.20  (def *event-dispatcher*)
    2.21 +(def *path*)
    2.22 +
    2.23 +(defrecord Theme [fore-color back-color border-color font])
    2.24 +     
    2.25 +(defn- default-theme []
    2.26 +  (Theme. Color/BLACK Color/WHITE Color/BLUE (Font. "Sans" Font/PLAIN 12)))
    2.27 +
    2.28 +(def *theme* (default-theme))
    2.29  
    2.30  (defprotocol Layer
    2.31    "Basic UI element."
    2.32 -  (render! [this context graphics])
    2.33 -  (size [this context]))
    2.34 +  (render! [this opts])
    2.35 +  (size [this opts]))
    2.36 +
    2.37 +(defn layer? [x]
    2.38 +  (satisfies? Layer x)) 
    2.39 +
    2.40 +(defprotocol EventDispatcher
    2.41 +  (listen! [this component])
    2.42 +  (register [this handle-path])
    2.43 +  (handler [this handle-path event-id f])
    2.44 +  (commit [this]))
    2.45  
    2.46  ;; TODO: modifiers
    2.47  (defrecord MouseEvent [id when x y x-on-screen y-on-screen button])
    2.48  
    2.49 -(defprotocol MouseHandler
    2.50 -  "Layers that also satisfy this protocol will recieve mouse events."
    2.51 -  (handle-mouse [this context event]))
    2.52 +(defn- apply-theme [graphics]
    2.53 +  (doto graphics
    2.54 +    (.setColor (:fore-color *theme*))
    2.55 +    (.setFont (:font *theme*))))
    2.56  
    2.57 -(defprotocol EventDispatcher
    2.58 -  (listen! [this component])
    2.59 -  (register [this context])
    2.60 -  (commit [this])
    2.61 -  (hovered? [this layer])
    2.62 -  (picked? [this layer]))
    2.63 +(defn with-translate* [x y w h f & args]
    2.64 +  (let [graphics (apply-theme (.create *graphics* x y w h))]
    2.65 +    (try
    2.66 +      (apply with-bindings* {#'*bounds* (Bounds. (+ x (:x *bounds*))
    2.67 +                                                 (+ y (:y *bounds*))
    2.68 +                                                 w h)
    2.69 +                             #'*graphics* graphics}
    2.70 +             f args)
    2.71 +      (finally
    2.72 +       (.dispose graphics)))))
    2.73  
    2.74 -(defprotocol Anchored
    2.75 -  "Provide anchor point for Layers. Used by viewport."
    2.76 -  (anchor [this context h-align v-align]
    2.77 -          "Anchor point: [x y], h-align could be :left, :center
    2.78 -           or :right, v-align is :top, :center or :bottom"))
    2.79 +(defmacro with-translate [x y w h & body]
    2.80 +  `(with-translate* ~x ~y ~w ~h (fn [] ~@body)))
    2.81  
    2.82 -;; Default implementation of Anchored for any Layer.
    2.83 -(extend-protocol Anchored
    2.84 -  indyvon.core.Layer
    2.85 -  (anchor [this context h-align v-align]
    2.86 -          (if (and (= h-align :left)
    2.87 -                   (= v-align :top))
    2.88 -            [0 0]
    2.89 -            (let [size (size this context)]
    2.90 -              [(case h-align
    2.91 -                 :top 0
    2.92 -                 :center (/ (size 0) 2)
    2.93 -                 :right (size 0))
    2.94 -               (case v-align
    2.95 -                 :left 0
    2.96 -                 :center (/ (size 1) 2)
    2.97 -                 :bottom (size 1))]))))
    2.98 +(defn with-handle* [handle f & args]
    2.99 +  (let [path (cons handle *path*)]
   2.100 +    (register *event-dispatcher* path)
   2.101 +    (apply with-bindings* {#'*path* path} f args)))
   2.102  
   2.103 -(defrecord Theme [fore-color back-color border-color font])
   2.104 +(defmacro with-handle [handle & body]
   2.105 +  `(with-handle* ~handle (fn [] ~@body)))
   2.106  
   2.107 -(defn default-theme []
   2.108 -  (Theme. Color/BLACK Color/WHITE Color/BLUE (Font. "Sans" Font/PLAIN 12)))
   2.109 -  
   2.110 -(defrecord LayerContext
   2.111 -  [handle           ; Identifies context for dispatching mouse
   2.112 -                    ; entered/exited and mainaining keyboard focus.
   2.113 -   parent           ; Parent context.
   2.114 -   x y width height ; Geometry.
   2.115 -   update-fn        ; Call to request repaint.
   2.116 -   dispatcher       ; Event dispatcher.
   2.117 -   font-context     ; An instance of java.awt.font.FontRenderContext.
   2.118 -   theme            ; An instance of Theme.
   2.119 -   target           ; Component.
   2.120 -   handlers])       ; Map: event-id -> handler fn.
   2.121 +(defn handle-event* [event-id f & args]
   2.122 +  (let [f (if args #(f % args) f)]
   2.123 +    (handler *event-dispatcher* *path* event-id f)))
   2.124  
   2.125 -(defn default-context []
   2.126 -  (LayerContext. nil nil 0 0 0 0 nil nil nil (default-theme) nil nil))
   2.127 +(defmacro handle-event [event-id name & body]
   2.128 +  `(handle-event* ~event-id (fn [~name] ~@body)))
   2.129  
   2.130 -(defn update [context]
   2.131 -  ((:update-fn context)))
   2.132 +(defn- geometry-vec [geometry]
   2.133 +  (if (vector? geometry)
   2.134 +    geometry
   2.135 +    [(:x geometry) (:y geometry) (:width geometry) (:height geometry)]))
   2.136  
   2.137 -(defn- make-graphics [graphics x y w h clip]
   2.138 -  (if clip
   2.139 -    (.create graphics x y w h)
   2.140 -    (doto (.create graphics)
   2.141 -      (.translate x y))))
   2.142 -
   2.143 -(defn- apply-theme [graphics theme]
   2.144 -  (doto graphics
   2.145 -    (.setColor (:fore-color theme))
   2.146 -    (.setFont (:font theme))))
   2.147 -
   2.148 -;; (defn with-context* [opts fn & args]
   2.149 -;;   (let [context (apply assoc *context*
   2.150 -;;                        :parent *context*
   2.151 -;;                        :handlers nil
   2.152 -;;                        opts)
   2.153 -;;         graphics (make-graphics *graphics* x y w h false)
   2.154 -;;         graphics (apply-theme graphics (:theme context))]
   2.155 -;;     (try
   2.156 -;;       (register (:dispatcher context) context)
   2.157 -;;       (with-bindings* {#'*context* context
   2.158 -;;                        #'*graphics* graphics}
   2.159 -;;         fn args)
   2.160 -;;       (finally
   2.161 -;;        (.dispose graphics)))))
   2.162 -
   2.163 -;; (defmacro with-context [opts & body]
   2.164 -;;   `(with-context* ~opts #(~@body)))
   2.165 -
   2.166 -(defn draw!
   2.167 -  "Render layer in a new graphics context."
   2.168 -  ([layer context graphics]
   2.169 -     (draw! layer context graphics
   2.170 -                    0 0 (:width context) (:height context)))
   2.171 -  ([layer context graphics x y]
   2.172 -     (draw! layer context graphics x y true))
   2.173 -  ([layer context graphics x y clip]
   2.174 -     (let [s (size layer context)]
   2.175 -       (draw! layer context graphics
   2.176 -              x y (s 0) (s 1) clip)))
   2.177 -  ([layer context graphics x y w h]
   2.178 -     (draw! layer context graphics
   2.179 -            x y w h true))
   2.180 -  ([layer context graphics x y w h clip]
   2.181 -     (let [context (assoc context
   2.182 -                     :handle layer
   2.183 -                     :parent context
   2.184 -                     :x (+ (:x context) x)
   2.185 -                     :y (+ (:y context) y)
   2.186 -                     :width w
   2.187 -                     :height h)
   2.188 -           graphics (make-graphics graphics x y w h clip)
   2.189 -           graphics (apply-theme graphics (:theme context))]
   2.190 -       (try
   2.191 -         (register (:dispatcher context) context)
   2.192 -         (render! layer context graphics)
   2.193 -         (finally
   2.194 -          (.dispose graphics))))))
   2.195 +(defn draw! [layer geometry & args]
   2.196 +  "Draw a layer. Geometry is either a map or vector [x y] or
   2.197 +   [x y width height]."
   2.198 +  (let [[x y w h] (geometry-vec geometry)
   2.199 +        size (if-not (and w h) (size layer args))
   2.200 +        w (or w (:width size))
   2.201 +        h (or h (:height size))]
   2.202 +    (with-translate* x y w h render! layer args)))
   2.203  
   2.204  ;;
   2.205 -;; EventDispatcher implementation
   2.206 +;; EventDispatcher
   2.207  ;;
   2.208  
   2.209  (def awt-events
   2.210 @@ -158,25 +105,28 @@
   2.211        java.awt.event.MouseEvent/MOUSE_PRESSED  :mouse-pressed
   2.212        java.awt.event.MouseEvent/MOUSE_RELEASED :mouse-released})
   2.213  
   2.214 -(defn- registered-parent
   2.215 -  "Returns first context parent registered for event processing."
   2.216 -  [context-tree context]
   2.217 -  (let [parent (:parent context)]
   2.218 -    (cond
   2.219 -     (nil? parent) nil
   2.220 -     (contains? context-tree parent) parent
   2.221 -     :default (recur context-tree parent))))
   2.222 +(defrecord DispatcherNode [id bounds children handlers])
   2.223  
   2.224 -(defn- add-context
   2.225 -  [context-tree context]
   2.226 -  (let [parent (registered-parent context-tree context)]
   2.227 -    (assoc context-tree parent (cons context (context-tree parent))
   2.228 -           context nil)))
   2.229 +(defn- add-child [node child]
   2.230 +  (assoc node :children (cons child (:children node))))
   2.231 +
   2.232 +(defn- add-path [tree path]
   2.233 +  (let [parent-path (next path)
   2.234 +        parent-node (get tree parent-path)
   2.235 +        node (DispatcherNode. path *bounds* nil
   2.236 +                              (get-in tree [path :handlers]))]
   2.237 +    (assoc tree
   2.238 +      parent-path (add-child parent-node node)
   2.239 +      path node)))
   2.240 +
   2.241 +(defn add-handler [tree path event-id f]
   2.242 +  (let [keys [path :handlers event-id]]
   2.243 +  (assoc-in tree keys (cons f (get-in tree keys)))))
   2.244  
   2.245  (defn- inside?
   2.246 -  ([x y context]
   2.247 -     (inside? x y (:x context) (:y context)
   2.248 -              (:width context) (:height context)))
   2.249 +  ([x y bounds]
   2.250 +     (inside? x y (:x bounds) (:y bounds)
   2.251 +              (:width bounds) (:height bounds)))
   2.252    ([px py x y w h]
   2.253       (and (>= px x)
   2.254            (>= py y)
   2.255 @@ -184,13 +134,13 @@
   2.256            (< py (+ y h)))))
   2.257  
   2.258  (defn- under-cursor
   2.259 -  "Returns a sequence of contexts under cursor."
   2.260 -  ([context-tree x y]
   2.261 -     (under-cursor context-tree x y nil))
   2.262 -  ([context-tree x y context]
   2.263 -     (some #(if (inside? x y %)
   2.264 -              (conj (under-cursor context-tree x y %) %))
   2.265 -           (context-tree context))))
   2.266 +  "Returns a sequence of nodes under cursor."
   2.267 +  ([tree x y]
   2.268 +     (under-cursor tree x y nil))
   2.269 +  ([tree x y node]
   2.270 +     (some #(if (inside? x y (:bounds %))
   2.271 +              (conj (under-cursor tree x y %) %))
   2.272 +           (get tree (:children node)))))
   2.273  
   2.274  (defn- remove-all [coll1 coll2 pred]
   2.275    (filter #(not (some (partial pred %) coll2)) coll1))
   2.276 @@ -203,30 +153,26 @@
   2.277                 (.getButton event)))
   2.278  
   2.279  (defn- translate-and-dispatch
   2.280 -  ([contexts event]
   2.281 -     (translate-and-dispatch contexts event (awt-events (.getID event))))
   2.282 -  ([contexts event id]
   2.283 -     (doseq [context contexts]
   2.284 -       (if-let [handler (get (:handlers context) id)]
   2.285 -         (handler context (translate-mouse-event
   2.286 -                           event (:x context) (:y context) id))))
   2.287 +  ([nodes event]
   2.288 +     (translate-and-dispatch nodes event (awt-events (.getID event))))
   2.289 +  ([nodes event id]
   2.290 +     (doseq [node nodes
   2.291 +             :let [bounds (:bounds node)
   2.292 +                   event (translate-mouse-event event
   2.293 +                           (:x bounds) (:y bounds) id)]
   2.294 +             handler (get (:handlers node) id)]
   2.295 +       ;; TODO restore more of the original context.
   2.296 +       (with-bindings* {#'*bounds* bounds} handler event))
   2.297       id))
   2.298  
   2.299 -(defn- context-id [context]
   2.300 -  (loop [context context
   2.301 -         id nil]
   2.302 -    (if context
   2.303 -      (recur (:parent context) (cons (:handle context) id))
   2.304 -      id)))
   2.305 -
   2.306  (defn- dispatch-mouse-motion*
   2.307 -  "Dispatches mouse motion events. Returns a new set of contexts which
   2.308 +  "Dispatches mouse motion events. Returns a new set of nodes which
   2.309    currently are under cursor."
   2.310 -  [hovered context-tree event]
   2.311 +  [hovered tree event]
   2.312    (let [x (.getX event)
   2.313          y (.getY event)
   2.314 -        hovered2 (under-cursor context-tree x y)
   2.315 -        pred #(= (context-id %1) (context-id %2))
   2.316 +        hovered2 (under-cursor tree x y)
   2.317 +        pred #(= (:id %1) (:id %2))
   2.318          exited (remove-all hovered hovered2 pred)
   2.319          entered (remove-all hovered2 hovered pred)
   2.320          moved (remove-all hovered2 entered pred)]
   2.321 @@ -236,12 +182,12 @@
   2.322      hovered2))
   2.323  
   2.324  (defn- dispatch-mouse-motion
   2.325 -  [hovered-ref context-tree event]
   2.326 +  [hovered-ref tree event]
   2.327    (dosync
   2.328 -   (alter hovered-ref dispatch-mouse-motion* context-tree event)))
   2.329 +   (alter hovered-ref dispatch-mouse-motion* tree event)))
   2.330  
   2.331  (defn- dispatch-mouse-button*
   2.332 -  "Dispatches mouse button events. Returns a new set of contexts which
   2.333 +  "Dispatches mouse button events. Returns a new set of nodes which
   2.334    currently are picked with a pressed button."
   2.335    [picked hovered event]
   2.336    (if (= (translate-and-dispatch hovered event) :mouse-pressed)
   2.337 @@ -254,8 +200,10 @@
   2.338     (alter picked-ref dispatch-mouse-button* @hovered-ref event)))
   2.339  
   2.340  (defn make-event-dispatcher []
   2.341 -  (let [context-tree-r (ref {}) ; register
   2.342 -        context-tree (ref {})   ; dispatch
   2.343 +  (let [root-node (DispatcherNode. nil nil nil nil)
   2.344 +        tree-i {nil root-node} ; initial
   2.345 +        tree-r (ref tree-i)    ; register
   2.346 +        tree (ref tree-i)      ; dispatch
   2.347          hovered (ref '())
   2.348          picked (ref '())]
   2.349      (reify
   2.350 @@ -264,19 +212,18 @@
   2.351          (doto component
   2.352            (.addMouseListener this)
   2.353            (.addMouseMotionListener this)))
   2.354 -     (register [this context]
   2.355 -        (if (:handlers context)
   2.356 -          (dosync (alter context-tree-r add-context context))))
   2.357 +     (register [this path]
   2.358 +        (dosync (alter tree-r add-path path)))
   2.359 +     (handler [this path event-id f]
   2.360 +        (dosync (alter tree-r add-handler path event-id f)))
   2.361       (commit [this]
   2.362 -        (dosync (ref-set context-tree @context-tree-r)
   2.363 -                (ref-set context-tree-r {})))
   2.364 -     (picked? [this layer] false)
   2.365 -     (hovered? [this layer] false)
   2.366 +        (dosync (ref-set tree @tree-r)
   2.367 +                (ref-set tree-r tree-i)))
   2.368       MouseListener
   2.369       (mouseEntered [this event]
   2.370 -        (dispatch-mouse-motion hovered @context-tree event))
   2.371 +        (dispatch-mouse-motion hovered @tree event))
   2.372       (mouseExited [this event]
   2.373 -        (dispatch-mouse-motion hovered @context-tree event))
   2.374 +        (dispatch-mouse-motion hovered @tree event))
   2.375       (mouseClicked [this event]
   2.376          (dispatch-mouse-button picked hovered event))
   2.377       (mousePressed [this event]
   2.378 @@ -287,4 +234,29 @@
   2.379       (mouseDragged [this event]
   2.380          (translate-and-dispatch @picked event))
   2.381       (mouseMoved [this event]
   2.382 -        (dispatch-mouse-motion hovered @context-tree event)))))
   2.383 +        (dispatch-mouse-motion hovered @tree event)))))
   2.384 +
   2.385 +;;
   2.386 +;; ИДЕИ:
   2.387 +;;
   2.388 +;; Контекст: биндинги или запись?
   2.389 +;;
   2.390 +;; Установка обработчиков (в контексте слоя):
   2.391 +;;
   2.392 +;; (listen
   2.393 +;;   (:mouse-entered e
   2.394 +;;     ...)
   2.395 +;;   (:mouse-exited e
   2.396 +;;     ...))
   2.397 +;;
   2.398 +;; Не надо IMGUI.
   2.399 +;; Построение сцены путем декорирования слоев:
   2.400 +;;
   2.401 +;; (listener
   2.402 +;;  (:action e (println e))
   2.403 +;;  (:mouse-dragged e (println e))
   2.404 +;;  (theme :font "Helvetica-14"
   2.405 +;;    (vbox
   2.406 +;;      (button (text-layer "Button 1"))
   2.407 +;;      (button (text-layer "Button 2")))))
   2.408 +;;

     3.1 --- a/src/indyvon/core_new.clj	Sun Jul 04 06:03:48 2010 +0400
     3.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
     3.3 @@ -1,228 +0,0 @@
     3.4 -;; Copyright (C) 2010 Mikhail Kryshen <mikhail@kryshen.net>
     3.5 -;;
     3.6 -;; This file is part of Indyvon.
     3.7 -;;
     3.8 -
     3.9 -(ns indyvon.core_new
    3.10 -  (:import (java.awt Color Font)
    3.11 -           (java.awt.event MouseListener MouseMotionListener)))
    3.12 -
    3.13 -(defrecord Location [x y])
    3.14 -(defrecord Size [width height])
    3.15 -(defrecord Bounds [x y width height])
    3.16 -
    3.17 -(def *graphics*)
    3.18 -(def *font-context*)
    3.19 -(def *bounds*)
    3.20 -(def *theme*)
    3.21 -(def *target*)
    3.22 -(def *update*)
    3.23 -(def *event-dispatcher*)
    3.24 -(def *path*)
    3.25 -
    3.26 -(defprotocol Layer
    3.27 -  "Basic UI element."
    3.28 -  (render! [this opts])
    3.29 -  (size [this opts]))
    3.30 -
    3.31 -(defn layer? [x]
    3.32 -  (satisfies? Layer x)) 
    3.33 -
    3.34 -(defprotocol EventDispatcher
    3.35 -  (listen! [this component])
    3.36 -  (register [this handle-path])
    3.37 -  (handler [this handle-path event-id f])
    3.38 -  (commit [this]))
    3.39 -
    3.40 -;; TODO: modifiers
    3.41 -(defrecord MouseEvent [id when x y x-on-screen y-on-screen button])
    3.42 -
    3.43 -(defn with-translate* [x y w h f & args]
    3.44 -  (let [graphics (.create *graphics* x y w h)]  
    3.45 -    (try
    3.46 -      (apply with-bindings* {#'*bounds* (Bounds. (+ x (:x *bounds*))
    3.47 -                                                 (+ y (:y *bounds*))
    3.48 -                                                 w h)
    3.49 -                             #'*graphics* graphics}
    3.50 -             f args)
    3.51 -      (finally
    3.52 -       (.dispose graphics)))))
    3.53 -
    3.54 -(defn with-handle* [handle f & args]
    3.55 -  (let [path (cons handle *path*)]
    3.56 -    (register *event-dispatcher* path)
    3.57 -    (apply with-bindings* {#'*path* path} f args)))
    3.58 -
    3.59 -(defn- geometry-vec [geometry]
    3.60 -  (if (vector? geometry)
    3.61 -    geometry
    3.62 -    [(:x geometry) (:y geometry) (:width geometry) (:height geometry)]))
    3.63 -
    3.64 -(defn draw! [layer geometry & args]
    3.65 -  "Draw a layer. Geometry is either a map or vector [x y] or
    3.66 -   [x y width height]."
    3.67 -  (let [[x y w h] (geometry-vec geometry)
    3.68 -        size (if-not (and w h) (size layer args))
    3.69 -        w (or w (:width size))
    3.70 -        h (or h (:height size))]
    3.71 -    (with-translate* x y w h render! layer args)))
    3.72 -
    3.73 -(defn draw-root! [layer width height graphics event-dispatcher]
    3.74 -  (with-bindings* {#'*path* nil
    3.75 -                   #'*graphics* graphics
    3.76 -                   #'*event-dispatcher* event-dispatcher
    3.77 -                   #'*bounds* (Bounds. 0 0 width height)}
    3.78 -    render! layer))
    3.79 -
    3.80 -;;
    3.81 -;; EventDispatcher
    3.82 -;;
    3.83 -
    3.84 -(def awt-events
    3.85 -     {java.awt.event.MouseEvent/MOUSE_CLICKED  :mouse-clicked
    3.86 -      java.awt.event.MouseEvent/MOUSE_DRAGGED  :mouse-dragged
    3.87 -      java.awt.event.MouseEvent/MOUSE_ENTERED  :mouse-entered
    3.88 -      java.awt.event.MouseEvent/MOUSE_EXITED   :mouse-exited
    3.89 -      java.awt.event.MouseEvent/MOUSE_MOVED    :mouse-moved
    3.90 -      java.awt.event.MouseEvent/MOUSE_PRESSED  :mouse-pressed
    3.91 -      java.awt.event.MouseEvent/MOUSE_RELEASED :mouse-released})
    3.92 -
    3.93 -(defrecord DispatcherNode [id bounds children handlers])
    3.94 -
    3.95 -(defn- add-child [node child]
    3.96 -  (assoc node :children (cons child (:children node))))
    3.97 -
    3.98 -(defn- add-path [tree path]
    3.99 -  (let [parent-path (next path)
   3.100 -        parent-node (get tree parent-path)
   3.101 -        node (DispatcherNode. path *bounds* nil
   3.102 -                              (get-in tree [path :handlers]))]
   3.103 -    (assoc tree
   3.104 -      parent-path (add-child parent-node node)
   3.105 -      path node)))
   3.106 -
   3.107 -(defn add-handler [tree path event-id f]
   3.108 -  (let [keys [path :handlers event-id]]
   3.109 -  (assoc-in tree keys (cons f (get-in tree keys)))))
   3.110 -
   3.111 -(defn- inside?
   3.112 -  ([x y bounds]
   3.113 -     (inside? x y (:x bounds) (:y bounds)
   3.114 -              (:width bounds) (:height bounds)))
   3.115 -  ([px py x y w h]
   3.116 -     (and (>= px x)
   3.117 -          (>= py y)
   3.118 -          (< px (+ x w))
   3.119 -          (< py (+ y h)))))
   3.120 -
   3.121 -(defn- under-cursor
   3.122 -  "Returns a sequence of nodes under cursor."
   3.123 -  ([tree x y]
   3.124 -     (under-cursor tree x y nil))
   3.125 -  ([tree x y node]
   3.126 -     (some #(if (inside? x y (:bounds %))
   3.127 -              (conj (under-cursor tree x y %) %))
   3.128 -           (get tree (:children node)))))
   3.129 -
   3.130 -(defn- remove-all [coll1 coll2 pred]
   3.131 -  (filter #(not (some (partial pred %) coll2)) coll1))
   3.132 -
   3.133 -(defn- translate-mouse-event
   3.134 -  [event x y id]
   3.135 -  (MouseEvent. id (.getWhen event)
   3.136 -               (- (.getX event) x) (- (.getY event) y)
   3.137 -               (.getXOnScreen event) (.getYOnScreen event)
   3.138 -               (.getButton event)))
   3.139 -
   3.140 -(defn- translate-and-dispatch
   3.141 -  ([nodes event]
   3.142 -     (translate-and-dispatch nodes event (awt-events (.getID event))))
   3.143 -  ([nodes event id]
   3.144 -     (doseq [node nodes
   3.145 -             :let [bounds (:bounds node)
   3.146 -                   event (translate-mouse-event event
   3.147 -                           (:x bounds) (:y bounds) id)]
   3.148 -             handler (get (:handlers node) id)]
   3.149 -       ;; TODO restore more of the original context.
   3.150 -       (with-bindings* {#'*bounds* bounds} handler event))
   3.151 -     id))
   3.152 -
   3.153 -(defn- dispatch-mouse-motion*
   3.154 -  "Dispatches mouse motion events. Returns a new set of nodes which
   3.155 -  currently are under cursor."
   3.156 -  [hovered tree event]
   3.157 -  (let [x (.getX event)
   3.158 -        y (.getY event)
   3.159 -        hovered2 (under-cursor tree x y)
   3.160 -        pred #(= (:id %1) (:id %2))
   3.161 -        exited (remove-all hovered hovered2 pred)
   3.162 -        entered (remove-all hovered2 hovered pred)
   3.163 -        moved (remove-all hovered2 entered pred)]
   3.164 -    (translate-and-dispatch exited event :mouse-exited)
   3.165 -    (translate-and-dispatch entered event :mouse-entered)
   3.166 -    (translate-and-dispatch moved event :mouse-moved)
   3.167 -    hovered2))
   3.168 -
   3.169 -(defn- dispatch-mouse-motion
   3.170 -  [hovered-ref tree event]
   3.171 -  (dosync
   3.172 -   (alter hovered-ref dispatch-mouse-motion* tree event)))
   3.173 -
   3.174 -(defn- dispatch-mouse-button*
   3.175 -  "Dispatches mouse button events. Returns a new set of nodes which
   3.176 -  currently are picked with a pressed button."
   3.177 -  [picked hovered event]
   3.178 -  (if (= (translate-and-dispatch hovered event) :mouse-pressed)
   3.179 -    hovered
   3.180 -    nil))
   3.181 -
   3.182 -(defn- dispatch-mouse-button
   3.183 -  [picked-ref hovered-ref event]
   3.184 -  (dosync
   3.185 -   (alter picked-ref dispatch-mouse-button* @hovered-ref event)))
   3.186 -
   3.187 -(defn make-event-dispatcher []
   3.188 -  (let [root-node (DispatcherNode. nil nil nil nil)
   3.189 -        tree-i {nil root-node} ; initial
   3.190 -        tree-r (ref tree-i)    ; register
   3.191 -        tree (ref tree-i)      ; dispatch
   3.192 -        hovered (ref '())
   3.193 -        picked (ref '())]
   3.194 -    (reify
   3.195 -     EventDispatcher
   3.196 -     (listen! [this component]
   3.197 -        (doto component
   3.198 -          (.addMouseListener this)
   3.199 -          (.addMouseMotionListener this)))
   3.200 -     (register [this path]
   3.201 -        (dosync (alter tree-r add-path path)))
   3.202 -     (handler [this path event-id f]
   3.203 -        (dosync (alter tree-r add-handler path event-id f)))
   3.204 -     (commit [this]
   3.205 -        (dosync (ref-set tree @tree-r)
   3.206 -                (ref-set tree-r tree-i)))
   3.207 -     MouseListener
   3.208 -     (mouseEntered [this event]
   3.209 -        (dispatch-mouse-motion hovered @tree event))
   3.210 -     (mouseExited [this event]
   3.211 -        (dispatch-mouse-motion hovered @tree event))
   3.212 -     (mouseClicked [this event]
   3.213 -        (dispatch-mouse-button picked hovered event))
   3.214 -     (mousePressed [this event]
   3.215 -        (dispatch-mouse-button picked hovered event))
   3.216 -     (mouseReleased [this event]
   3.217 -        (dispatch-mouse-button picked hovered event))
   3.218 -     MouseMotionListener
   3.219 -     (mouseDragged [this event]
   3.220 -        (translate-and-dispatch @picked event))
   3.221 -     (mouseMoved [this event]
   3.222 -        (dispatch-mouse-motion hovered @tree event)))))
   3.223 -
   3.224 -;; (with-handle :button1
   3.225 -;;   (draw! button [5 5 100 200] "Cick Me!"))
   3.226 -
   3.227 -;; (when-event :action :button1
   3.228 -;;     ...)
   3.229 -
   3.230 -;; (handle-event :mouse-entered :button1
   3.231 -;;     ...)