Author Jackson McCann.

#======================================================================= # # Package: DGA.tcl # # Purpose: A tcl package that implements a number of algorithms on top of # the basic Tcl ::struct::graph package. package provide DGA 1.0 #======================================================================= # NAMESPACE ::DGA:: namespace eval DGA { #=================================================================== # Export the functions that the user should be calling namespace export shortest_path min_span_tree predecessor_list namespace export pl_node pl_arc pl_dist namespace export topological_sort outonly_nodes is_DAG # The graph package is needed for obvious reasons so we include # the struct package that contains it package require struct # Define any variables used by the package variable topo_sort {} #------------------------------------------------------------------- # update_node # # g - The graph # n - The node # u - Used start 0 Unused, 1 Found, 2 Completely used # d - The distance from the starting node # p - The predecessor node proc update_node { g n d p u } { # Set this nodes predecessor $g node set $n -key predecessor $p # The distance to the source node $g node set $n -key distance $d # Set the used flag if { [expr $u > -1] } { $g node set $n -key "used" $u } } #------------------------------------------------------------------- # init_graph # Algorithms such as Dijkstra'a and Prim's need to flag the nodes # and arcs of the graph and to record additional information # against the nodes and arcs. This function initializes these # values for a graph proc init_graph { g } { # Setup. Update each node with the keyed values that will hold # the following information for each node: # The distance from the source to the node - infinite # The predecessor of the node - nothing # The nodes status 0 - Not found, 1 - Found, 2 - Finished foreach node [$g nodes] { # This node doesn't have a predecessor and the distance to the # source node is undefined and the node is unused update_node $g $node -1 {} 0 } # Initialize the arcs in the graph. Make sure they all # have a weight associated with them. Give a default # weight of 1 if no weight is found. Set a flag to show # if the arc has been used in the algorithm foreach arc [$g arcs] { $g arc set $arc -key used 0 if { [catch { $g arc get $arc -key weight }] } { $g arc set $arc -key weight 1.0 } } } #------------------------------------------------------------------- # min_arc # Within the graph zero, one or many nodes will be in state 1, # i.e., the node has been found and still has outward arcs that # have not been used. Find the arc that has the minimum weight. # As a side effect if a node has no unused outward arcs left # then mark the node as used. If no arc can be found then # return an empty list. # g - The graph to search proc min_arc { g } { # Initialise the working variables used by this proc # The arc from the source node set tArc {} # The weight of the arc set tArcMin -1 # Find the shortest arc out of the nodes that have been found. # Use this arc if it provides a shorter route to the target or # if it discovers a new target node foreach node [$g nodes -key used -value 1] { # The hasArc counter is used to determine when a node has # no unused arcs left. set hasArc 0 # Look at each arc that goes out of the current node foreach arc [$g arcs -out $node -key used -value 0] { # Set hasArc as this node has at least one unused arc set hasArc 1 # Get the weight of this arc. If it is less than the # current value of tArcMin then it will be used set arcWeight [$g arc get $arc -key weight] if { [expr $tArcMin == -1] || [expr $tArcMin > $arcWeight] } { # Store the source node and arc names set tArc $arc set tArcMin $arcWeight } } # If a node doesn't have any unused arcs left then # mark the node as completely used if { [expr $hasArc == 0] } { $g node set $node -key used 2 } } # Now mark this arc as having been used if { $tArc != {} } { $g arc set $tArc -key used 1 } return $tArc } #=================================================================== # predecessor_list # After an algorithm such as: # shortest_path # min_span_tree # has been run on the graph it will contain a predecessor list, # that is for each node that was found an arc will be held under # the key 'predecessor' that defines the arc and node that this # node was reached from. This function returns this list as a # Tcl list with a structure. The pl_ functions can be used to # access this list # g - The graph proc predecessor_list { g } { set idxList {} set detList {} foreach node [$g nodes] { # The distance node is from the source set nDist [$g node get $node -key distance] # The arc that links node to its predecessor set pArc [$g node get $node -key predecessor] # The node that precedes this node, if there is one if { $pArc == {} } { set pNode {} } else { set pNode [$g arc source $pArc] } lappend idxList $node lappend detList [list $node $pNode $pArc $nDist] } return [list [lsort $idxList] [lsort $detList]] } #=================================================================== # pl_node # pl_arc # pl_dist # Three helper functions that make it easier to get # details about a node's predecessor. # pl - The predecessor list as returned by predecessor_list # n - The node proc pl_node { pl n } { set idx [lsearch -sorted [lindex $pl 0] $n] return [lindex [lindex [lindex $pl 1] $idx] 1] } proc pl_arc { pl n } { set idx [lsearch -sorted [lindex $pl 0] $n] return [lindex [lindex [lindex $pl 1] $idx] 2] } proc pl_dist { pl n } { set idx [lsearch -sorted [lindex $pl 0] $n] return [lindex [lindex [lindex $pl 1] $idx] 3] } #=================================================================== # shortest_path # Using Dijkstra's algorithm find a shortest path from the node # n to every other node that is reachable from n. # # g - The graph to be processed # n - The starting node proc shortest_path { g n } { # Setup. Update the nodes and arcs with the required # flags etc. init_graph $g # Mark the starting node as being used and as having a distance # of zero from itself. update_node $g $n 0.0 {} 1 # Now start looking for nodes we don't know about by exploring out # from the starting node. while {1} { # Find the arc with minimum length that goes from # a found node set tArc [min_arc $g] # Test for the end of the graph, we have no unused nodes # or arcs left. This does not imply that all of the nodes # in the graph have been discovered, some nodes may not be # reachable from the given starting node. These can be # identified as they have a distance of -1. if { $tArc == {} } { break } # Get the distance from the first node of # this node set sDist [$g node get [$g arc source $tArc] -key distance] # Get the name of the target node set tNode [$g arc target $tArc] # Get the weight of the arc joining the source and # target nodes. set weight [$g arc get $tArc -key weight] # Get the distance from the source node of the # target node. This will be -1 if we have never # seen this node before. set tDist [$g node get $tNode -key distance] # Does this arc build a short path to the target node? if { [expr $tDist == -1] } { # Yes - it must do, this is the first time # the target node has been encountered. # Save the distance from the source node and the # arc that leads to the predecessor and mark the # node as found, it will now be considered next time # we look for the shortest arc. update_node $g $tNode [expr $sDist + $weight] $tArc 1 } else { # Does this arc provide a cheaper way to get to # the already discovered node? Calculate the distance # based on the new arc's weight and compare it with the stored # distance for the node. set ttDist [expr $sDist + $weight] if { [expr $ttDist < $tDist] } { # Update the node to use the new arc as its # predecessor update_node $g $tNode $ttDist $tArc -1 } } } } #=================================================================== # min_span_tree # Using Prims's algorithm find a minimum spanning tree starting # at the node n and reaching to every other node that is reachable # from n. # # g - The graph to be processed # n - The starting node proc min_span_tree { g n } { # Setup. Update the nodes and arcs with the required # flags etc. init_graph $g # Mark the starting node as being used and as having a distance # of zero from itself. update_node $g $n 0.0 {} 1 # Now start looking for nodes we don't know about by exploring out # from the starting node. while {1} { # Find the arc with minimum length that goes from # a found node set tArc [min_arc $g] # Test for the end of the graph, we have no unused nodes # or arcs left. This does not imply that all of the nodes # in the graph have been discovered, some nodes may not be # reachable from the given starting node. These can be # identified as they have a distance of -1. if { $tArc == {} } { break } # Get the distance from the first node of # this node set sDist [$g node get [$g arc source $tArc] -key distance] # Get the name of the target node. set tNode [$g arc target $tArc] # Get the weight of the arc joining the source and # target nodes. set weight [$g arc get $tArc -key weight] # Get the distance from the source node of the # target node. This will be -1 if we have never # seen this node before. set tDist [$g node get $tNode -key distance] # Does this arc discover a new target node? if { [expr $tDist == -1] } { # Yes it does # Save the distance from the source node and the # arc that leads to the predecessor and mark the # node as found. It will now be considered next time # we look for the shortest arc. update_node $g $tNode [expr $sDist + $weight] $tArc 1 } } } #=================================================================== # outonly_nodes # An 'out only' node is one that has no inward arcs. That is the # node can have no predecessor as no no arc has it as its target # This function finds all such nodes with the graph. # # g - The graph proc outonly_nodes { g } { set result {} foreach node [$g nodes] { if { [$g node degree -in $node] == 0 } { lappend result $node } } return $result } #------------------------------------------------------------------- # make_toplevel_node # When checking for DAGness and/or performing a topological sort # a single top-level node to start the process from is required. # This function transforms the graph so that it has that single # top node. The name of this new node is returned. proc make_toplevel_node { g } { # Find toplevel node(s) set oonList [outonly_nodes $g] # If there are no out-only nodes then we can't sort the # graph as it must have at least one cycle. if { [llength $oonList] == 0 } { error "$g is not a DAG. Graph contains one or more cycles" } # If there are more than one out-only nodes a new parent node that # provides a single starting point for the sort must be created above # these nodes. To make life simple we do this for one node as well. set startNode [$g node insert] # Connect the startNode to the original out-only nodes foreach node $oonList { $g arc insert $startNode $node } return $startNode } #------------------------------------------------------------------- # topo_node # This routine is called by the topological_sort when a node has # been completely explored. The routine has two functions. proc topo_node { dir g n } { variable topo_sort lappend topo_sort $n } #=================================================================== # topological_sort # Perform a topological sort on the graph. This will return a # list of nodes giving an ordering on the nodes such that all # arcs go from left to right. Only an acyclic graph can have a # topological sort, because a directed cycle must eventually # return home to the source of the cycle. However, every DAG # has at least one topological sort. # # g - The graph to sort proc topological_sort { g } { variable topo_sort {} # Make a toplevel (parentless) node to start the sort from set startNode [make_toplevel_node $g] # Setup. Update the nodes and arcs with the required # flags etc. init_graph $g # Walk the graph, nodes are added to the topo_sort list # in the order that they are marked as completely explored. # The topological sort is the reverse of this order. # NB - This code won't detect any cycles in the data so it's # up to the user to determine that the graph is a DAG # The is_DAG function can be used for this $g walk $startNode -order post -type dfs -command topo_node # Remove the start node we created from the graph, all of the # arcs will be removed as well. $g node delete $startNode # Reverse the list and discard the node that # was added to the graph by this routine. set result {} for { set i [expr [llength $topo_sort] - 2] } {$i >= 0} {incr i -1} { lappend result [lindex $topo_sort $i] } return $result } #=================================================================== # dag_dfs # Recursive Depth First Search of the graph. If a node is # discovered that has the used flag set to 1, then it has been # found by a cycle through one of its children and the graph # is not a DAG. A stack-based implementation of this function # would be better. It would not risk blowing up if the recursion # level got too big. # # g - The graph # n - The next node to check proc dag_dfs { g n } { # We have found a new node, mark it as such. $g node set $n -key used 1 # Process each of the arcs out of the node. foreach arc [$g arcs -out $n] { # Find out the details of the target node. set tNode [$g arc target $arc] set used [$g node get $tNode -key used] # If the node has been discovered but not completed then # this is a back edge and the graph contains a cycle. if { $used == 1 } { error "$g is not a DAG. Graph contains one or more cycles" } dag_dfs $g $tNode } # We have completely used this node. $g node set $n -key used 2 } #=================================================================== # is_DAG # Determine if the graph is a DAG, that is that it contains no # cycles. If it isn't a DAG then an error is thrown! # # g - The graph proc is_DAG { g } { # Make a toplevel (parentless) node to start the sort from set startNode [make_toplevel_node $g] # Setup. Update the nodes and arcs with the required # flags etc. init_graph $g # Use the simple recursive definition of depth-first search # to search through the tree for back edges. set result [dag_dfs $g $startNode] # Remove the start node we created from the graph. All of the # arcs will be removed as well. $g node delete $startNode return $result } }