Mercurial > hg > indyvon
view src/indyvon/core.clj @ 33:439f6ecee119
Include graphics into context.
Event dispatcher respects clipping.
author | Mikhail Kryshen <mikhail@kryshen.net> |
---|---|
date | Wed, 07 Jul 2010 07:17:08 +0400 |
parents | 0b3757d263db |
children | 6975b9a71eec |
line wrap: on
line source
;; ;; Copyright (C) 2010 Mikhail Kryshen <mikhail@kryshen.net> ;; ;; This file is part of Indyvon. ;; (ns indyvon.core (:import (java.awt Graphics2D Component Color Font) (java.awt.event MouseListener MouseMotionListener))) (defprotocol Layer "Basic UI element." (render! [this context]) (size [this context])) (defrecord Location [x y]) (defrecord Size [width height]) (defrecord Bounds [x y width height]) ;; TODO: modifiers (defrecord MouseEvent [id when x y x-on-screen y-on-screen button]) (defprotocol EventDispatcher (listen! [this ^Component component] "Listen for events on the specified AWT Component.") (create-dispatcher [this context handle handlers] "Returns new event dispatcher associated with the specified event handlers (an event-id -> handler-fn map). Handle is used to match the contexts between commits.") (commit [this] "Apply the registered handlers for event processing.")) (defprotocol Anchored "Provide anchor point for Layers. Used by viewport." (anchor [this context h-align v-align] "Anchor point: [x y], h-align could be :left, :center or :right, v-align is :top, :center or :bottom")) ;; Default implementation of Anchored for any Layer. (extend-protocol Anchored indyvon.core.Layer (anchor [this context h-align v-align] (if (and (= h-align :left) (= v-align :top)) (Location. 0 0) (let [size (size this context)] (Location. (case h-align :top 0 :center (/ (:width size) 2) :right (:width size)) (case v-align :left 0 :center (/ (:height size) 2) :bottom (:height size))))))) (defrecord Theme [fore-color back-color border-color font]) (defn default-theme [] (Theme. Color/BLACK Color/WHITE Color/BLUE (Font. "Sans" Font/PLAIN 12))) (defrecord LayerContext [x y width height clip update-fn font-context theme target event-dispatcher]) (defn default-context [] (LayerContext. 0 0 0 0 nil nil nil (default-theme) nil nil)) (defn update [context] ((:update-fn context))) (defn ^Graphics2D graphics "Get AWT Graphics2D from context." [context] (:graphics context)) (defn- ^Graphics2D make-graphics [^Graphics2D graphics x y w h] (.create graphics x y w h)) (defn- ^Graphics2D apply-theme [^Graphics2D graphics theme] (doto graphics (.setColor (:fore-color theme)) (.setFont (:font theme)))) (defn intersect [bounds x y w h] (let [x12 (+ x w) y12 (+ y h) x21 (:x bounds) y21 (:y bounds) x22 (+ x21 (:width bounds)) y22 (+ y21 (:height bounds)) x1 (max x x21) y1 (max y y21) x2 (min x12 x22) y2 (min y12 y22)] (Bounds. x1 y1 (- x2 x1) (- y2 y1)))) (defn translate [context x y w h] (let [ax (+ (:x context) x) ay (+ (:y context) y)] (assoc context :x (+ (:x context) x) :y (+ (:y context) y) :width w :height h :clip (intersect (:clip context) ax ay w h) :graphics (apply-theme (make-graphics (:graphics context) x y w h) (:theme context))))) (defn draw! "Render layer in a new graphics context." ([layer context] (render! layer context)) ([layer context x y] (let [s (size layer context)] (draw! layer context x y (:width s) (:height s)))) ([layer context x y w h] (let [context (translate context x y w h)] (try (render! layer context) (finally (.dispose (:graphics context))))))) (defn add-handlers [context handle handlers] "Returns new context with the specified event handlers." (assoc context :event-dispatcher (create-dispatcher (:event-dispatcher context) context handle handlers))) (defmacro let-handlers [handle bindings form & specs] "bindings => [binding-form context] or [context-symbol] specs => (:event-id name & handler-body)* Execute form with the specified event handlers." (let [[binding context] bindings context (or context binding)] `(let [context# ~context ~binding (add-handlers context# ~handle ~(reduce (fn [m spec] (assoc m (first spec) `(fn [~(second spec)] ~@(nnext spec)))) {} specs))] ~form))) ;; ;; EventDispatcher implementation ;; (def awt-events {java.awt.event.MouseEvent/MOUSE_CLICKED :mouse-clicked java.awt.event.MouseEvent/MOUSE_DRAGGED :mouse-dragged java.awt.event.MouseEvent/MOUSE_ENTERED :mouse-entered java.awt.event.MouseEvent/MOUSE_EXITED :mouse-exited java.awt.event.MouseEvent/MOUSE_MOVED :mouse-moved java.awt.event.MouseEvent/MOUSE_PRESSED :mouse-pressed java.awt.event.MouseEvent/MOUSE_RELEASED :mouse-released}) (defrecord DispatcherNode [handle handlers parent bounds] EventDispatcher (listen! [this component] (listen! parent component)) (create-dispatcher [this context handle handlers] (create-dispatcher parent context handle handlers)) (commit [this] (commit parent))) (defn- make-node [c handle handlers] (DispatcherNode. handle handlers (:event-dispatcher c) (:clip c))) (defn- assoc-cons [m key val] (assoc m key (cons val (get m key)))) (defn- add-node [tree node] (assoc-cons tree (:parent node) node)) (defn- inside? ([x y bounds] (inside? x y (:x bounds) (:y bounds) (:width bounds) (:height bounds))) ([px py x y w h] (and (>= px x) (>= py y) (< px (+ x w)) (< py (+ y h))))) (defn- under-cursor "Returns a sequence of child nodes under cursor." [x y tree node] (some #(if (inside? x y (:bounds %)) (conj (under-cursor x y tree %) %)) (get tree node))) (defn- remove-all [coll1 coll2 pred] (filter #(not (some (partial pred %) coll2)) coll1)) (defn- translate-mouse-event [^java.awt.event.MouseEvent event x y id] (MouseEvent. id (.getWhen event) (- (.getX event) x) (- (.getY event) y) (.getXOnScreen event) (.getYOnScreen event) (.getButton event))) (defn- translate-and-dispatch ([nodes ^java.awt.event.MouseEvent event] (translate-and-dispatch nodes event (awt-events (.getID event)))) ([nodes event id] (doseq [node nodes] (when-let [handler (get (:handlers node) id)] (handler (translate-mouse-event event (-> node :bounds :x) (-> node :bounds :y) id)))) id)) (defn- dispatch-mouse-motion* "Dispatches mouse motion events. Returns a new set of nodes which currently are under cursor." [hovered tree root ^java.awt.event.MouseEvent event] (let [x (.getX event) y (.getY event) hovered2 (under-cursor x y tree root) pred #(= (:handle %1) (:handle %2)) exited (remove-all hovered hovered2 pred) entered (remove-all hovered2 hovered pred) moved (remove-all hovered2 entered pred)] (translate-and-dispatch exited event :mouse-exited) (translate-and-dispatch entered event :mouse-entered) (translate-and-dispatch moved event :mouse-moved) hovered2)) (defn- dispatch-mouse-motion [hovered-ref tree root event] (dosync (alter hovered-ref dispatch-mouse-motion* tree root event))) (defn- dispatch-mouse-button* "Dispatches mouse button events. Returns a new set of nodes which currently are picked with a pressed button." [picked hovered event] (if (= (translate-and-dispatch hovered event) :mouse-pressed) hovered nil)) (defn- dispatch-mouse-button [picked-ref hovered-ref event] (dosync (alter picked-ref dispatch-mouse-button* @hovered-ref event))) (defn root-event-dispatcher [] (let [tree-r (ref {}) ; register tree (ref {}) ; dispatch hovered (ref '()) picked (ref '())] (reify EventDispatcher (listen! [this component] (doto component (.addMouseListener this) (.addMouseMotionListener this))) (create-dispatcher [this context handle handlers] (let [node (make-node context handle handlers)] (dosync (alter tree-r add-node node)) node)) (commit [this] (dosync (ref-set tree @tree-r) (ref-set tree-r {}))) MouseListener (mouseEntered [this event] (dispatch-mouse-motion hovered @tree this event)) (mouseExited [this event] (dispatch-mouse-motion hovered @tree this event)) (mouseClicked [this event] (dispatch-mouse-button picked hovered event)) (mousePressed [this event] (dispatch-mouse-button picked hovered event)) (mouseReleased [this event] (dispatch-mouse-button picked hovered event)) MouseMotionListener (mouseDragged [this event] (translate-and-dispatch @picked event)) (mouseMoved [this event] (dispatch-mouse-motion hovered @tree this event))))) ;; ;; ИДЕИ: ;; ;; Контекст: биндинги или запись? ;; ;; Установка обработчиков (в контексте слоя): ;; ;; (listen ;; (:mouse-entered e ;; ...) ;; (:mouse-exited e ;; ...)) ;; ;; Не надо IMGUI. ;; Построение сцены путем декорирования слоев: ;; ;; (listener ;; (:action e (println e)) ;; (:mouse-dragged e (println e)) ;; (theme :font "Helvetica-14" ;; (vbox ;; (button (text-layer "Button 1")) ;; (button (text-layer "Button 2"))))) ;;