Mercurial > hg > indyvon
view src/net/kryshen/indyvon/core.clj @ 55:6adbc03a52cb
Replace *bounds* with *width* and *height*.
author | Mikhail Kryshen <mikhail@kryshen.net> |
---|---|
date | Thu, 19 Aug 2010 20:33:37 +0400 |
parents | 1d2dfe5026a8 |
children | c598c55c89e7 |
line wrap: on
line source
;; ;; Copyright (C) 2010 Mikhail Kryshen <mikhail@kryshen.net> ;; ;; This file is part of Indyvon. ;; (ns net.kryshen.indyvon.core (:import (java.awt Graphics2D Component Color Font AWTEvent Shape) (java.awt.geom AffineTransform Point2D$Double Rectangle2D$Double Area) (java.awt.event MouseListener MouseMotionListener) (java.awt.font FontRenderContext))) (def ^Graphics2D *graphics*) (def ^FontRenderContext *font-context*) (def ^Component *target*) (def *width*) (def *height*) (def ^Shape *clip*) (def *update*) (def *event-dispatcher*) (def ^AffineTransform *initial-transform*) (def ^AffineTransform *inverse-initial-transform*) (defrecord Theme [fore-color back-color alt-back-color border-color font]) (defn default-theme [] (Theme. Color/BLACK Color/LIGHT_GRAY Color/WHITE Color/BLUE (Font. "Sans" Font/PLAIN 12))) (def *theme* (default-theme)) (defrecord Location [x y]) (defrecord Size [width height]) (defrecord Bounds [x y width height]) (defprotocol Layer "Basic UI element." (render! [this]) (layer-size [this])) ;; 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 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 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 net.kryshen.indyvon.core.Layer (anchor [this h-align v-align] (if (and (= h-align :left) (= v-align :top)) (Location. 0 0) (let [size (layer-size this)] (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))))))) (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 "Compute intersection between a pair of rectangles (Bounds)." ([b1 b2] (let [x1 (:x b1) y1 (:y b1) x2 (:x b2) y2 (:y b2)] (intersect x1 y1 (+ x1 (:width b1)) (+ y1 (:height b1)) x2 y2 (+ x2 (:width b2)) (+ y2 (:height b2))))) ([x11 y11 x12 y12, x21 y21 x22 y22] (let [x1 (max x11 x21) y1 (max y11 y21) x2 (min x12 x22) y2 (min y12 y22)] (Bounds. x1 y1 (- x2 x1) (- y2 y1))))) (defn- relative-transform "AffineTransform: layer -> absolute -> component." [] (let [tr (.getTransform *graphics*)] (.preConcatenate tr *inverse-initial-transform*) tr)) (defn- inverse-relative-transform "AffineTransform: component (event) -> absolute -> layer." [] (let [tr (.getTransform *graphics*)] (.invert tr) ; absolute -> layer (.concatenate tr *initial-transform*) ; component -> absolute tr)) (defn clip "Intersect clipping area with the specified shape or bounds. Returns new clip (Shape or nil if empty)." ([x y w h] (clip (Rectangle2D$Double. x y w h))) ([shape] (let [a1 (Area. shape) a2 (if (instance? Area *clip*) *clip* (Area. *clip*))] (.transform a1 (relative-transform)) (.intersect a1 a2) (if (.isEmpty a1) nil a1)))) (defn ^Graphics2D create-graphics ([] (create-graphics 0 0 *width* *height*)) ([x y w h] (apply-theme (.create *graphics* x y w h) *theme*))) (defmacro with-bounds [x y w h & body] `(let [x# ~x, y# ~y w# ~w, h# ~h clip# (clip x# y# w# h#)] (when clip# (let [graphics# (create-graphics x# y# w# h#)] (try (binding [*width* w# *height* h# *clip* clip# *graphics* graphics#] ~@body) (finally (.dispose graphics#))))))) (defmacro with-handlers* [handle handlers & body] `(binding [*event-dispatcher* (create-dispatcher *event-dispatcher* ~handle ~handlers)] ~@body)) (defmacro with-handlers "specs => (:event-id name & handler-body)* Execute form with the specified event handlers." [handle form & specs] `(with-handlers* ~handle ~(reduce (fn [m spec] (assoc m (first spec) `(fn [~(second spec)] ~@(nnext spec)))) {} specs) ~form)) (defn with-theme* [theme f & args] (apply with-bindings* {#'*theme* (merge *theme* theme)} f args)) (defmacro with-theme [theme & body] `(binding [*theme* (merge *theme* ~theme)] ~@body)) (defmacro with-color [color & body] `(let [color# (.getColor *graphics*)] (try (.setColor *graphics* ~color) ~@body (finally (.setColor *graphics* color#))))) ;; TODO: ;; ;; (with-transform ;; (rotate ...) ;; (draw ...) ;; (scale ...) ;; (draw ...)) (defmacro with-transform [transform & body] `(let [old-t# (.getTransform *graphics*)] (try (.transform *graphics* ~transform) ~@body (finally (.setTransform *graphics* old-t#))))) (defmacro with-rotate [theta ax ay & body] `(let [transform# (AffineTransform/getRotateInstance ~theta ~ax ~ay)] (with-transform transform# ~@body))) (defn- geometry-vec [geometry] (if (vector? geometry) geometry [(:x geometry) (:y geometry) (:width geometry) (:height geometry)])) (defn draw! ([layer] (let [graphics (create-graphics)] (try (binding [*graphics* graphics] (render! layer)) (finally (.dispose graphics))))) ([layer x y] (let [size (layer-size layer)] (draw! layer x y (:width size) (:height size)))) ([layer x y width height] (with-bounds x y width height (render! layer)))) (defn draw-anchored! "Draw with location relative to the anchor point." ([layer h-align v-align x y] (let [anchor (anchor layer h-align v-align)] (draw! layer (- x (:x anchor)) (- y (:y anchor))))) ([layer h-align v-align x y w h] (let [anchor (anchor layer h-align v-align)] (draw! layer (- x (:x anchor)) (- y (:y anchor)) w h)))) ;; ;; 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 ^Shape clip ^AffineTransform transform bindings] EventDispatcher (listen! [this component] (listen! parent component)) (create-dispatcher [this handle handlers] (create-dispatcher parent handle handlers)) (commit [this] (commit parent))) (defn- make-node [handle handlers] (DispatcherNode. handle handlers *event-dispatcher* *clip* (inverse-relative-transform) (get-thread-bindings))) (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- under-cursor "Returns a vector of child nodes under cursor." [x y tree node] (some #(if (.contains (:clip %) x y) (conj (vec (under-cursor x y tree %)) %)) (get tree node))) (defn- remove-all [coll1 coll2 pred] (filter #(not (some (partial pred %) coll2)) coll1)) (defn- transform [^AffineTransform tr x y] (let [p (Point2D$Double. x y)] (.transform tr p p) [(.x p) (.y p)])) (defn- translate-mouse-event [^java.awt.event.MouseEvent event ^AffineTransform tr id] (let [[x y] (transform tr (.getX event) (.getY event))] (MouseEvent. id (.getWhen event) x y (.getXOnScreen event) (.getYOnScreen event) (.getButton event)))) (defn- translate-and-dispatch ([nodes first-only ^java.awt.event.MouseEvent event] (translate-and-dispatch nodes first-only event (awt-events (.getID event)))) ([nodes first-only event id] (if-let [node (first nodes)] (if-let [handler (get (:handlers node) id)] (do (with-bindings* (:bindings node) handler (translate-mouse-event event (:transform node) id)) (if-not first-only (recur (rest nodes) false event id))) (recur (rest nodes) first-only event id))))) (defn- dispatch-mouse-motion "Dispatches mouse motion events." [hovered-ref tree root ^java.awt.event.MouseEvent event] (let [x (.getX event) y (.getY event) [hovered hovered2] (dosync [@hovered-ref (ref-set hovered-ref (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 false event :mouse-exited) (translate-and-dispatch entered false event :mouse-entered) (translate-and-dispatch moved true event :mouse-moved))) (defn- dispatch-mouse-button [picked-ref hovered-ref ^java.awt.event.MouseEvent event] (let [id (awt-events (.getID event)) hovered (if (= id :mouse-pressed) (dosync (ref-set picked-ref @hovered-ref)) @hovered-ref)] (translate-and-dispatch hovered true event id))) (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 handle handlers] (let [node (make-node 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] (translate-and-dispatch @picked true event)) ;;(dispatch-mouse-button picked hovered event)) MouseMotionListener (mouseDragged [this event] (translate-and-dispatch @picked true 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"))))) ;;