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 470 - (view) (download)

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

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