Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Annotation of /sml/branches/SMLNJ/src/MLRISC/visualization/daVinci.sml
ViewVC logotype

Annotation of /sml/branches/SMLNJ/src/MLRISC/visualization/daVinci.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 245 - (view) (download)

1 : monnier 245 structure daVinci : GRAPH_DISPLAY =
2 :     struct
3 :    
4 :     structure L = GraphLayout
5 :     structure G = Graph
6 :    
7 :     exception DIR
8 :    
9 :     fun suffix() = "daVinci"
10 :     fun program() = "daVinci"
11 :    
12 :     fun visualize out (G.GRAPH G) =
13 :     let val l = ref 0
14 :     fun newLabel() = (l := !l + 1; "L" ^ Int.toString(!l))
15 :     val spaces = " ";
16 :     fun int n = out (Int.toString n)
17 :     fun nl() = out "\n"
18 :     fun tab t = out(String.substring(spaces,0,t)) handle _ => out spaces
19 :     fun nice l = String.toString (String.map (fn #"\t" => #" "
20 :     | c => c) l)
21 :     fun quote s = (out "\""; out s; out "\"")
22 :     fun comma() = out ", "
23 :     fun atom(a,b) = (out "a("; quote a; comma(); quote b; out ")")
24 :     fun OBJECT l = atom("OBJECT",nice l)
25 :     fun FONTFAMILY f = atom("FONTFAMILY",f)
26 :     fun FONTSTYLE s = atom("FONTSTYLE",s)
27 :     fun COLOR c = atom("COLOR",c)
28 :     fun EDGECOLOR c = atom("EDGECOLOR",c)
29 :     fun Dir () = atom("_DIR","none")
30 :     fun label l = (OBJECT l; comma();
31 :     FONTFAMILY "courier"; comma();
32 :     FONTSTYLE "normal"
33 :     )
34 :    
35 :     exception FOUND of string
36 :    
37 :     fun nodeAttrib (L.LABEL l) = label l
38 :     | nodeAttrib (L.COLOR c) = COLOR c
39 :     | nodeAttrib (L.BORDERLESS) = atom("_GO","text")
40 :     | nodeAttrib (L.BORDER_COLOR c) = COLOR c
41 :     | nodeAttrib _ = ()
42 :    
43 :     and isNodeAttrib (L.LABEL l) = true
44 :     | isNodeAttrib (L.COLOR c) = true
45 :     | isNodeAttrib (L.BORDERLESS) = true
46 :     | isNodeAttrib (L.BORDER_COLOR c) = true
47 :     | isNodeAttrib _ = false
48 :    
49 :     and edgeAttrib (L.COLOR c) = EDGECOLOR c
50 :     | edgeAttrib (L.ARROW_COLOR c) = EDGECOLOR c
51 :     | edgeAttrib (L.EDGEPATTERN p) = atom("EDGEPATTERN",p)
52 :     | edgeAttrib DIR = Dir()
53 :     | edgeAttrib _ = ()
54 :    
55 :     and isEdgeAttrib (L.COLOR c) = true
56 :     | isEdgeAttrib (L.ARROW_COLOR c) = true
57 :     | isEdgeAttrib (L.EDGEPATTERN p) = true
58 :     | isEdgeAttrib (DIR) = true
59 :     | isEdgeAttrib _ = false
60 :    
61 :     and findEdgeLabel ((L.LABEL "")::l) = findEdgeLabel l
62 :     | findEdgeLabel ((L.LABEL l)::_) = raise FOUND l
63 :     | findEdgeLabel (_::l) = findEdgeLabel l
64 :     | findEdgeLabel [] = ()
65 :    
66 :     and listify comma f [] = ()
67 :     | listify comma f [x] = f x
68 :     | listify comma f (x::xs) = (f x; comma(); listify comma f xs)
69 :    
70 :     and attribs t (p,gen) a =
71 :     (tab t; out "[\n";
72 :     tab (t+2); listify comma gen (List.filter p a); nl();
73 :     tab t; out "]\n"
74 :     )
75 :    
76 :     fun doNode t (n,a) =
77 :     ( tab t;
78 :     out "l(\""; int n; out "\",n(\"\",\n";
79 :     attribs (t+2) (isNodeAttrib,nodeAttrib) a;
80 :     comma();
81 :     tab (t+2); out "[\n";
82 :     listify comma (doEdge (t+2)) (#out_edges G n);
83 :     tab (t+2); out "]))\n"
84 :     )
85 :    
86 :     and doEdge t (i,j,a) =
87 :     ((findEdgeLabel a;
88 :     tab t; out "l(\""; int i; out "->"; int j; out "\",e(\"\",\n";
89 :     attribs (t+2) (isEdgeAttrib,edgeAttrib) a;
90 :     tab t; out ",r(\""; int j; out "\")))")
91 :     handle FOUND l =>
92 :     let val x = newLabel()
93 :     in
94 :     (tab t; out "l(\""; int i; out("->"^x^"\",e(\"\",");
95 :     attribs (t+2) (isEdgeAttrib,edgeAttrib) (DIR::a);
96 :     out ",l(\""; out(newLabel());
97 :     out "\",n(\"\",[a(\"OBJECT\",\"";
98 :     out l; out "\"),a(\"_GO\",\"text\")],";
99 :     out("[l(\""^x^"->"); int j; out "\",e(\"\",";
100 :     attribs (t+2) (isEdgeAttrib,edgeAttrib) a;
101 :     tab t; out ",r(\""; int j; out "\")))]))))"
102 :     )
103 :     end
104 :     )
105 :    
106 :     in out "[\n";
107 :     listify comma (doNode 2) (#nodes G ());
108 :     out "]\n"
109 :     end
110 :    
111 :    
112 :     end
113 :    
114 :     (*
115 :     * $Log$
116 :     *)

root@smlnj-gforge.cs.uchicago.edu
ViewVC Help
Powered by ViewVC 1.0.0