Mercurial > hg > indyvon
changeset 49:ca728127d605
Use conventional namespace/package name.
| author | Mikhail Kryshen <mikhail@kryshen.net> |
|---|---|
| date | Thu, 29 Jul 2010 01:08:34 +0400 |
| parents | a948ac563f6f |
| children | 409b1b16053d |
| files | project.clj src/kryshen/indyvon/component.clj src/kryshen/indyvon/core.clj src/kryshen/indyvon/demo.clj src/kryshen/indyvon/graph.clj src/kryshen/indyvon/layers.clj src/net/kryshen/indyvon/component.clj src/net/kryshen/indyvon/core.clj src/net/kryshen/indyvon/demo.clj src/net/kryshen/indyvon/graph.clj src/net/kryshen/indyvon/layers.clj test/indyvon/core_test.clj |
| diffstat | 12 files changed, 865 insertions(+), 870 deletions(-) [+] |
line wrap: on
line diff
--- a/project.clj Wed Jul 28 04:47:30 2010 +0400 +++ b/project.clj Thu Jul 29 01:08:34 2010 +0400 @@ -3,7 +3,7 @@ :dependencies [[org.clojure/clojure "1.2.0-beta1"] [org.clojure/clojure-contrib "1.2.0-beta1"]] :dev-dependencies [[swank-clojure/swank-clojure "1.2.1"]] - :namespaces [kryshen.indyvon.core - kryshen.indyvon.layers - kryshen.indyvon.component - kryshen.indyvon.demo]) + :namespaces [net.kryshen.indyvon.core + net.kryshen.indyvon.layers + net.kryshen.indyvon.component + net.kryshen.indyvon.demo])
--- a/src/kryshen/indyvon/component.clj Wed Jul 28 04:47:30 2010 +0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,53 +0,0 @@ -;; -;; Copyright (C) 2010 Mikhail Kryshen <mikhail@kryshen.net> -;; -;; This file is part of Indyvon. -;; - -(ns kryshen.indyvon.component - (:use - kryshen.indyvon.core) - (:import - (kryshen.indyvon.core Size Bounds) - (java.awt Graphics2D Component Dimension Color) - (javax.swing JFrame JPanel))) - -(defn- font-context [^Component component] - (.getFontRenderContext (.getFontMetrics component (.getFont component)))) - -(defn paint-component - [^Component component layer ^Graphics2D graphics event-dispatcher] - (let [size (.getSize component) - width (.width size) - height (.height size)] - (.clearRect graphics 0 0 width height) - (let [bounds (Bounds. 0 0 width height)] - (binding [*graphics* graphics - *font-context* (.getFontRenderContext graphics) - *target* component - *event-dispatcher* event-dispatcher - *update* #(.repaint component) - *bounds* bounds - *clip* bounds] - (render! layer) - (commit event-dispatcher))))) - -(defn preferred-size [component layer] - (binding [*target* component - *font-context*' (font-context component)] - (let [s (layer-size layer)] - (Dimension. (:width s) (:height s))))) - -(defn make-jpanel - ([layer] - (make-jpanel layer (root-event-dispatcher))) - ([layer event-dispatcher] - (let [panel - (proxy [JPanel] [] - (paintComponent [g] - (paint-component this layer g event-dispatcher)) - (getPreferredSize [] - (preferred-size this layer)))] - (.setBackground panel (:back-color *theme*)) - (listen! event-dispatcher panel) - panel)))
--- a/src/kryshen/indyvon/core.clj Wed Jul 28 04:47:30 2010 +0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,341 +0,0 @@ -;; -;; Copyright (C) 2010 Mikhail Kryshen <mikhail@kryshen.net> -;; -;; This file is part of Indyvon. -;; - -(ns kryshen.indyvon.core - (:import - (java.awt Graphics2D Component Color Font AWTEvent) - (java.awt.event MouseListener MouseMotionListener) - (java.awt.font FontRenderContext))) - -(def ^Graphics2D *graphics*) -(def ^FontRenderContext *font-context*) -(def ^Component *target*) -(def *bounds*) -(def *clip*) -(def *update*) -(def *event-dispatcher*) - -(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 - 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 - ([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 ^Graphics2D create-graphics - ([] - (create-graphics 0 0 (:width *bounds*) (:height *bounds*))) - ([x y w h] - (apply-theme (.create *graphics* x y w h) *theme*))) - -(defmacro with-bounds [x y w h & body] - `(let [bounds# (Bounds. (+ ~x (:x *bounds*)) - (+ ~y (:y *bounds*)) - ~w ~h) - clip# (intersect bounds# *clip*)] - (when (and (pos? (:width clip#)) (pos? (:height clip#))) - (let [graphics# (create-graphics ~x ~y ~w ~h)] - (try - (binding [*bounds* bounds# - *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#))))) - -(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 bounds 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* - (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- 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 vector of child nodes under cursor." - [x y tree node] - (some #(if (inside? x y (:bounds %)) - (conj (vec (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 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 - (-> node :bounds :x) (-> node :bounds :y) 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"))))) -;;
--- a/src/kryshen/indyvon/demo.clj Wed Jul 28 04:47:30 2010 +0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,90 +0,0 @@ -;; -;; Copyright (C) 2010 Mikhail Kryshen <mikhail@kryshen.net> -;; -;; This file is part of Indyvon. -;; - -(ns kryshen.indyvon.demo - (:gen-class) - (:use - (kryshen.indyvon core layers component)) - (:import - (kryshen.indyvon.core Size Bounds) - (java.awt Color) - (javax.swing JFrame))) - -(def frame (JFrame. "Test")) - -(def layer1 - (reify - Layer - (render! [layer] - (with-handlers layer - (doto *graphics* - (.setColor Color/RED) - (.fillRect 0 0 (:width *bounds*) (:height *bounds*))) - (:mouse-entered e (println e)) - (:mouse-exited e (println e)) - (:mouse-moved e (println e)))) - (layer-size [layer] (Size. 30 20)))) - -(def layer1b (border layer1 2 3)) - -(def layer2 - (reify - Layer - (render! [layer] - (doto *graphics* - (.setColor Color/YELLOW) - (.fillRect 0 0 (:width *bounds*) (:height *bounds*))) - (draw! layer1b 10 5) - (draw! layer1 55 5)) - (layer-size [layer] (Size. 70 65)))) - -(def layer3 - (border (text-layer "Sample\ntext" :right :center))) - -(defn fps-layer [fps] - (border (text-layer (format "%.1f" fps) :right :bottom) 0 5)) - -(def fps - (let [update-interval 0.1 - frames (ref 0) - last (ref 0) - fl (ref (fps-layer 0.0))] - (reify - Layer - (render! [layer] - (draw! @fl) - (dosync - (alter frames + 1) - (let [time (System/currentTimeMillis) - elapsed (/ (- time @last) 1000.0)] - (when (> elapsed update-interval) - (ref-set fl (fps-layer (/ @frames elapsed))) - (ref-set frames 0) - (ref-set last time))))) - (layer-size [layer] (layer-size @fl))))) - -(def layer - (reify - Layer - (render! [layer] - (*update*) - (doto *graphics* - (.setColor (rand-nth [Color/BLACK Color/BLUE Color/RED])) - (.drawLine 0 0 (:width *bounds*) (:height *bounds*))) - (draw! layer2 15 20) - (draw! layer3 100 100 80 50) - (draw! fps)) - (layer-size [layer] (Size. 400 300)))) - -(defn -main [] - (doto frame - (.addWindowListener - (proxy [java.awt.event.WindowAdapter] [] - (windowClosing [event] (.dispose frame)))) - (.. (getContentPane) (add (make-jpanel (viewport layer)))) - (.pack) - (.setVisible true))) -
--- a/src/kryshen/indyvon/graph.clj Wed Jul 28 04:47:30 2010 +0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,142 +0,0 @@ -;; -;; Copyright (C) 2010 Mikhail Kryshen <mikhail@kryshen.net> -;; -;; This file is part of Indyvon. -;; - -(ns kryshen.indyvon.graph - (:use - (kryshen.indyvon core component layers)) - (:import - (kryshen.indyvon.core Location Size) - (kryshen.indygraph Graph DefaultGraph GraphLayout Vertex2D Edge2D - RectangularVertex2D DefaultEdge2D) - (kryshen.indygraph.fdl ForceDirectedLayout) - (java.awt.geom Path2D$Double) - (javax.swing JFrame))) - -(extend-type Vertex2D - Layer - (render! [v] - (.drawOval *graphics* 0 0 (:width *bounds*) (:height *bounds*))) - (layer-size [v] - (Size. - (+ (.getLeftBound v) (.getRightBound v)) - (+ (.getTopBound v) (.getBottomBound v)))) - Anchored - (anchor [v _ _] - (Location. - (.getLeftBound v) - (.getTopBound v)))) - -(defn- draw-vertices! [^GraphLayout layout x y] - (doseq [v (.vertices (.getGraph layout))] - (draw-anchored! v :center :center (+ x (.getX v)) (+ y (.getY v))))) - -(defn- draw-movable-vertex! - [^Vertex2D v ^GraphLayout layout x y dragged fix-x fix-y] - (let [x (+ x (.getX v)) - y (+ y (.getY v)) - anchor (anchor v :center :center) - size (layer-size v) - x (- x (:x anchor)) - y (- y (:y anchor))] - (with-bounds x y (:width size) (:height size) - (with-handlers v - (draw! v) - (:mouse-pressed e - (dosync (ref-set fix-x (:x-on-screen e)) - (ref-set fix-y (:y-on-screen e)) - (ref-set dragged v))) - (:mouse-released e - (dosync (if (= v @dragged) - (ref-set dragged nil)))) - (:mouse-dragged e - (let [x (:x-on-screen e) - y (:y-on-screen e) - vx (.getX v) - vy (.getY v)] - (dosync - (when @dragged - (let [dx (- x @fix-x) - dy (- y @fix-y)] - (.layoutLocation v (+ vx dx) (+ vy dy)) - (.invalidateLayout layout) - (*update*) - (ref-set fix-x x) - (ref-set fix-y y)))))))))) - -(defn- draw-movable-vertices! - [^GraphLayout layout x y dragged-ref fix-x fix-y] - (let [dragged @dragged-ref] - (doseq [v (.vertices (.getGraph layout)) - :when (not= v dragged)] - (draw-movable-vertex! v layout x y dragged-ref fix-x fix-y)) - ;; Draw the vertex being dragged above others. - (when dragged - (draw-movable-vertex! dragged layout x y dragged-ref fix-x fix-y)))) - -(defn- draw-edges! [^GraphLayout layout x y] - ;; TODO: extend Layer on Edge2D and draw like vertices. - (.translate *graphics* x y) - (let [path (Path2D$Double.)] - (doseq [^Edge2D e (.edges (.getGraph layout))] - (.getPath e path) - (.draw *graphics* path))) - (.translate *graphics* (- x) (- y))) - -(defrecord GraphLayer [layout movable dragged fix-x fix-y] - Layer - (render! [layer] - (let [bounds (.getBounds layout) - x (- (.getX bounds)) - y (- (.getY bounds))] - (draw-edges! layout x y) - (if movable - (draw-movable-vertices! layout x y dragged fix-x fix-y) - (draw-vertices! layout x y)))) - (layer-size [layer] - (let [bounds (.getBounds layout)] - (Size. (.getWidth bounds) (.getHeight bounds)))) - Anchored - (anchor [layer x-align y-align] - (let [bounds (.getBounds layout)] - (Location. (- (.getX bounds)) - (- (.getY bounds)))))) - -(defn graph-layer - ([graph-layout] - (graph-layer graph-layout false)) - ([^GraphLayout graph-layout movable] - (GraphLayer. graph-layout movable (ref nil) (ref 0) (ref 0)))) - -(defn build-graph - "Returns Graph defined by a sequence of pairs of vertex ids, - and a function that maps vertex id's to Vertex objects." - [relations f] - (let [graph (DefaultGraph.) - vs (reduce #(conj %1 (first %2) (second %2)) #{} relations) - vm (reduce #(assoc %1 %2 (f %2)) {} vs) - vs (vals vm) - es (map #(DefaultEdge2D. (vm (first %)) (vm (second %))) relations)] - (doseq [v vs] - (.addVertex graph v)) - (doseq [e es] - (.addEdge graph e)) - graph)) - -(comment - (let [graph (build-graph - [[1 2] [1 3] [1 4] [2 4]] - (fn [_] (RectangularVertex2D. 100 30))) - layout (ForceDirectedLayout. graph) - frame (JFrame. "Graph test") - layer (graph-layer layout true) - layer (viewport layer :center :center)] - (.add (.getContentPane frame) (make-jpanel layer)) - (while (not (.update layout))) - (doto frame - (.setDefaultCloseOperation JFrame/DISPOSE_ON_CLOSE) - (.pack) - (.setVisible true))) - )
--- a/src/kryshen/indyvon/layers.clj Wed Jul 28 04:47:30 2010 +0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,234 +0,0 @@ -;; -;; Copyright (C) 2010 Mikhail Kryshen <mikhail@kryshen.net> -;; -;; This file is part of Indyvon. -;; - -(ns kryshen.indyvon.layers - (:use kryshen.indyvon.core) - (:import (kryshen.indyvon.core Size Location) - (java.lang.ref SoftReference) - (java.awt Font Cursor Image Toolkit) - (java.awt.image ImageObserver) - (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)) - -(defmacro decorate-layer [layer & render-tail] - `(reify - Layer - (render! ~@render-tail) - (layer-size [t#] (layer-size ~layer)) - Anchored - (anchor [t# xa# ya#] (anchor ~layer xa# ya#)))) - -(defn padding - ([content pad] - (padding content pad pad pad pad)) - ([content top left bottom right] - (if (== 0 top left bottom right) - content - (reify - Layer - (render! [l] - (draw! content - left top - (- (:width *bounds*) left right) - (- (:height *bounds*) top bottom))) - (layer-size [l] - (let [s (layer-size content)] - (Size. (+ (:width s) left right) - (+ (:height s) top bottom)))))))) - -(defn border - "Decorate layer with a border." - ([content] - (border content 1)) - ([content width] - (border content width 0)) - ([content width gap] - (let [layer (padding content (+ width gap))] - (decorate-layer layer [_] - (let [w (:width *bounds*) - h (:height *bounds*)] - (with-color (:border-color *theme*) - (doseq [i (range 0 width)] - (.drawRect *graphics* i i (- w 1 i i) (- h 1 i i)))) - (render! layer)))))) - -(defn panel - "Opaque layer using theme's alt-back-color." - ([content] - (panel content 0)) - ([content gap] - (let [layer (padding content gap)] - (decorate-layer layer [_] - (with-color (:alt-back-color *theme*) - (.fillRect *graphics* 0 0 - (:width *bounds*) (:height *bounds*))) - (render! layer))))) - -(defn- re-split [^java.util.regex.Pattern re s] - (seq (.split re s))) - -(def text-layout-cache (atom {})) - -(defn- get-text-layout - [^String line ^Font font ^FontRenderContext font-context] - (let [key [line font font-context]] - (or (if-let [^SoftReference softref (@text-layout-cache key)] - (.get softref) - (do (swap! text-layout-cache dissoc key) - false)) - (let [layout (TextLayout. line font font-context)] - (println "text-layout-cache miss" line) - (swap! text-layout-cache assoc key (SoftReference. layout)) - layout)))) - -(defn- layout-text - [lines ^Font font ^FontRenderContext font-context] - (map #(get-text-layout % font font-context) lines)) - ;;(map #(TextLayout. ^String % font font-context) lines)) - -(defn- text-width [layouts] - (reduce (fn [w ^TextLayout tl] (max w (.getAdvance tl))) 0 layouts)) - -(defn- text-height [layouts] - (reduce (fn [w ^TextLayout tl] (+ w (.getAscent tl) - (.getDescent tl) - (.getLeading tl))) - 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! [layer] - (let [w (:width *bounds*) - h (:height *bounds*) - font (.getFont *graphics*) - layouts (layout-text lines font *font-context*) - y (align-y (text-height layouts) h v-align)] - (loop [layouts layouts, y y] - (when-first [^TextLayout layout layouts] - (let [ascent (.getAscent layout) - lh (+ ascent (.getDescent layout) (.getLeading layout)) - x (align-x (.getAdvance layout) w h-align)] - (.draw layout *graphics* x (+ y ascent)) - (recur (next layouts) (+ y lh))))))) - (layer-size [layer] - (let [layouts (layout-text lines (:font *theme*) *font-context*) - width (text-width layouts) - height (text-height layouts)] - (Size. width height))))))) - -(defn- image-observer [update-fn] - (reify - ImageObserver - (imageUpdate [this img infoflags x y width height] - (update-fn) - (zero? (bit-and infoflags - (bit-or ImageObserver/ALLBITS - ImageObserver/ABORT)))))) - -(defn image-layer - [image-or-uri] - (let [^Image image (if (isa? image-or-uri Image) - image-or-uri - (.getImage (Toolkit/getDefaultToolkit) - ^java.net.URL image-or-uri))] - (.prepareImage (Toolkit/getDefaultToolkit) image -1 -1 nil) - (reify - Layer - (render! [layer] - (.drawImage *graphics* image 0 0 - ^ImageObserver (image-observer *update*))) - (layer-size [layer] - (let [observer (image-observer *update*) - width (.getWidth image observer) - height (.getHeight image observer) - width (if (pos? width) width 1) - height (if (pos? height) height 1)] - (Size. 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] - (with-handlers layer - (let [anchor (anchor content h-align v-align) - width (:width *bounds*) - height (:height *bounds*)] - (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 (- 0 @x (:x anchor)) (- 0 @y (:y anchor)))) - (:mouse-pressed e - (dosync - (ref-set fix-x (:x-on-screen e)) - (ref-set fix-y (:y-on-screen e))) - (->> Cursor/MOVE_CURSOR Cursor. (.setCursor *target*))) - (:mouse-released e - (->> Cursor/DEFAULT_CURSOR Cursor. (.setCursor *target*))) - (:mouse-dragged e - (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*)))) - (layer-size [layer] (layer-size content)))))) - -;; -;; Layer context decorators. -;; - -(defmacro handler [layer & handlers] - `(let [layer# ~layer] - (decorate-layer layer# [t#] - (with-handlers t# - (render! layer#) - ~@handlers)))) - -(defn theme [layer & map-or-keyvals] - (let [theme (if (== (count map-or-keyvals) 1) - map-or-keyvals - (apply array-map map-or-keyvals))] - (reify - Layer - (render! [t] - (with-theme theme - (render! layer))) - (layer-size [t] - (with-theme theme - (layer-size layer))) - Anchored - (anchor [t xa ya] - (with-theme theme - (anchor layer xa ya))))))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/net/kryshen/indyvon/component.clj Thu Jul 29 01:08:34 2010 +0400 @@ -0,0 +1,53 @@ +;; +;; Copyright (C) 2010 Mikhail Kryshen <mikhail@kryshen.net> +;; +;; This file is part of Indyvon. +;; + +(ns net.kryshen.indyvon.component + (:use + net.kryshen.indyvon.core) + (:import + (net.kryshen.indyvon.core Size Bounds) + (java.awt Graphics2D Component Dimension Color) + (javax.swing JFrame JPanel))) + +(defn- font-context [^Component component] + (.getFontRenderContext (.getFontMetrics component (.getFont component)))) + +(defn paint-component + [^Component component layer ^Graphics2D graphics event-dispatcher] + (let [size (.getSize component) + width (.width size) + height (.height size)] + (.clearRect graphics 0 0 width height) + (let [bounds (Bounds. 0 0 width height)] + (binding [*graphics* graphics + *font-context* (.getFontRenderContext graphics) + *target* component + *event-dispatcher* event-dispatcher + *update* #(.repaint component) + *bounds* bounds + *clip* bounds] + (render! layer) + (commit event-dispatcher))))) + +(defn preferred-size [component layer] + (binding [*target* component + *font-context*' (font-context component)] + (let [s (layer-size layer)] + (Dimension. (:width s) (:height s))))) + +(defn make-jpanel + ([layer] + (make-jpanel layer (root-event-dispatcher))) + ([layer event-dispatcher] + (let [panel + (proxy [JPanel] [] + (paintComponent [g] + (paint-component this layer g event-dispatcher)) + (getPreferredSize [] + (preferred-size this layer)))] + (.setBackground panel (:back-color *theme*)) + (listen! event-dispatcher panel) + panel)))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/net/kryshen/indyvon/core.clj Thu Jul 29 01:08:34 2010 +0400 @@ -0,0 +1,341 @@ +;; +;; 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) + (java.awt.event MouseListener MouseMotionListener) + (java.awt.font FontRenderContext))) + +(def ^Graphics2D *graphics*) +(def ^FontRenderContext *font-context*) +(def ^Component *target*) +(def *bounds*) +(def *clip*) +(def *update*) +(def *event-dispatcher*) + +(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 + ([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 ^Graphics2D create-graphics + ([] + (create-graphics 0 0 (:width *bounds*) (:height *bounds*))) + ([x y w h] + (apply-theme (.create *graphics* x y w h) *theme*))) + +(defmacro with-bounds [x y w h & body] + `(let [bounds# (Bounds. (+ ~x (:x *bounds*)) + (+ ~y (:y *bounds*)) + ~w ~h) + clip# (intersect bounds# *clip*)] + (when (and (pos? (:width clip#)) (pos? (:height clip#))) + (let [graphics# (create-graphics ~x ~y ~w ~h)] + (try + (binding [*bounds* bounds# + *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#))))) + +(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 bounds 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* + (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- 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 vector of child nodes under cursor." + [x y tree node] + (some #(if (inside? x y (:bounds %)) + (conj (vec (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 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 + (-> node :bounds :x) (-> node :bounds :y) 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"))))) +;;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/net/kryshen/indyvon/demo.clj Thu Jul 29 01:08:34 2010 +0400 @@ -0,0 +1,89 @@ +;; +;; Copyright (C) 2010 Mikhail Kryshen <mikhail@kryshen.net> +;; +;; This file is part of Indyvon. +;; + +(ns net.kryshen.indyvon.demo + (:gen-class) + (:use + (net.kryshen.indyvon core layers component)) + (:import + (net.kryshen.indyvon.core Size Bounds) + (java.awt Color) + (javax.swing JFrame))) + +(def frame (JFrame. "Test")) + +(def layer1 + (reify + Layer + (render! [layer] + (with-handlers layer + (doto *graphics* + (.setColor Color/RED) + (.fillRect 0 0 (:width *bounds*) (:height *bounds*))) + (:mouse-entered e (println e)) + (:mouse-exited e (println e)) + (:mouse-moved e (println e)))) + (layer-size [layer] (Size. 30 20)))) + +(def layer1b (border layer1 2 3)) + +(def layer2 + (reify + Layer + (render! [layer] + (doto *graphics* + (.setColor Color/YELLOW) + (.fillRect 0 0 (:width *bounds*) (:height *bounds*))) + (draw! layer1b 10 5) + (draw! layer1 55 5)) + (layer-size [layer] (Size. 70 65)))) + +(def layer3 + (border (text-layer "Sample\ntext" :right :center))) + +(defn fps-layer [fps] + (border (text-layer (format "%.1f" fps) :right :bottom) 0 5)) + +(def fps + (let [update-interval 0.1 + frames (ref 0) + last (ref 0) + fl (ref (fps-layer 0.0))] + (reify + Layer + (render! [layer] + (draw! @fl) + (dosync + (alter frames + 1) + (let [time (System/currentTimeMillis) + elapsed (/ (- time @last) 1000.0)] + (when (> elapsed update-interval) + (ref-set fl (fps-layer (/ @frames elapsed))) + (ref-set frames 0) + (ref-set last time))))) + (layer-size [layer] (layer-size @fl))))) + +(def layer + (reify + Layer + (render! [layer] + (*update*) + (doto *graphics* + (.setColor (rand-nth [Color/BLACK Color/BLUE Color/RED])) + (.drawLine 0 0 (:width *bounds*) (:height *bounds*))) + (draw! layer2 15 20) + (draw! layer3 100 100 80 50) + (draw! fps)) + (layer-size [layer] (Size. 400 300)))) + +(defn -main [] + (doto frame + (.addWindowListener + (proxy [java.awt.event.WindowAdapter] [] + (windowClosing [event] (.dispose frame)))) + (.. (getContentPane) (add (make-jpanel (viewport layer)))) + (.pack) + (.setVisible true)))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/net/kryshen/indyvon/graph.clj Thu Jul 29 01:08:34 2010 +0400 @@ -0,0 +1,142 @@ +;; +;; Copyright (C) 2010 Mikhail Kryshen <mikhail@kryshen.net> +;; +;; This file is part of Indyvon. +;; + +(ns net.kryshen.indyvon.graph + (:use + (net.kryshen.indyvon core component layers)) + (:import + (net.kryshen.indyvon.core Location Size) + (net.kryshen.indygraph Graph DefaultGraph GraphLayout Vertex2D + Edge2D RectangularVertex2D DefaultEdge2D) + (net.kryshen.indygraph.fdl ForceDirectedLayout) + (java.awt.geom Path2D$Double) + (javax.swing JFrame))) + +(extend-type Vertex2D + Layer + (render! [v] + (.drawOval *graphics* 0 0 (:width *bounds*) (:height *bounds*))) + (layer-size [v] + (Size. + (+ (.getLeftBound v) (.getRightBound v)) + (+ (.getTopBound v) (.getBottomBound v)))) + Anchored + (anchor [v _ _] + (Location. + (.getLeftBound v) + (.getTopBound v)))) + +(defn- draw-vertices! [^GraphLayout layout x y] + (doseq [v (.vertices (.getGraph layout))] + (draw-anchored! v :center :center (+ x (.getX v)) (+ y (.getY v))))) + +(defn- draw-movable-vertex! + [^Vertex2D v ^GraphLayout layout x y dragged fix-x fix-y] + (let [x (+ x (.getX v)) + y (+ y (.getY v)) + anchor (anchor v :center :center) + size (layer-size v) + x (- x (:x anchor)) + y (- y (:y anchor))] + (with-bounds x y (:width size) (:height size) + (with-handlers v + (draw! v) + (:mouse-pressed e + (dosync (ref-set fix-x (:x-on-screen e)) + (ref-set fix-y (:y-on-screen e)) + (ref-set dragged v))) + (:mouse-released e + (dosync (if (= v @dragged) + (ref-set dragged nil)))) + (:mouse-dragged e + (let [x (:x-on-screen e) + y (:y-on-screen e) + vx (.getX v) + vy (.getY v)] + (dosync + (when @dragged + (let [dx (- x @fix-x) + dy (- y @fix-y)] + (.layoutLocation v (+ vx dx) (+ vy dy)) + (.invalidateLayout layout) + (*update*) + (ref-set fix-x x) + (ref-set fix-y y)))))))))) + +(defn- draw-movable-vertices! + [^GraphLayout layout x y dragged-ref fix-x fix-y] + (let [dragged @dragged-ref] + (doseq [v (.vertices (.getGraph layout)) + :when (not= v dragged)] + (draw-movable-vertex! v layout x y dragged-ref fix-x fix-y)) + ;; Draw the vertex being dragged above others. + (when dragged + (draw-movable-vertex! dragged layout x y dragged-ref fix-x fix-y)))) + +(defn- draw-edges! [^GraphLayout layout x y] + ;; TODO: extend Layer on Edge2D and draw like vertices. + (.translate *graphics* x y) + (let [path (Path2D$Double.)] + (doseq [^Edge2D e (.edges (.getGraph layout))] + (.getPath e path) + (.draw *graphics* path))) + (.translate *graphics* (- x) (- y))) + +(defrecord GraphLayer [layout movable dragged fix-x fix-y] + Layer + (render! [layer] + (let [bounds (.getBounds layout) + x (- (.getX bounds)) + y (- (.getY bounds))] + (draw-edges! layout x y) + (if movable + (draw-movable-vertices! layout x y dragged fix-x fix-y) + (draw-vertices! layout x y)))) + (layer-size [layer] + (let [bounds (.getBounds layout)] + (Size. (.getWidth bounds) (.getHeight bounds)))) + Anchored + (anchor [layer x-align y-align] + (let [bounds (.getBounds layout)] + (Location. (- (.getX bounds)) + (- (.getY bounds)))))) + +(defn graph-layer + ([graph-layout] + (graph-layer graph-layout false)) + ([^GraphLayout graph-layout movable] + (GraphLayer. graph-layout movable (ref nil) (ref 0) (ref 0)))) + +(defn build-graph + "Returns Graph defined by a sequence of pairs of vertex ids, + and a function that maps vertex id's to Vertex objects." + [relations f] + (let [graph (DefaultGraph.) + vs (reduce #(conj %1 (first %2) (second %2)) #{} relations) + vm (reduce #(assoc %1 %2 (f %2)) {} vs) + vs (vals vm) + es (map #(DefaultEdge2D. (vm (first %)) (vm (second %))) relations)] + (doseq [v vs] + (.addVertex graph v)) + (doseq [e es] + (.addEdge graph e)) + graph)) + +(comment + (let [graph (build-graph + [[1 2] [1 3] [1 4] [2 4]] + (fn [_] (RectangularVertex2D. 100 30))) + layout (ForceDirectedLayout. graph) + frame (JFrame. "Graph test") + layer (graph-layer layout true) + layer (viewport layer :center :center)] + (.add (.getContentPane frame) (make-jpanel layer)) + (while (not (.update layout))) + (doto frame + (.setDefaultCloseOperation JFrame/DISPOSE_ON_CLOSE) + (.pack) + (.setVisible true))) + )
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/net/kryshen/indyvon/layers.clj Thu Jul 29 01:08:34 2010 +0400 @@ -0,0 +1,236 @@ +;; +;; Copyright (C) 2010 Mikhail Kryshen <mikhail@kryshen.net> +;; +;; This file is part of Indyvon. +;; + +(ns net.kryshen.indyvon.layers + (:use + net.kryshen.indyvon.core) + (:import + (net.kryshen.indyvon.core Size Location) + (java.lang.ref SoftReference) + (java.awt Font Cursor Image Toolkit) + (java.awt.image ImageObserver) + (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)) + +(defmacro decorate-layer [layer & render-tail] + `(reify + Layer + (render! ~@render-tail) + (layer-size [t#] (layer-size ~layer)) + Anchored + (anchor [t# xa# ya#] (anchor ~layer xa# ya#)))) + +(defn padding + ([content pad] + (padding content pad pad pad pad)) + ([content top left bottom right] + (if (== 0 top left bottom right) + content + (reify + Layer + (render! [l] + (draw! content + left top + (- (:width *bounds*) left right) + (- (:height *bounds*) top bottom))) + (layer-size [l] + (let [s (layer-size content)] + (Size. (+ (:width s) left right) + (+ (:height s) top bottom)))))))) + +(defn border + "Decorate layer with a border." + ([content] + (border content 1)) + ([content width] + (border content width 0)) + ([content width gap] + (let [layer (padding content (+ width gap))] + (decorate-layer layer [_] + (let [w (:width *bounds*) + h (:height *bounds*)] + (with-color (:border-color *theme*) + (doseq [i (range 0 width)] + (.drawRect *graphics* i i (- w 1 i i) (- h 1 i i)))) + (render! layer)))))) + +(defn panel + "Opaque layer using theme's alt-back-color." + ([content] + (panel content 0)) + ([content gap] + (let [layer (padding content gap)] + (decorate-layer layer [_] + (with-color (:alt-back-color *theme*) + (.fillRect *graphics* 0 0 + (:width *bounds*) (:height *bounds*))) + (render! layer))))) + +(defn- re-split [^java.util.regex.Pattern re s] + (seq (.split re s))) + +(def text-layout-cache (atom {})) + +(defn- get-text-layout + [^String line ^Font font ^FontRenderContext font-context] + (let [key [line font font-context]] + (or (if-let [^SoftReference softref (@text-layout-cache key)] + (.get softref) + (do (swap! text-layout-cache dissoc key) + false)) + (let [layout (TextLayout. line font font-context)] + ;;(println "text-layout-cache miss" line) + (swap! text-layout-cache assoc key (SoftReference. layout)) + layout)))) + +(defn- layout-text + [lines ^Font font ^FontRenderContext font-context] + (map #(get-text-layout % font font-context) lines)) + ;;(map #(TextLayout. ^String % font font-context) lines)) + +(defn- text-width [layouts] + (reduce (fn [w ^TextLayout tl] (max w (.getAdvance tl))) 0 layouts)) + +(defn- text-height [layouts] + (reduce (fn [w ^TextLayout tl] (+ w (.getAscent tl) + (.getDescent tl) + (.getLeading tl))) + 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! [layer] + (let [w (:width *bounds*) + h (:height *bounds*) + font (.getFont *graphics*) + layouts (layout-text lines font *font-context*) + y (align-y (text-height layouts) h v-align)] + (loop [layouts layouts, y y] + (when-first [^TextLayout layout layouts] + (let [ascent (.getAscent layout) + lh (+ ascent (.getDescent layout) (.getLeading layout)) + x (align-x (.getAdvance layout) w h-align)] + (.draw layout *graphics* x (+ y ascent)) + (recur (next layouts) (+ y lh))))))) + (layer-size [layer] + (let [layouts (layout-text lines (:font *theme*) *font-context*) + width (text-width layouts) + height (text-height layouts)] + (Size. width height))))))) + +(defn- image-observer [update-fn] + (reify + ImageObserver + (imageUpdate [this img infoflags x y width height] + (update-fn) + (zero? (bit-and infoflags + (bit-or ImageObserver/ALLBITS + ImageObserver/ABORT)))))) + +(defn image-layer + [image-or-uri] + (let [^Image image (if (isa? image-or-uri Image) + image-or-uri + (.getImage (Toolkit/getDefaultToolkit) + ^java.net.URL image-or-uri))] + (.prepareImage (Toolkit/getDefaultToolkit) image -1 -1 nil) + (reify + Layer + (render! [layer] + (.drawImage *graphics* image 0 0 + ^ImageObserver (image-observer *update*))) + (layer-size [layer] + (let [observer (image-observer *update*) + width (.getWidth image observer) + height (.getHeight image observer) + width (if (pos? width) width 1) + height (if (pos? height) height 1)] + (Size. 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] + (with-handlers layer + (let [anchor (anchor content h-align v-align) + width (:width *bounds*) + height (:height *bounds*)] + (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 (- 0 @x (:x anchor)) (- 0 @y (:y anchor)))) + (:mouse-pressed e + (dosync + (ref-set fix-x (:x-on-screen e)) + (ref-set fix-y (:y-on-screen e))) + (->> Cursor/MOVE_CURSOR Cursor. (.setCursor *target*))) + (:mouse-released e + (->> Cursor/DEFAULT_CURSOR Cursor. (.setCursor *target*))) + (:mouse-dragged e + (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*)))) + (layer-size [layer] (layer-size content)))))) + +;; +;; Layer context decorators. +;; + +(defmacro handler [layer & handlers] + `(let [layer# ~layer] + (decorate-layer layer# [t#] + (with-handlers t# + (render! layer#) + ~@handlers)))) + +(defn theme [layer & map-or-keyvals] + (let [theme (if (== (count map-or-keyvals) 1) + map-or-keyvals + (apply array-map map-or-keyvals))] + (reify + Layer + (render! [t] + (with-theme theme + (render! layer))) + (layer-size [t] + (with-theme theme + (layer-size layer))) + Anchored + (anchor [t xa ya] + (with-theme theme + (anchor layer xa ya))))))