|
1
|
## -*- tcl -*- |
|
2
|
# # ## ### ##### ######## ############# ##################### |
|
3
|
## Copyright (c) 2007 Andreas Kupries. |
|
4
|
# |
|
5
|
# This software is licensed as described in the file LICENSE, which |
|
6
|
# you should have received as part of this distribution. |
|
7
|
# |
|
8
|
# This software consists of voluntary contributions made by many |
|
9
|
# individuals. For exact contribution history, see the revision |
|
10
|
# history and logs, available at http://fossil-scm.hwaci.com/fossil |
|
11
|
# # ## ### ##### ######## ############# ##################### |
|
12
|
|
|
13
|
## Utility package, export graph data to dot format for formatting |
|
14
|
## with neato et. all |
|
15
|
|
|
16
|
# # ## ### ##### ######## ############# ##################### |
|
17
|
## Requirements |
|
18
|
|
|
19
|
package require Tcl 8.4 ; # Required runtime |
|
20
|
package require snit ; # OO system. |
|
21
|
package require fileutil ; # Helper commands. |
|
22
|
|
|
23
|
# # ## ### ##### ######## ############# ##################### |
|
24
|
## |
|
25
|
|
|
26
|
snit::type ::vc::tools::dot { |
|
27
|
# # ## ### ##### ######## ############# |
|
28
|
## Public API, Methods |
|
29
|
|
|
30
|
typemethod format {g name {subgraph {}}} { |
|
31
|
lappend lines "digraph \"$name\" \{" |
|
32
|
|
|
33
|
if {![llength $subgraph]} { |
|
34
|
set nodes [$g nodes] |
|
35
|
set arcs [$g arcs] |
|
36
|
} else { |
|
37
|
set nodes $subgraph |
|
38
|
set arcs [eval [linsert $subgraph 0 $g arcs -inner]] |
|
39
|
} |
|
40
|
|
|
41
|
foreach n $nodes { |
|
42
|
set style [Style $g node $n {label label shape shape fontcolor fontcolor}] |
|
43
|
lappend lines "\"$n\" ${style};" |
|
44
|
} |
|
45
|
foreach a $arcs { |
|
46
|
set style [Style $g arc $a {color color}] |
|
47
|
lappend lines "\"[$g arc source $a]\" -> \"[$g arc target $a]\" ${style};" |
|
48
|
} |
|
49
|
|
|
50
|
lappend lines "\}" |
|
51
|
return [join $lines \n] |
|
52
|
} |
|
53
|
|
|
54
|
typemethod write {g name file {subgraph {}}} { |
|
55
|
fileutil::writeFile $file [$type format $g $name $subgraph] |
|
56
|
return |
|
57
|
} |
|
58
|
|
|
59
|
typemethod layout {format g name file} { |
|
60
|
set f [fileutil::tempfile c2fdot_] |
|
61
|
$type write $g $name $f |
|
62
|
exec dot -T $format -o $file $f |
|
63
|
::file delete $f |
|
64
|
return |
|
65
|
} |
|
66
|
|
|
67
|
# # ## ### ##### ######## ############# |
|
68
|
## Internal, state |
|
69
|
|
|
70
|
proc Style {graph x y dict} { |
|
71
|
set sep " " |
|
72
|
set head " \[" |
|
73
|
set tail "" |
|
74
|
set style "" |
|
75
|
foreach {gattr key} $dict { |
|
76
|
if {![$graph $x keyexists $y $key]} continue |
|
77
|
append style "$head$sep${gattr}=\"[$graph $x get $y $key]\"" |
|
78
|
set sep ", " |
|
79
|
set head "" |
|
80
|
set tail " \]" |
|
81
|
} |
|
82
|
|
|
83
|
append style ${tail} |
|
84
|
return $style |
|
85
|
} |
|
86
|
|
|
87
|
# # ## ### ##### ######## ############# |
|
88
|
## Internal, helper methods (formatting, dispatch) |
|
89
|
|
|
90
|
# # ## ### ##### ######## ############# |
|
91
|
## Configuration |
|
92
|
|
|
93
|
pragma -hasinstances no ; # singleton |
|
94
|
pragma -hastypeinfo no ; # no introspection |
|
95
|
pragma -hastypedestroy no ; # immortal |
|
96
|
|
|
97
|
# # ## ### ##### ######## ############# |
|
98
|
} |
|
99
|
|
|
100
|
namespace eval ::vc::tools { |
|
101
|
namespace export dot |
|
102
|
} |
|
103
|
|
|
104
|
# ----------------------------------------------------------------------------- |
|
105
|
# Ready |
|
106
|
|
|
107
|
package provide vc::tools::dot 1.0 |
|
108
|
return |
|
109
|
|