Mercurial > hg > indyvon
changeset 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 |
| files | project.clj src/indyvon/component.clj src/indyvon/core.clj src/indyvon/event.clj src/indyvon/layers.clj |
| diffstat | 5 files changed, 304 insertions(+), 273 deletions(-) [+] |
line wrap: on
line diff
--- a/project.clj Mon Jun 21 01:18:50 2010 +0400 +++ b/project.clj Mon Jun 21 04:00:45 2010 +0400 @@ -1,8 +1,8 @@ (defproject indyvon "1.0.0-SNAPSHOT" - :description "FIXME: write" + :description "INteractive DYnamic VisualizatiON library" :dependencies [[org.clojure/clojure "1.2.0-master-SNAPSHOT"] [org.clojure/clojure-contrib "1.2.0-SNAPSHOT"]] :dev-dependencies [[leiningen/lein-swank "1.2.0-SNAPSHOT"]] :namespaces [indyvon.core - indyvon.event + indyvon.layers indyvon.component])
--- a/src/indyvon/component.clj Mon Jun 21 01:18:50 2010 +0400 +++ b/src/indyvon/component.clj Mon Jun 21 04:00:45 2010 +0400 @@ -5,10 +5,8 @@ ;; (ns indyvon.component - (:use indyvon.core) - (:require (indyvon [event :as event])) + (:use indyvon.core indyvon.layers) (:import (java.awt Component Dimension Color) - (java.awt.event MouseEvent) (javax.swing JFrame JPanel))) (defn- font-context [component] @@ -35,7 +33,7 @@ (defn make-jpanel ([layer] - (make-jpanel layer (event/make-event-dispatcher))) + (make-jpanel layer (make-event-dispatcher))) ([layer event-dispatcher] (let [context (default-context) context (assoc context :dispatcher event-dispatcher) @@ -53,9 +51,6 @@ (do (def frame (JFrame. "Test")) - (defn handler [event context] - (println (:layer context) (.paramString event))) - (def layer1 (reify Layer @@ -65,7 +60,7 @@ (size [this context] [30 20]) MouseHandler (handle-mouse [this context event] - (println "layer1" (.paramString event))))) + (println "layer1" event)))) (def layer1b (border-layer layer1 2 3)) @@ -80,7 +75,7 @@ (size [this context] [70 65]) MouseHandler (handle-mouse [this context event] - (println "layer2" (.paramString event))))) + (println "layer2" event)))) (def layer3 (border-layer (text-layer "Sample\ntext" :right :center)))
--- a/src/indyvon/core.clj Mon Jun 21 01:18:50 2010 +0400 +++ b/src/indyvon/core.clj Mon Jun 21 04:00:45 2010 +0400 @@ -5,15 +5,17 @@ ;; (ns indyvon.core - (:import (java.awt Color Font Cursor) - (java.awt.font FontRenderContext TextLayout) - (java.awt.event MouseEvent))) + (: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])) @@ -25,6 +27,29 @@ (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 [] @@ -81,134 +106,151 @@ (.dispose graphics)))))) ;; -;; Layer implementations. +;; EventDispatcher implementation ;; -(defn border-layer - "Decorate layer with a border." - ([content] - (border-layer content 1)) - ([content width] - (border-layer content width 0)) - ([content width gap] - (let [offset (+ width gap)] - (reify Layer - (render! [l c g] - (let [w (:width c) - h (:height c)] - (.setColor g (-> c :theme :border-color)) - (doseq [i (range 0 width)] - (.drawRect g i i (- w 1 i i) (- h 1 i i))) - (draw! content c g offset offset (- w offset offset) - (- h offset offset)))) - (size [l c] - (let [s (size content c)] - [(+ (s 0) offset offset) - (+ (s 1) offset offset)])))))) +(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))) -;; Define as macro to avoid unnecessary calculation of inner and outer -;; sizes in the first case. -(defmacro align-xy [inner outer align first center last] - `(case ~align - ~first 0 - ~center (/ (- ~outer ~inner) 2) - ~last (- ~outer ~inner))) +(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))))) -(defmacro align-x [inner outer align] - `(align-xy ~inner ~outer ~align :left :center :right)) +(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)))) -(defmacro align-y [inner outer align] - `(align-xy ~inner ~outer ~align :top :center :bottom)) - -(defn- re-split [re s] - (seq (.split re s))) +(defn- remove-all [coll1 coll2 pred] + (filter #(not (some (partial pred %) coll2)) coll1)) -(defn- layout-text [lines font font-context] - (map #(TextLayout. % font font-context) lines)) +;; (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- text-width [layouts] - (reduce #(max %1 (.getAdvance %2)) 0 layouts)) - -(defn- text-height [layouts] - (reduce #(+ %1 (.getAscent %2) (.getDescent %2) (.getLeading %2)) - 0 layouts)) +(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 text-layer - "Creates a layer to display multiline text." - ([text] - (text-layer text :left :top)) - ([text h-align v-align] - (let [lines (re-split #"\r\n|\n|\r|\u0085|\u2028|\u2029" text)] - (reify Layer - (render! [l c g] - (let [w (:width c) - h (:height c) - font (.getFont g) - font-context (:font-context c) - layouts (layout-text lines font font-context) - y (align-y (text-height layouts) h v-align)] - (loop [layouts layouts, y y] - (when-first [layout layouts] - (let [ascent (.getAscent layout) - lh (+ ascent (.getDescent layout) (.getLeading layout)) - x (align-x (.getAdvance layout) w h-align)] - (.draw layout g x (+ y ascent)) - (recur (next layouts) (+ y lh))))))) - (size [l c] - (let [layouts (layout-text lines - (-> c :theme :font) - (:font-context c)) - width (text-width layouts) - height (text-height layouts)] - [width height])))))) +(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)) -(defprotocol Anchored - "Provide anchor point for Layers. Used by viewport." - (anchor [this context] "Anchor point: [x y]")) +(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)) -;; Default implementation of Anchored for any Layer. -(extend-protocol Anchored - indyvon.core.Layer - (anchor [this context] [0 0])) +(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 viewport - "Creates scrollable viewport layer." - ([content] (viewport content :left :top)) - ([content h-align v-align] - (let [x (ref 0) - y (ref 0) - fix-x (ref 0) - fix-y (ref 0) - last-width (ref 0) - last-height (ref 0)] +(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 - Layer - (render! [layer c g] - (let [anchor (anchor content c) - width (:width c) - height (:height c)] - (dosync - (alter x + (align-x width @last-width h-align)) - (alter y + (align-y height @last-height v-align)) - (ref-set last-width width) - (ref-set last-height height)) - (draw! content c g - (- 0 @x (anchor 0)) - (- 0 @y (anchor 1))))) - (size [layer c] (size content c)) - MouseHandler - (handle-mouse [layer c e] - (when (= (.getID e) MouseEvent/MOUSE_PRESSED) - (dosync - (ref-set fix-x (.getXOnScreen e)) - (ref-set fix-y (.getYOnScreen e))) - (->> Cursor/MOVE_CURSOR Cursor. (.setCursor (:target c)))) - (when (= (.getID e) MouseEvent/MOUSE_RELEASED) - (->> Cursor/DEFAULT_CURSOR Cursor. (.setCursor (:target c)))) - (when (= (.getID e) MouseEvent/MOUSE_DRAGGED) - (dosync - (alter x + (- @fix-x (.getXOnScreen e))) - (alter y + (- @fix-y (.getYOnScreen e))) - (ref-set fix-x (.getXOnScreen e)) - (ref-set fix-y (.getYOnScreen e))) - (update c))))))) + 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)))))
--- a/src/indyvon/event.clj Mon Jun 21 01:18:50 2010 +0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,140 +0,0 @@ -;; -;; Copyright (C) 2010 Mikhail Kryshen <mikhail@kryshen.net> -;; -;; This file is part of Indyvon. -;; - -(ns indyvon.event - (:use indyvon.core) - (:import (java.awt.event MouseEvent MouseListener MouseMotionListener) - java.lang.ref.WeakReference)) - -(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-and-dispatch - ([contexts event] - (translate-and-dispatch contexts event (.getID event))) - ([contexts event id] - (doseq [context contexts] - (handle-mouse - (:layer context) context - (translate-mouse-event event (:x context) (:y context) 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 MouseEvent/MOUSE_EXITED) - (translate-and-dispatch entered event MouseEvent/MOUSE_ENTERED) - (translate-and-dispatch moved event MouseEvent/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] - (translate-and-dispatch hovered event) - (if (= (.getID event) MouseEvent/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)))))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/indyvon/layers.clj Mon Jun 21 04:00:45 2010 +0400 @@ -0,0 +1,134 @@ +;; +;; Copyright (C) 2010 Mikhail Kryshen <mikhail@kryshen.net> +;; +;; This file is part of Indyvon. +;; + +(ns indyvon.layers + (:use indyvon.core) + (:import (java.awt Cursor) + (java.awt.font FontRenderContext TextLayout))) + +;; Define as macro to avoid unnecessary calculation of inner and outer +;; sizes in the first case. +(defmacro align-xy [inner outer align first center last] + `(case ~align + ~first 0 + ~center (/ (- ~outer ~inner) 2) + ~last (- ~outer ~inner))) + +(defmacro align-x [inner outer align] + `(align-xy ~inner ~outer ~align :left :center :right)) + +(defmacro align-y [inner outer align] + `(align-xy ~inner ~outer ~align :top :center :bottom)) + +(defn border-layer + "Decorate layer with a border." + ([content] + (border-layer content 1)) + ([content width] + (border-layer content width 0)) + ([content width gap] + (let [offset (+ width gap)] + (reify Layer + (render! [l c g] + (let [w (:width c) + h (:height c)] + (.setColor g (-> c :theme :border-color)) + (doseq [i (range 0 width)] + (.drawRect g i i (- w 1 i i) (- h 1 i i))) + (draw! content c g offset offset (- w offset offset) + (- h offset offset)))) + (size [l c] + (let [s (size content c)] + [(+ (s 0) offset offset) + (+ (s 1) offset offset)])))))) + +(defn- re-split [re s] + (seq (.split re s))) + +(defn- layout-text [lines font font-context] + (map #(TextLayout. % font font-context) lines)) + +(defn- text-width [layouts] + (reduce #(max %1 (.getAdvance %2)) 0 layouts)) + +(defn- text-height [layouts] + (reduce #(+ %1 (.getAscent %2) (.getDescent %2) (.getLeading %2)) + 0 layouts)) + +(defn text-layer + "Creates a layer to display multiline text." + ([text] + (text-layer text :left :top)) + ([text h-align v-align] + (let [lines (re-split #"\r\n|\n|\r|\u0085|\u2028|\u2029" text)] + (reify Layer + (render! [l c g] + (let [w (:width c) + h (:height c) + font (.getFont g) + font-context (:font-context c) + layouts (layout-text lines font font-context) + y (align-y (text-height layouts) h v-align)] + (loop [layouts layouts, y y] + (when-first [layout layouts] + (let [ascent (.getAscent layout) + lh (+ ascent (.getDescent layout) (.getLeading layout)) + x (align-x (.getAdvance layout) w h-align)] + (.draw layout g x (+ y ascent)) + (recur (next layouts) (+ y lh))))))) + (size [l c] + (let [layouts (layout-text lines + (-> c :theme :font) + (:font-context c)) + width (text-width layouts) + height (text-height layouts)] + [width height])))))) + +(defn viewport + "Creates scrollable viewport layer." + ([content] (viewport content :left :top)) + ([content h-align v-align] + (let [x (ref 0) + y (ref 0) + fix-x (ref 0) + fix-y (ref 0) + last-width (ref 0) + last-height (ref 0)] + (reify + Layer + (render! [layer c g] + (let [anchor (anchor content c h-align v-align) + width (:width c) + height (:height c)] + (dosync + (alter x + (align-x width @last-width h-align)) + (alter y + (align-y height @last-height v-align)) + (ref-set last-width width) + (ref-set last-height height)) + (draw! content c g + (- 0 @x (anchor 0)) + (- 0 @y (anchor 1))))) + (size [layer c] (size content c)) + MouseHandler + (handle-mouse [layer c e] + (case (:id e) + :mouse-pressed + (do + (dosync + (ref-set fix-x (:x-on-screen e)) + (ref-set fix-y (:y-on-screen e))) + (->> Cursor/MOVE_CURSOR Cursor. (.setCursor (:target c)))) + :mouse-released + (->> Cursor/DEFAULT_CURSOR Cursor. (.setCursor (:target c))) + :mouse-dragged + (do + (dosync + (alter x + (- @fix-x (:x-on-screen e))) + (alter y + (- @fix-y (:y-on-screen e))) + (ref-set fix-x (:x-on-screen e)) + (ref-set fix-y (:y-on-screen e))) + (update c)) + nil))))))