#======================================================================= # # Package: ASDOT.tcl # # Purpose: A tcl package to allow the reading and writing of graphs # using the the Graphviz format. # See http://www.research.att.com/sw/tools/graphviz/ for details of the # Graphviz tools # Function Name Description # ------------- ------------------------------------------------------- # read_dot Read and parse a .dot file. Build a graph from the description # write_dot Create a .dot file from a Tcl ::struct::graph object # History # Version Created By Description # ------- ---------- ------------------------------------------------- # 1.0 J McCann Initial version package provide ASDOT 1.0 #======================================================================= # NAMESPACE ::ASDOT:: namespace eval ASDOT { #=================================================================== # Export the functions that the user should be calling namespace export read_dot write_dot # We use the tcLex package (1.2 was the latest at the time of # writing) to parse the .dot package package require tcLex # The graph package is needed for obvious reasons so we include # the struct package that contains it package require struct # Define the namespace variables variable n_graph # List of all the possible attributes for a node variable n_nodeAttr { bottomlabel color comment distortion \ fillcolor fixedsize fontcolor \ fontname fontsize group height \ label layer orientation peripheries \ regular shape shapefile sides skew \ style toplabel URL width z } # List of all possible attributes for an edge (arc) variable n_edgeAttr { arrowhead arrowsize arrowtail color comment \ constraint decorate dir fontcolor \ fontname fontsize headlabel headport \ headURL label labelangle labeldistance \ labelfloat labelfontcolor labelfontname \ labelfontsize layer lhead ltail minlen \ samehead sametail style taillabel \ tailport tailURL weight } # List of all possible attributes for a graph variable n_graphAttr { bgcolor center clusterrank color comment \ compound concentrate fillcolor \ fontcolor fontname fontpath fontsize \ label labeljust labelloc layers margin \ mclimit nodesep nslimit nslimit1 ordering \ orientation page pagedir quantum rank \ rankdir ranksep ratio remincross rotate \ samplepoints searchsize size style URL } # Create the lexer that will parse the graph lexer create ASDOT::dot \ -line \ -ec {graphHeader graphDetail attrList nodeSpecAttrList edgeSpec edgeSpecAttrList subGraph} \ -prescript { # prescript - this is run before the lexer starts to work # subgraph contains a stack that is used to track the (possibly nested) # subgraphs within the graph specifications ::struct::stack ASDOT::subgraph } \ -postscript { # postscript - this is run after the lexer has finished work # Destroy the stack now we have finished with it ASDOT::subgraph destroy } \ { {initial} "digraph|static digraph" {graphType} { # The .dot file needs to start with a directed graph specifier. # Only directed graphs are handled by this parser dot begin graphHeader } {graphHeader} "\"(.*)\"" {x graphName} - {graphHeader} "[a-zA-Z][a-zA-Z0-9_]*" {graphName} { # Get the graph name from the .dot file. If the graphname # was enclosed in quotes then it may contain escaped quotes, the # call to regsub removes these set graphName [regsub -all {\\\"} $graphName "\""] # Use the .dot graphname as the name of the graph command # created by the graph library package set ASDOT::n_graph [::struct::graph $graphName] } {graphHeader} "\{" {graphName} { # Match the opening brace for the graph details in the .dot # file. Start the graphDetail processing when it has been # located. dot begin graphDetail } {graphDetail} "([a-zA-Z0-9_]+)[ \t]*[=][ \t]*[\"]*([^\]\"]+)[\"]*[;,]*" {x name value} { # Picks up settings at the graph level. Store these in the graph set value [string trim [regsub -all {\\\"} $value "\""]] $ASDOT::n_graph set -key $name $value } {graphDetail} "(graph|node|edge)[ \t]*[\[]" {x attrType} { # A graph can contain graph, node and edge sections that # define general properties. This condition finds the # start of these sections. They are processed by the # arrtList statements. dot begin attrList } {graphDetail subGraph} "subgraph[ \t]*([a-zA-Z0-9_]+)[ \t]*\{" {x subGraphName} - {graphDetail subGraph} "subgraph[ \t]*\"(.*)\"[ \t]*\{" {x subGraphName} { # Store the subgraph name on the stack. This information gets used later # when arcs are being created. The stack gets stored on the arc when it is # created set subGraphName [regsub -all {\\\"} $subGraphName "\""] ASDOT::subgraph push $subGraphName dot begin subGraph } {graphDetail subGraph} "\"(.*)\"[ \t]*[\[;]" {x nodeName} - {graphDetail subGraph} "([a-zA-Z0-9_]+)[ \t]*[\[;]" {x nodeName} { # Convert any escaped quotes to normal quotes set nodeName [regsub -all {\\\"} $nodeName "\""] # Now check for an edge spec that looks like a node spec because # of its format "333" -> "444" [ for example if { ![ regexp {.*[\"][ \t]*->[ \t]*[\"].*} $nodeName ] && ![ regexp {.*[\"]:.*[ \t]*->[ \t]*[\"].*} $nodeName ] } { # This is a node definition - so create the new node if # ir dosn't exist set newNode $nodeName if { ![$ASDOT::n_graph node exists $nodeName] } { $ASDOT::n_graph node insert $nodeName } # Now start looking at the node attribute list dot begin nodeSpecAttrList } else { # Reject this match and try again dot reject } } {graphDetail subGraph} "\"(.*)\":([a-zA-Z0-9_]+)[ \t]*->" {x nodeName fromNodeRecord} - {graphDetail subGraph} "([a-zA-Z0-9_]+):([a-zA-Z0-9_]+)[ \t]*->" {x nodeName fromNodeRecord} { # This marks the start of a new edge specification (with a record). # First save the name of the from/source node and the record set nodeName [regsub -all {\\\"} $nodeName "\""] set fromNode $nodeName # Now check for an edge spec that looks like a node spec because # of its format "333" -> "444" [ for example if { ![ regexp {.*[\"][ \t]*->[ \t]*[\"].*} $nodeName ] } { # Initialize variables that will hold details of the edge set toNode {} set toNodeRecord {} # Start processing the edge spec dot begin edgeSpec } else { # Reject this match and try again dot reject } } {graphDetail subGraph} "\"(.*)\"[ \t]*->" {x nodeName} - {graphDetail subGraph} "([a-zA-Z0-9_]+)[ \t]*->" {x nodeName} { # This marks the start of a new edge specification. First save # the name of the from/source node set nodeName [regsub -all {\\\"} $nodeName "\""] set fromNode $nodeName # Initialize variables that will hold details of the edge set toNode {} set toNodeRecord {} set fromNodeRecord {} # Start processing the edge spec dot begin edgeSpec } {graphDetail} "\}" {} { # Now go back to the graphHeader condition dot end # Now go back to the initial condition dot end } {attrList} "([a-zA-Z0-9_]+)[ \t]*[=][ \t]*[\"]*([^\],\"]+)[\"]*[,]*" {x name value} { # picks up attributes in the node|edge|graph sections and store these # in the graph set value [string trim [regsub -all {\\\"} $value "\""]] $ASDOT::n_graph set -key "$attrType,$name" $value } {attrList} "[\]]" {} { # End of the attribute list dot end } {nodeSpecAttrList} "([a-zA-Z0-9_]+)[ \t]*[=][ \t]*[\"]*([^\],\"]+)[\"]*[,]*" {x name value} { # When a node is explicitly created it can have attributes set. Associate the # attributes with the node set value [string trim [regsub -all {\\\"} $value "\""]] $ASDOT::n_graph node set $newNode -key $name $value } {nodeSpecAttrList} "[\]]" {} { # End of the node specification dot end } {edgeSpec} ":([a-zA-Z][a-zA-Z0-9_]*)" {x nodeRecordName} { # Get the (optional) record identifier for the start/end # of the edge if { $toNode == {} } { set fromNodeRecord $nodeRecordName } else { # The arc will have been created by now so add the # toNodeRecord to it set toNodeRecord $nodeRecordName $ASDOT::n_graph arc set $newArc -key toRecord $toNodeRecord } } {edgeSpec} "\"(.*)\"" {x nodeName} - {edgeSpec} "[a-zA-Z0-9_]+" {nodeName} { set nodeName [regsub -all {\\\"} $nodeName "\""] set toNode $nodeName # The toNode and fromNode may not yet exist. Check for them # and create them if necessary if { ![$ASDOT::n_graph node exists $fromNode] } { $ASDOT::n_graph node insert $fromNode } # Now for the to node if { ![$ASDOT::n_graph node exists $toNode] } { $ASDOT::n_graph node insert $toNode } # Create the new arc set newArc [$ASDOT::n_graph arc insert $fromNode $toNode] # If we are in a subgraph then add the subgraph stack to the # arc using the key subgraph if { [ASDOT::subgraph size] > 0 } { $ASDOT::n_graph arc set $newArc -key "subgraph" \ [ASDOT::subgraph peek [ASDOT::subgraph size]] } # A from node record can be specified. If one has then # store it with the details of the arc if { $fromNodeRecord != {} } { $ASDOT::n_graph arc set $newArc -key fromRecord $fromNodeRecord } # Nodes and edges can be specified like this # a0 -> a1 -> a2 ; # So copy the toNode to the fromNode in case this is happening set fromNode $toNode } {edgeSpec} "[\[]" {} { dot begin edgeSpecAttrList } {edgeSpec} "[\n]" {} - {edgeSpec} ";" {} { dot end } {edgeSpecAttrList} "([a-zA-Z0-9_]+)[ \t]*[=][ \t]*[\"](.*)[\"]" {x name value} { # An edge can have attributes associated with it. This stores the edge # attributes into the graph set value [string trim [regsub -all {\\\"} $value "\""]] $ASDOT::n_graph arc set $newArc -key $name $value } {edgeSpecAttrList} "[\]]" {} { # Reached the end of an edge specification attribute list dot end } {subGraph} "\}" {} { # Reached the end of a subgraph so pop the name # from the stack ASDOT::subgraph pop dot end } } #=================================================================== # read_dot # Read a .dot file, parse its contents and create a Tcl # ::struct::graph from the contents. # # file - Name of the .dot file to be read proc read_dot { file } { variable n_graph # Open the file and read its contents into the # variable gspec set df [open $file r] set gspec [read $df] # Parse the .dot file into a ::struct::graph ASDOT::dot eval $gspec # Close the file close $df # Return the graph - the caller needs to clean this up return $n_graph } #------------------------------------------------------------------- # writeGraphAttr # Check to see if a graph level attribute exists. If it does # then write it into the output file # df - output file # g - graph # pf - prefix this will be blank or one of node,|graph,|edge, # attr - attribute name proc writeGraphAttr { df g pf attr } { if { ![catch { set val [$g get -key "${pf}${attr}"] }] } { puts $df " $attr = \"$val\"" } } #------------------------------------------------------------------- # getNodeAttr # A node may have zero, one or many attributes defined for it. # If it has none just return a semicolon. If it has one or more # the return them in the correct square bracket delimiters proc getNodeAttr {g n} { variable n_nodeAttr set attrCnt 0 set result " \"${n}\" \[\n" foreach attrName $n_nodeAttr { if { ![catch { set val [$g node get $n -key $attrName] }] } { append result " $attrName = \"$val\"\n" incr attrCnt } } append result " \]\n" if { $attrCnt == 0 } { set result "$n ;" } return $result } #------------------------------------------------------------------- # getEdgeAttr # An edge may have zero, one or many attributes defined for it. # If it has none just return a semicolon. If it has one or more # the return them in the correct square bracket delimiters proc getEdgeAttr {g e} { variable n_edgeAttr set srcNode [$g arc source $e] set destNode [$g arc target $e] set attrCnt 0 set arcDef " \"${srcNode}\"" # Check to see if a from node record has been specfied if { ![catch { set val [$g arc get $e -key "fromRecord"] }] } { append arcDef ":${val}" } append arcDef " -> " append arcDef "\"${destNode}\"" # Check to see if a to node record has been specfied if { ![catch { set val [$g arc get $e -key "toRecord"] }] } { append arcDef ":${val}" } set result "$arcDef \[\n" foreach attrName $n_edgeAttr { if { ![catch { set val [$g arc get $e -key $attrName] }] } { append result " $attrName = \"$val\"\n" incr attrCnt } } append result " \]\n" if { $attrCnt == 0 } { set result "$arcDef ;" } return $result } #------------------------------------------------------------------- # lreverse # Reverse the order of the elements in a list # l - list to reverse proc lreverse { l } { set result {} set ll [expr [llength $l] -1] for {set i $ll} {$i >= 0} {incr i -1} { lappend result [lindex $l $i] } return $result } #------------------------------------------------------------------- # sg_sort # Decide the order of two elements of the with_sg list # e1 - element 1 # e2 - element 2 proc sg_sort { e1 e2 } { set e1_sg [lindex $e1 0] set e2_sg [lindex $e2 0] return [string compare $e1_sg $e2_sg] } #=================================================================== # write_dot # # file - Name of the file to write the graph format data out to # graph - The graph to be written to the file proc write_dot { file graph } { variable n_nodeAttr variable n_edgeAttr variable n_graphAttr # Open the file for output set df [open $file w] # Write the header information into the graph puts $df "digraph \"[set graph]\" \{\n" # Write out any graph level attributes foreach attrName $n_graphAttr { writeGraphAttr $df $graph "" $attrName } # Write out the graph section where graph attributes # can also be specified puts $df " graph \[" foreach attrName $n_edgeAttr { writeGraphAttr $df $graph "graph," $attrName } puts $df " \]\n" # Write out the node section where attributes for all # nodes are specified puts $df "\n node \[" foreach attrName $n_nodeAttr { writeGraphAttr $df $graph "node," $attrName } puts $df " \]\n" # Write out the edge section where attributes for all # edges are specified puts $df " edge \[" foreach attrName $n_edgeAttr { writeGraphAttr $df $graph "edge," $attrName } puts $df " \]\n" # Now write out the details of each node foreach node [lsort -dictionary [$graph nodes]] { puts $df [getNodeAttr $graph $node] } # Now write out the details of each arc. This process is complicated # by the need to cater for subgraphs set with_sg {} set no_sg {} foreach arc [$graph arcs] { # First partition the arcs into those that do and those that # do not have subgraphs if { [catch { set sg [$graph arc get $arc -key "subgraph"] } ] } { lappend no_sg $arc } else { lappend with_sg [list [lreverse $sg] $arc] } } # Write out the arcs that ar not involved in a subgraph foreach arc $no_sg { puts $df "[getEdgeAttr $graph $arc]" } if { [llength $with_sg] > 0 } { # Now write out the arcs that are involved in a subgraph set last_sg {} set last_level 0 foreach sg_arc [lsort -command sg_sort $with_sg] { set sg [lindex $sg_arc 0] set arc [lindex $sg_arc 1] set level [llength $sg] #puts $df "$last_level --> $level" #puts $df "$last_sg --> $sg" if { ! [string equal $last_sg $sg] } { if { $level > $last_level } { puts $df " subgraph [lindex $sg end] \{" } elseif { $level == $last_level } { puts $df " subgraph [lindex $sg end] \{" if { $level > 0 } { puts $df " \}" } } elseif { $level < $last_level } { # Close of the difference in levels plus 1 set closeLevels [expr $last_level - $level + 1] for {set i 0} {$i < $closeLevels} {incr i} { puts $df " \}" } # Start a new subgraph puts $df " subgraph [lindex $sg end] \{" } } puts $df "[getEdgeAttr $graph $arc]" set last_sg $sg set last_level $level } # Close of the last remaining subgraphs set closeLevels [expr $last_level - $level + 1] for {set i 0} {$i < $closeLevels} {incr i} { puts $df " \}" } } # Write the trailing bracket into the graph puts $df "\}" # Close the file close $df } } ---- [[ [Category Package] ]]