SCM Repository
[smlnj] / sml / branches / SMLNJ / src / MLRISC / visualization / daVinci.sml |
View of /sml/branches/SMLNJ/src/MLRISC/visualization/daVinci.sml
Parent Directory
|
Revision Log
Revision 469 -
(download)
(annotate)
Wed Nov 10 22:42:52 1999 UTC (21 years, 5 months ago) by monnier
File size: 4173 byte(s)
Wed Nov 10 22:42:52 1999 UTC (21 years, 5 months ago) by monnier
File size: 4173 byte(s)
version 110.23
(* * This backend communicates with the daVinci tool. * * -- Allen *) structure daVinci : GRAPH_DISPLAY = struct structure L = GraphLayout structure G = Graph fun suffix() = ".daVinci" fun program() = "daVinci" fun visualize out (G.GRAPH G) = let val l = ref 0 fun newLabel() = (l := !l + 1; "L" ^ Int.toString(!l)) val spaces = " "; fun int n = out (Int.toString n) fun nl() = out "\n" fun tab t = out(String.substring(spaces,0,t)) handle _ => out spaces fun nice l = String.toString (String.map (fn #"\t" => #" " | c => c) l) fun quote s = (out "\""; out s; out "\"") fun comma() = out ", " fun atom(a,b) = (out "a("; quote a; comma(); quote b; out ")") fun OBJECT l = atom("OBJECT",nice l) fun FONTFAMILY f = atom("FONTFAMILY",f) fun FONTSTYLE s = atom("FONTSTYLE",s) fun COLOR c = atom("COLOR",c) fun EDGECOLOR c = atom("EDGECOLOR",c) fun Dir () = atom("_DIR","none") fun label l = (OBJECT l; comma(); FONTFAMILY "courier"; comma(); FONTSTYLE "normal" ) exception FOUND of string fun nodeAttrib (L.LABEL l) = label l | nodeAttrib (L.COLOR c) = COLOR c | nodeAttrib (L.BORDERLESS) = atom("_GO","text") | nodeAttrib (L.BORDER_COLOR c) = COLOR c | nodeAttrib _ = () and isNodeAttrib (L.LABEL l) = true | isNodeAttrib (L.COLOR c) = true | isNodeAttrib (L.BORDERLESS) = true | isNodeAttrib (L.BORDER_COLOR c) = true | isNodeAttrib _ = false and edgeAttrib (L.COLOR c) = EDGECOLOR c | edgeAttrib (L.ARROW_COLOR c) = EDGECOLOR c | edgeAttrib (L.EDGEPATTERN p) = atom("EDGEPATTERN",p) | edgeAttrib L.DIR = Dir() | edgeAttrib _ = () and isEdgeAttrib (L.COLOR c) = true | isEdgeAttrib (L.ARROW_COLOR c) = true | isEdgeAttrib (L.EDGEPATTERN p) = true | isEdgeAttrib (L.DIR) = true | isEdgeAttrib _ = false and findEdgeLabel ((L.LABEL "")::l) = findEdgeLabel l | findEdgeLabel ((L.LABEL l)::_) = raise FOUND l | findEdgeLabel (_::l) = findEdgeLabel l | findEdgeLabel [] = () and listify comma f [] = () | listify comma f [x] = f x | listify comma f (x::xs) = (f x; comma(); listify comma f xs) and attribs t (p,gen) a = (tab t; out "[\n"; tab (t+2); listify comma gen (List.filter p a); nl(); tab t; out "]\n" ) fun doNode t (n,a) = ( tab t; out "l(\""; int n; out "\",n(\"\",\n"; attribs (t+2) (isNodeAttrib,nodeAttrib) a; comma(); tab (t+2); out "[\n"; listify comma (doEdge (t+2)) (#out_edges G n); tab (t+2); out "]))\n" ) and doEdge t (i,j,a) = ((findEdgeLabel a; tab t; out "l(\""; int i; out "->"; int j; (* dummy label; daVinci chokes on duplicated edge names *) out "-"; out(newLabel()); out "\",e(\"\",\n"; attribs (t+2) (isEdgeAttrib,edgeAttrib) a; tab t; out ",r(\""; int j; out "\")))") handle FOUND l => let val x = newLabel() in (tab t; out "l(\""; int i; out("->"^x^"\",e(\"\","); attribs (t+2) (isEdgeAttrib,edgeAttrib) (L.DIR::a); out ",l(\""; out(newLabel()); out "\",n(\"\",[a(\"OBJECT\",\""; out l; out "\"),a(\"_GO\",\"text\")],"; out("[l(\""^x^"->"); int j; out "\",e(\"\","; attribs (t+2) (isEdgeAttrib,edgeAttrib) a; tab t; out ",r(\""; int j; out "\")))]))))" ) end ) in out "[\n"; listify comma (doNode 2) (#nodes G ()); out "]\n" end end
root@smlnj-gforge.cs.uchicago.edu | ViewVC Help |
Powered by ViewVC 1.0.0 |