#=======================================================================
 #
 # 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
        
    }
 }