Mercurial > hg > indyvon

view src/net/kryshen/indyvon/graph.clj @ 56:87400ec6d433

find changesets by author, revision, files, or words in the commit message
Update to clojure 1.2.0.
author Mikhail Kryshen <mikhail@kryshen.net>
date Fri, 20 Aug 2010 03:08:02 +0400
parents
children
line source
1 ;;
2 ;; Copyright (C) 2010 Mikhail Kryshen <mikhail@kryshen.net>
3 ;;
4 ;; This file is part of Indyvon.
5 ;;
6
7 (ns net.kryshen.indyvon.graph
8 (:use
9 (net.kryshen.indyvon core component layers))
10 (:import
11 (net.kryshen.indyvon.core Location Size)
12 (net.kryshen.indygraph Graph DefaultGraph GraphLayout Vertex2D
13 Edge2D RectangularVertex2D DefaultEdge2D)
14 (net.kryshen.indygraph.fdl ForceDirectedLayout)
15 (java.awt.geom Path2D$Double)
16 (javax.swing JFrame)))
17
18 (extend-type Vertex2D
19 Layer
20 (render! [v]
21 (.drawOval *graphics* 0 0 (:width *bounds*) (:height *bounds*)))
22 (layer-size [v]
23 (Size.
24 (+ (.getLeftBound v) (.getRightBound v))
25 (+ (.getTopBound v) (.getBottomBound v))))
26 Anchored
27 (anchor [v _ _]
28 (Location.
29 (.getLeftBound v)
30 (.getTopBound v))))
31
32 (defn- draw-vertices! [^GraphLayout layout x y]
33 (doseq [v (.vertices (.getGraph layout))]
34 (draw-anchored! v :center :center (+ x (.getX v)) (+ y (.getY v)))))
35
36 (defn- draw-movable-vertex!
37 [^Vertex2D v ^GraphLayout layout x y dragged fix-x fix-y]
38 (let [x (+ x (.getX v))
39 y (+ y (.getY v))
40 anchor (anchor v :center :center)
41 size (layer-size v)
42 x (- x (:x anchor))
43 y (- y (:y anchor))]
44 (with-bounds x y (:width size) (:height size)
45 (with-handlers v
46 (draw! v)
47 (:mouse-pressed e
48 (dosync (ref-set fix-x (:x-on-screen e))
49 (ref-set fix-y (:y-on-screen e))
50 (ref-set dragged v)))
51 (:mouse-released e
52 (dosync (if (= v @dragged)
53 (ref-set dragged nil))))
54 (:mouse-dragged e
55 (let [x (:x-on-screen e)
56 y (:y-on-screen e)
57 vx (.getX v)
58 vy (.getY v)]
59 (dosync
60 (when @dragged
61 (let [dx (- x @fix-x)
62 dy (- y @fix-y)]
63 (.layoutLocation v (+ vx dx) (+ vy dy))
64 (.invalidateLayout layout)
65 (*update*)
66 (ref-set fix-x x)
67 (ref-set fix-y y))))))))))
68
69 (defn- draw-movable-vertices!
70 [^GraphLayout layout x y dragged-ref fix-x fix-y]
71 (let [dragged @dragged-ref]
72 (doseq [v (.vertices (.getGraph layout))
73 :when (not= v dragged)]
74 (draw-movable-vertex! v layout x y dragged-ref fix-x fix-y))
75 ;; Draw the vertex being dragged above others.
76 (when dragged
77 (draw-movable-vertex! dragged layout x y dragged-ref fix-x fix-y))))
78
79 (defn- draw-edges! [^GraphLayout layout x y]
80 ;; TODO: extend Layer on Edge2D and draw like vertices.
81 (.translate *graphics* x y)
82 (let [path (Path2D$Double.)]
83 (doseq [^Edge2D e (.edges (.getGraph layout))]
84 (.getPath e path)
85 (.draw *graphics* path)))
86 (.translate *graphics* (- x) (- y)))
87
88 (defrecord GraphLayer [layout movable dragged fix-x fix-y]
89 Layer
90 (render! [layer]
91 (let [bounds (.getBounds layout)
92 x (- (.getX bounds))
93 y (- (.getY bounds))]
94 (draw-edges! layout x y)
95 (if movable
96 (draw-movable-vertices! layout x y dragged fix-x fix-y)
97 (draw-vertices! layout x y))))
98 (layer-size [layer]
99 (let [bounds (.getBounds layout)]
100 (Size. (.getWidth bounds) (.getHeight bounds))))
101 Anchored
102 (anchor [layer x-align y-align]
103 (let [bounds (.getBounds layout)]
104 (Location. (- (.getX bounds))
105 (- (.getY bounds))))))
106
107 (defn graph-layer
108 ([graph-layout]
109 (graph-layer graph-layout false))
110 ([^GraphLayout graph-layout movable]
111 (GraphLayer. graph-layout movable (ref nil) (ref 0) (ref 0))))
112
113 (defn build-graph
114 "Returns Graph defined by a sequence of pairs of vertex ids,
115 and a function that maps vertex id's to Vertex objects."
116 [relations f]
117 (let [graph (DefaultGraph.)
118 vs (reduce #(conj %1 (first %2) (second %2)) #{} relations)
119 vm (reduce #(assoc %1 %2 (f %2)) {} vs)
120 vs (vals vm)
121 es (map #(DefaultEdge2D. (vm (first %)) (vm (second %))) relations)]
122 (doseq [v vs]
123 (.addVertex graph v))
124 (doseq [e es]
125 (.addEdge graph e))
126 graph))
127
128 (comment
129 (let [graph (build-graph
130 [[1 2] [1 3] [1 4] [2 4]]
131 (fn [_] (RectangularVertex2D. 100 30)))
132 layout (ForceDirectedLayout. graph)
133 frame (JFrame. "Graph test")
134 layer (graph-layer layout true)
135 layer (viewport layer :center :center)]
136 (.add (.getContentPane frame) (make-jpanel layer))
137 (while (not (.update layout)))
138 (doto frame
139 (.setDefaultCloseOperation JFrame/DISPOSE_ON_CLOSE)
140 (.pack)
141 (.setVisible true)))
142 )