Mercurial > hg > indyvon
view src/indyvon/core.clj @ 26:1237f7555029
Rearranged namespaces.
Mouse events represented by a record.
Added alignment args to anchor.
author | Mikhail Kryshen <mikhail@kryshen.net> |
---|---|
date | Mon, 21 Jun 2010 04:00:45 +0400 |
parents | 07ee065cbb3e |
children | 61bc04f94d61 4cb70c5a6e0d |
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 Color Font) (java.awt.event MouseListener MouseMotionListener))) (defprotocol Layer "Basic UI element." (render! [this context graphics]) (size [this context])) ;; TODO: modifiers (defrecord MouseEvent [id when x y x-on-screen y-on-screen button]) (defprotocol MouseHandler "Layers that also satisfy this protocol will recieve mouse events." (handle-mouse [this context event])) (defprotocol EventDispatcher (listen! [this component]) (register [this context]) (commit [this]) (hovered? [this layer]) (picked? [this layer])) (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)) [0 0] (let [size (size this context)] [(case h-align :top 0 :center (/ (size 0) 2) :right (size 0)) (case v-align :left 0 :center (/ (size 1) 2) :bottom (size 1))])))) (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 [layer parent x y width height update-fn dispatcher font-context theme target]) (defn default-context [] (LayerContext. nil nil 0 0 0 0 nil nil nil (default-theme) nil)) (defn update [context] ((:update-fn context))) (defn- make-graphics [graphics x y w h clip] (if clip (.create graphics x y w h) (doto (.create graphics) (.translate x y)))) (defn- apply-theme [graphics theme] (doto graphics (.setColor (:fore-color theme)) (.setFont (:font theme)))) (defn draw! "Render layer in a new graphics context." ([layer context graphics] (draw! layer context graphics 0 0 (:width context) (:height context))) ([layer context graphics x y] (draw! layer context graphics x y true)) ([layer context graphics x y clip] (let [s (size layer context)] (draw! layer context graphics x y (s 0) (s 1) clip))) ([layer context graphics x y w h] (draw! layer context graphics x y w h true)) ([layer context graphics x y w h clip] (let [context (assoc context :layer layer :parent context :x (+ (:x context) x) :y (+ (:y context) y) :width w :height h) graphics (make-graphics graphics x y w h clip) graphics (apply-theme graphics (:theme context))] (try (register (:dispatcher context) context) (render! layer context graphics) (finally (.dispose graphics)))))) ;; ;; 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}) (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- add-context [context-tree context] (let [parent (registered-parent context-tree context)] (assoc context-tree parent (cons context (context-tree parent)) context nil))) (defn- inside? ([x y context] (inside? x y (:x context) (:y context) (:width context) (:height context))) ([px py x y w h] (and (>= px x) (>= py y) (< px (+ x w)) (< py (+ y h))))) (defn- under-cursor "Returns a sequence of contexts under cursor." ([context-tree x y] (under-cursor context-tree x y nil)) ([context-tree x y context] (some #(if (inside? x y %) (conj (under-cursor context-tree x y %) %)) (context-tree context)))) (defn- remove-all [coll1 coll2 pred] (filter #(not (some (partial pred %) coll2)) coll1)) ;; (defn- translate-mouse-event ;; [event x y id] ;; (proxy [MouseEvent] [(.getComponent event) ;; id ;; (.getWhen event) ;; (.getModifiers event) ;; (- (.getX event) x) ;; (- (.getY event) y) ;; (.getClickCount event) ;; (.isPopupTrigger event)] ;; (getXOnScreen [] (.getXOnScreen event)) ;; (getYOnScreen [] (.getYOnScreen event)))) (defn- translate-mouse-event [event x y id] (MouseEvent. id (.getWhen event) (- (.getX event) x) (- (.getY event) y) (.getXOnScreen event) (.getYOnScreen event) (.getButton event))) (defn- translate-and-dispatch ([contexts event] (translate-and-dispatch contexts event (awt-events (.getID event)))) ([contexts event id] (doseq [context contexts] (handle-mouse (:layer context) context (translate-mouse-event event (:x context) (:y context) id))) id)) (defn- dispatch-mouse-motion* "Dispatches mouse motion events. Returns a new set of contexts which currently are under cursor." [hovered context-tree event] (let [x (.getX event) y (.getY event) hovered2 (under-cursor context-tree x y) pred #(= (:layer %1) (:layer %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 context-tree event] (dosync (alter hovered-ref dispatch-mouse-motion* context-tree event))) (defn- dispatch-mouse-button* "Dispatches mouse button events. Returns a new set of contexts 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 make-event-dispatcher [] (let [context-tree-r (ref {}) ; register context-tree (ref {}) ; dispatch hovered (ref '()) picked (ref '())] (reify EventDispatcher (listen! [this component] (doto component (.addMouseListener this) (.addMouseMotionListener this))) (register [this context] (when (satisfies? MouseHandler (:layer context)) (dosync (alter context-tree-r add-context context)))) (commit [this] (dosync (ref-set context-tree @context-tree-r) (ref-set context-tree-r {}))) (picked? [this layer] false) (hovered? [this layer] false) MouseListener (mouseEntered [this event] (dispatch-mouse-motion hovered @context-tree event)) (mouseExited [this event] (dispatch-mouse-motion hovered @context-tree 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 @context-tree event)))))