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/trunk/src/MLRISC/visualization/daVinci.sml
ViewVC logotype

Annotation of /sml/trunk/src/MLRISC/visualization/daVinci.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 411 - (view) (download)
Original Path: sml/branches/SMLNJ/src/MLRISC/visualization/daVinci.sml

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

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