1.1 --- a/src/indyvon/core.clj	Mon Jun 21 04:00:45 2010 +0400
     1.2 +++ b/src/indyvon/core.clj	Sun Jul 04 06:03:48 2010 +0400
     1.3 @@ -8,6 +8,19 @@
     1.4    (:import (java.awt Color Font)
     1.5             (java.awt.event MouseListener MouseMotionListener)))
     1.6  
     1.7 +(def *context*)
     1.8 +(def *graphics*)
     1.9 +
    1.10 +(defrecord Size [width height])
    1.11 +(defrecord Bounds [x y width height])
    1.12 +
    1.13 +(def *font-context*)
    1.14 +(def *bounds*)
    1.15 +(def *theme*)
    1.16 +(def *target*)
    1.17 +(def *update*)
    1.18 +(def *event-dispatcher*)
    1.19 +
    1.20  (defprotocol Layer
    1.21    "Basic UI element."
    1.22    (render! [this context graphics])
    1.23 @@ -55,11 +68,20 @@
    1.24  (defn default-theme []
    1.25    (Theme. Color/BLACK Color/WHITE Color/BLUE (Font. "Sans" Font/PLAIN 12)))
    1.26    
    1.27 -(defrecord LayerContext [layer parent x y width height update-fn
    1.28 -  dispatcher font-context theme target])
    1.29 +(defrecord LayerContext
    1.30 +  [handle           ; Identifies context for dispatching mouse
    1.31 +                    ; entered/exited and mainaining keyboard focus.
    1.32 +   parent           ; Parent context.
    1.33 +   x y width height ; Geometry.
    1.34 +   update-fn        ; Call to request repaint.
    1.35 +   dispatcher       ; Event dispatcher.
    1.36 +   font-context     ; An instance of java.awt.font.FontRenderContext.
    1.37 +   theme            ; An instance of Theme.
    1.38 +   target           ; Component.
    1.39 +   handlers])       ; Map: event-id -> handler fn.
    1.40  
    1.41  (defn default-context []
    1.42 -  (LayerContext. nil nil 0 0 0 0 nil nil nil (default-theme) nil))
    1.43 +  (LayerContext. nil nil 0 0 0 0 nil nil nil (default-theme) nil nil))
    1.44  
    1.45  (defn update [context]
    1.46    ((:update-fn context)))
    1.47 @@ -75,6 +97,24 @@
    1.48      (.setColor (:fore-color theme))
    1.49      (.setFont (:font theme))))
    1.50  
    1.51 +;; (defn with-context* [opts fn & args]
    1.52 +;;   (let [context (apply assoc *context*
    1.53 +;;                        :parent *context*
    1.54 +;;                        :handlers nil
    1.55 +;;                        opts)
    1.56 +;;         graphics (make-graphics *graphics* x y w h false)
    1.57 +;;         graphics (apply-theme graphics (:theme context))]
    1.58 +;;     (try
    1.59 +;;       (register (:dispatcher context) context)
    1.60 +;;       (with-bindings* {#'*context* context
    1.61 +;;                        #'*graphics* graphics}
    1.62 +;;         fn args)
    1.63 +;;       (finally
    1.64 +;;        (.dispose graphics)))))
    1.65 +
    1.66 +;; (defmacro with-context [opts & body]
    1.67 +;;   `(with-context* ~opts #(~@body)))
    1.68 +
    1.69  (defn draw!
    1.70    "Render layer in a new graphics context."
    1.71    ([layer context graphics]
    1.72 @@ -91,7 +131,7 @@
    1.73              x y w h true))
    1.74    ([layer context graphics x y w h clip]
    1.75       (let [context (assoc context
    1.76 -                     :layer layer
    1.77 +                     :handle layer
    1.78                       :parent context
    1.79                       :x (+ (:x context) x)
    1.80                       :y (+ (:y context) y)
    1.81 @@ -155,19 +195,6 @@
    1.82  (defn- remove-all [coll1 coll2 pred]
    1.83    (filter #(not (some (partial pred %) coll2)) coll1))
    1.84  
    1.85 -;; (defn- translate-mouse-event
    1.86 -;;   [event x y id]
    1.87 -;;   (proxy [MouseEvent] [(.getComponent event)
    1.88 -;;                        id
    1.89 -;;                        (.getWhen event)
    1.90 -;;                        (.getModifiers event)
    1.91 -;;                        (- (.getX event) x)
    1.92 -;;                        (- (.getY event) y)
    1.93 -;;                        (.getClickCount event)
    1.94 -;;                        (.isPopupTrigger event)]
    1.95 -;;     (getXOnScreen [] (.getXOnScreen event))
    1.96 -;;     (getYOnScreen [] (.getYOnScreen event))))
    1.97 -
    1.98  (defn- translate-mouse-event
    1.99    [event x y id]
   1.100    (MouseEvent. id (.getWhen event)
   1.101 @@ -180,11 +207,18 @@
   1.102       (translate-and-dispatch contexts event (awt-events (.getID event))))
   1.103    ([contexts event id]
   1.104       (doseq [context contexts]
   1.105 -       (handle-mouse
   1.106 -        (:layer context) context 
   1.107 -        (translate-mouse-event event (:x context) (:y context) id)))
   1.108 +       (if-let [handler (get (:handlers context) id)]
   1.109 +         (handler context (translate-mouse-event
   1.110 +                           event (:x context) (:y context) id))))
   1.111       id))
   1.112  
   1.113 +(defn- context-id [context]
   1.114 +  (loop [context context
   1.115 +         id nil]
   1.116 +    (if context
   1.117 +      (recur (:parent context) (cons (:handle context) id))
   1.118 +      id)))
   1.119 +
   1.120  (defn- dispatch-mouse-motion*
   1.121    "Dispatches mouse motion events. Returns a new set of contexts which
   1.122    currently are under cursor."
   1.123 @@ -192,7 +226,7 @@
   1.124    (let [x (.getX event)
   1.125          y (.getY event)
   1.126          hovered2 (under-cursor context-tree x y)
   1.127 -        pred #(= (:layer %1) (:layer %2))
   1.128 +        pred #(= (context-id %1) (context-id %2))
   1.129          exited (remove-all hovered hovered2 pred)
   1.130          entered (remove-all hovered2 hovered pred)
   1.131          moved (remove-all hovered2 entered pred)]
   1.132 @@ -231,7 +265,7 @@
   1.133            (.addMouseListener this)
   1.134            (.addMouseMotionListener this)))
   1.135       (register [this context]
   1.136 -        (when (satisfies? MouseHandler (:layer context))
   1.137 +        (if (:handlers context)
   1.138            (dosync (alter context-tree-r add-context context))))
   1.139       (commit [this]
   1.140          (dosync (ref-set context-tree @context-tree-r)

     2.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     2.2 +++ b/src/indyvon/core_new.clj	Sun Jul 04 06:03:48 2010 +0400
     2.3 @@ -0,0 +1,228 @@
     2.4 +;; Copyright (C) 2010 Mikhail Kryshen <mikhail@kryshen.net>
     2.5 +;;
     2.6 +;; This file is part of Indyvon.
     2.7 +;;
     2.8 +
     2.9 +(ns indyvon.core_new
    2.10 +  (:import (java.awt Color Font)
    2.11 +           (java.awt.event MouseListener MouseMotionListener)))
    2.12 +
    2.13 +(defrecord Location [x y])
    2.14 +(defrecord Size [width height])
    2.15 +(defrecord Bounds [x y width height])
    2.16 +
    2.17 +(def *graphics*)
    2.18 +(def *font-context*)
    2.19 +(def *bounds*)
    2.20 +(def *theme*)
    2.21 +(def *target*)
    2.22 +(def *update*)
    2.23 +(def *event-dispatcher*)
    2.24 +(def *path*)
    2.25 +
    2.26 +(defprotocol Layer
    2.27 +  "Basic UI element."
    2.28 +  (render! [this opts])
    2.29 +  (size [this opts]))
    2.30 +
    2.31 +(defn layer? [x]
    2.32 +  (satisfies? Layer x)) 
    2.33 +
    2.34 +(defprotocol EventDispatcher
    2.35 +  (listen! [this component])
    2.36 +  (register [this handle-path])
    2.37 +  (handler [this handle-path event-id f])
    2.38 +  (commit [this]))
    2.39 +
    2.40 +;; TODO: modifiers
    2.41 +(defrecord MouseEvent [id when x y x-on-screen y-on-screen button])
    2.42 +
    2.43 +(defn with-translate* [x y w h f & args]
    2.44 +  (let [graphics (.create *graphics* x y w h)]  
    2.45 +    (try
    2.46 +      (apply with-bindings* {#'*bounds* (Bounds. (+ x (:x *bounds*))
    2.47 +                                                 (+ y (:y *bounds*))
    2.48 +                                                 w h)
    2.49 +                             #'*graphics* graphics}
    2.50 +             f args)
    2.51 +      (finally
    2.52 +       (.dispose graphics)))))
    2.53 +
    2.54 +(defn with-handle* [handle f & args]
    2.55 +  (let [path (cons handle *path*)]
    2.56 +    (register *event-dispatcher* path)
    2.57 +    (apply with-bindings* {#'*path* path} f args)))
    2.58 +
    2.59 +(defn- geometry-vec [geometry]
    2.60 +  (if (vector? geometry)
    2.61 +    geometry
    2.62 +    [(:x geometry) (:y geometry) (:width geometry) (:height geometry)]))
    2.63 +
    2.64 +(defn draw! [layer geometry & args]
    2.65 +  "Draw a layer. Geometry is either a map or vector [x y] or
    2.66 +   [x y width height]."
    2.67 +  (let [[x y w h] (geometry-vec geometry)
    2.68 +        size (if-not (and w h) (size layer args))
    2.69 +        w (or w (:width size))
    2.70 +        h (or h (:height size))]
    2.71 +    (with-translate* x y w h render! layer args)))
    2.72 +
    2.73 +(defn draw-root! [layer width height graphics event-dispatcher]
    2.74 +  (with-bindings* {#'*path* nil
    2.75 +                   #'*graphics* graphics
    2.76 +                   #'*event-dispatcher* event-dispatcher
    2.77 +                   #'*bounds* (Bounds. 0 0 width height)}
    2.78 +    render! layer))
    2.79 +
    2.80 +;;
    2.81 +;; EventDispatcher
    2.82 +;;
    2.83 +
    2.84 +(def awt-events
    2.85 +     {java.awt.event.MouseEvent/MOUSE_CLICKED  :mouse-clicked
    2.86 +      java.awt.event.MouseEvent/MOUSE_DRAGGED  :mouse-dragged
    2.87 +      java.awt.event.MouseEvent/MOUSE_ENTERED  :mouse-entered
    2.88 +      java.awt.event.MouseEvent/MOUSE_EXITED   :mouse-exited
    2.89 +      java.awt.event.MouseEvent/MOUSE_MOVED    :mouse-moved
    2.90 +      java.awt.event.MouseEvent/MOUSE_PRESSED  :mouse-pressed
    2.91 +      java.awt.event.MouseEvent/MOUSE_RELEASED :mouse-released})
    2.92 +
    2.93 +(defrecord DispatcherNode [id bounds children handlers])
    2.94 +
    2.95 +(defn- add-child [node child]
    2.96 +  (assoc node :children (cons child (:children node))))
    2.97 +
    2.98 +(defn- add-path [tree path]
    2.99 +  (let [parent-path (next path)
   2.100 +        parent-node (get tree parent-path)
   2.101 +        node (DispatcherNode. path *bounds* nil
   2.102 +                              (get-in tree [path :handlers]))]
   2.103 +    (assoc tree
   2.104 +      parent-path (add-child parent-node node)
   2.105 +      path node)))
   2.106 +
   2.107 +(defn add-handler [tree path event-id f]
   2.108 +  (let [keys [path :handlers event-id]]
   2.109 +  (assoc-in tree keys (cons f (get-in tree keys)))))
   2.110 +
   2.111 +(defn- inside?
   2.112 +  ([x y bounds]
   2.113 +     (inside? x y (:x bounds) (:y bounds)
   2.114 +              (:width bounds) (:height bounds)))
   2.115 +  ([px py x y w h]
   2.116 +     (and (>= px x)
   2.117 +          (>= py y)
   2.118 +          (< px (+ x w))
   2.119 +          (< py (+ y h)))))
   2.120 +
   2.121 +(defn- under-cursor
   2.122 +  "Returns a sequence of nodes under cursor."
   2.123 +  ([tree x y]
   2.124 +     (under-cursor tree x y nil))
   2.125 +  ([tree x y node]
   2.126 +     (some #(if (inside? x y (:bounds %))
   2.127 +              (conj (under-cursor tree x y %) %))
   2.128 +           (get tree (:children node)))))
   2.129 +
   2.130 +(defn- remove-all [coll1 coll2 pred]
   2.131 +  (filter #(not (some (partial pred %) coll2)) coll1))
   2.132 +
   2.133 +(defn- translate-mouse-event
   2.134 +  [event x y id]
   2.135 +  (MouseEvent. id (.getWhen event)
   2.136 +               (- (.getX event) x) (- (.getY event) y)
   2.137 +               (.getXOnScreen event) (.getYOnScreen event)
   2.138 +               (.getButton event)))
   2.139 +
   2.140 +(defn- translate-and-dispatch
   2.141 +  ([nodes event]
   2.142 +     (translate-and-dispatch nodes event (awt-events (.getID event))))
   2.143 +  ([nodes event id]
   2.144 +     (doseq [node nodes
   2.145 +             :let [bounds (:bounds node)
   2.146 +                   event (translate-mouse-event event
   2.147 +                           (:x bounds) (:y bounds) id)]
   2.148 +             handler (get (:handlers node) id)]
   2.149 +       ;; TODO restore more of the original context.
   2.150 +       (with-bindings* {#'*bounds* bounds} handler event))
   2.151 +     id))
   2.152 +
   2.153 +(defn- dispatch-mouse-motion*
   2.154 +  "Dispatches mouse motion events. Returns a new set of nodes which
   2.155 +  currently are under cursor."
   2.156 +  [hovered tree event]
   2.157 +  (let [x (.getX event)
   2.158 +        y (.getY event)
   2.159 +        hovered2 (under-cursor tree x y)
   2.160 +        pred #(= (:id %1) (:id %2))
   2.161 +        exited (remove-all hovered hovered2 pred)
   2.162 +        entered (remove-all hovered2 hovered pred)
   2.163 +        moved (remove-all hovered2 entered pred)]
   2.164 +    (translate-and-dispatch exited event :mouse-exited)
   2.165 +    (translate-and-dispatch entered event :mouse-entered)
   2.166 +    (translate-and-dispatch moved event :mouse-moved)
   2.167 +    hovered2))
   2.168 +
   2.169 +(defn- dispatch-mouse-motion
   2.170 +  [hovered-ref tree event]
   2.171 +  (dosync
   2.172 +   (alter hovered-ref dispatch-mouse-motion* tree event)))
   2.173 +
   2.174 +(defn- dispatch-mouse-button*
   2.175 +  "Dispatches mouse button events. Returns a new set of nodes which
   2.176 +  currently are picked with a pressed button."
   2.177 +  [picked hovered event]
   2.178 +  (if (= (translate-and-dispatch hovered event) :mouse-pressed)
   2.179 +    hovered
   2.180 +    nil))
   2.181 +
   2.182 +(defn- dispatch-mouse-button
   2.183 +  [picked-ref hovered-ref event]
   2.184 +  (dosync
   2.185 +   (alter picked-ref dispatch-mouse-button* @hovered-ref event)))
   2.186 +
   2.187 +(defn make-event-dispatcher []
   2.188 +  (let [root-node (DispatcherNode. nil nil nil nil)
   2.189 +        tree-i {nil root-node} ; initial
   2.190 +        tree-r (ref tree-i)    ; register
   2.191 +        tree (ref tree-i)      ; dispatch
   2.192 +        hovered (ref '())
   2.193 +        picked (ref '())]
   2.194 +    (reify
   2.195 +     EventDispatcher
   2.196 +     (listen! [this component]
   2.197 +        (doto component
   2.198 +          (.addMouseListener this)
   2.199 +          (.addMouseMotionListener this)))
   2.200 +     (register [this path]
   2.201 +        (dosync (alter tree-r add-path path)))
   2.202 +     (handler [this path event-id f]
   2.203 +        (dosync (alter tree-r add-handler path event-id f)))
   2.204 +     (commit [this]
   2.205 +        (dosync (ref-set tree @tree-r)
   2.206 +                (ref-set tree-r tree-i)))
   2.207 +     MouseListener
   2.208 +     (mouseEntered [this event]
   2.209 +        (dispatch-mouse-motion hovered @tree event))
   2.210 +     (mouseExited [this event]
   2.211 +        (dispatch-mouse-motion hovered @tree event))
   2.212 +     (mouseClicked [this event]
   2.213 +        (dispatch-mouse-button picked hovered event))
   2.214 +     (mousePressed [this event]
   2.215 +        (dispatch-mouse-button picked hovered event))
   2.216 +     (mouseReleased [this event]
   2.217 +        (dispatch-mouse-button picked hovered event))
   2.218 +     MouseMotionListener
   2.219 +     (mouseDragged [this event]
   2.220 +        (translate-and-dispatch @picked event))
   2.221 +     (mouseMoved [this event]
   2.222 +        (dispatch-mouse-motion hovered @tree event)))))
   2.223 +
   2.224 +;; (with-handle :button1
   2.225 +;;   (draw! button [5 5 100 200] "Cick Me!"))
   2.226 +
   2.227 +;; (when-event :action :button1
   2.228 +;;     ...)
   2.229 +
   2.230 +;; (handle-event :mouse-entered :button1
   2.231 +;;     ...)