Mercurial > hg > indyvon
view src/indyvon/core.clj @ 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 |
line wrap: on
line source
(ns indyvon.core (:import (java.awt Dimension Point Component Graphics2D AWTEvent) (java.awt.event MouseAdapter MouseMotionAdapter MouseListener MouseMotionListener))) (defprotocol Layer (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]]} method-map (loop [fns fns mm method-map] (if-let [form (first fns)] (recur (next fns) (conj mm [(first form) (next form)])) mm)) methods (for [m method-map] (cons (first m) (second m)))] `(reify Layer ~@methods))) (defn- make-graphics [g x y w h clip] (if clip (.create g x y w h) (doto (.create g) (.translate x y)))) (defn render-layer! "Render layer in a new graphics context." ([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 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 ;; (defmulti handle-layer-event (fn [layer context event] [layer (.getID event)])) (defmethod handle-layer-event :default [layer context event]) (defprotocol EventDispatcher (register [this context]) (commit [this])) (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 [context-tree-r (ref {}) ; register context-tree (ref {}) ; dispatch hovered (ref []) picked (ref [])] (reify EventDispatcher (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 ;; hovered (ref []) ;; picked (ref [])] ;; (reify ;; EventDispatcher ;; (register [this layer] ;; (dosync ;; (alter contexts-r conj ;; (LayerContext. layer *rx* *ry* ;; *width* *height* ;; *update-fn*)))) ;; (commit [this] ;; (dosync (ref-set contexts @contexts-r) ;; (ref-set contexts-r []))) ;; (dispatch [this event] ;; (println "dispatch" this event) ;; ;; TODO ;; ) ;; MouseListener ;; (mouseClicked [this event]) ;; (mouseEntered [this event]) ;; (mouseExited [this event]) ;; (mousePressed [this event]) ;; (mouseReleased [this event]) ;; MouseMotionListener ;; (mouseDragged [this event]) ;; (mouseMoved [this event])))) ;; ;; Connection to AWT. ;; (defn- make-update-fn [component] (fn [] (.repaint component))) ;; (defn make-component [layer] ;; (proxy [Component] [] ;; (update [g] (.paint this g)) ;; (paint [g] ;; (let [insets (.getInsets this) ;; top (.top insets) ;; left (.left insets) ;; bottom (.bottom insets) ;; right (.right insets) ;; size (.getSize this) ;; width (- (.width size) left right) ;; height (- (.height size) top bottom)] ;; (binding [*graphics* g ;; *update-fn* (make-update-fn this)] ;; (render-layer! layer top left width height false)))) ;; (getPreferredSize [] ;; (size layer)))) (defn make-component ([layer] (make-component layer (make-event-dispatcher))) ([layer event-dispatcher] (doto (proxy [Component] [] (update [g] (.paint this g)) (paint [g] (let [size (.getSize this) width (.width size) 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 nil)] ;; TODO: supply context (Dimension. (s 0) (s 1)))) (processEvent [event])) ;; No way to call protected final evenbleEvents even in gen-class, ;; have to use the following hack: (.addMouseListener (proxy [MouseAdapter] [])) (.addMouseMotionListener (proxy [MouseMotionAdapter] []))))) (comment (do (def frame (java.awt.Frame. "Test")) (def layer (reify-layer (render! [this] (.fillRect *graphics* 10 10 40 40)) (size [this] [100 100]))) (doto frame (.addWindowListener (proxy [java.awt.event.WindowAdapter] [] (windowClosing [event] (.dispose frame)))) (.add (make-component layer)) (.pack) (.setVisible true)) ) )