NEM 23 May 2007: I've just moved house, and found myself last night needing to precompute some route plans for a group of agents embodied in a virtual environment. As I haven't even got a working phone line in the new house, I had no access to the wiki, and no copy of tcllib on my laptop. So I hacked up this lightweight directed-graph (digraph) package with some utilities for searching the space with a variety of strategies (breadth-first, depth-first, A* etc). The code is quite lightweight and fairly speedy. It makes extensive use of dicts and some other 8.5isms, but I expect a back-port to 8.4 wouldn't be too difficult.
Version 0.2: Fixed some bugs in the search and made node/edge methods take a graph variable rather than the graph itself.
Version 0.3: More fixes...
Version 0.4: And a few more. It is now possible to prevent the current node being expanded in digraph search by using the continue command. This can be useful if you want to avoid expanding the same node twice from different search paths. (Useful when using the uniform-cost strategy which guarantees in certain conditions that any node you encounter for the first time will be on the minimum route to that node).
# digraph.tcl -- # # A basic directed graph library. # # Copyright (c) 2007 Neil Madden ([email protected]). # # RCS: $Id: digraph.tcl,v 1.3 2007/05/23 17:41:46 nem Exp $ package require Tcl 8.5 package provide digraph 0.4 namespace eval digraph { namespace export {[a-z]*} namespace ensemble create # create -- # # Create an empty graph. # proc create {} { return [dict create] } # node graph name -- # # Create a new node in the graph if it doesn't already exist. # proc node {graphVar name} { upvar 1 $graphVar graph if {![dict exists $graph $name]} { dict set graph $name [list] } return $graph } # edge graph source dest ?cost [1]? -- # # Create a directed edge (arc) from source to dest in the graph, # with an optional cost weighting. # proc edge {graphVar source dest {cost 1}} { upvar 1 $graphVar graph dict lappend graph $source $dest $cost } # size graph -- # # Return the number of nodes in the graph. # proc size graph { dict size $graph } # nodes graph ?-progress cmd? nodeVar script -- # # Iterate through the nodes in the graph (in arbitrary order) # calling a script for each node. If the -progress option is given # then this command is called with the current iteration count and # the total number of nodes on each iteration. # proc nodes {graph args} { array set options { -progress "" } array set options [lrange $args 0 end-2] lassign [lrange $args end-1 end] nodeVar script upvar 1 $nodeVar node set total [size $graph] set done 0 foreach node [dict keys $graph] { Invoke #0 $options(-progress) [incr done] $total Uplevel 1 $script } } # search graph source strategy {pathVar costVar} script -- # # Walk the entire graph structure from the source node without # cycles. New nodes are searched in the order determined by the # strategy command which queues new nodes in some order. For each # new path encountered the script is called with the current path # from the source node to that node and the total cost of that path. # proc search {graph source strategy vars script} { lassign $vars pathVar costVar upvar 1 $pathVar path $costVar cost set queue [list [list [list $source] 0]] Do { # pop first item off queue set queue [lassign $queue next] lassign $next path cost set node [lindex $path end] # visit the node Uplevel 1 $script # expand this node expand $graph $node $path {newPath newCost} { set queue [Invoke 1 $strategy $queue $newPath \ [expr {$cost+$newCost}]] } } while {[llength $queue]} } # expand graph node path {pathVar costVar} script -- # # Iterate through all new paths that are reachable from "node" via # an outgoing edge. # proc expand {graph node path vars script} { lassign $vars pathVar costVar upvar 1 $pathVar newPath $costVar cost if {![dict exists $graph $node]} { return } foreach {dest cost} [dict get $graph $node] { if {$dest ni $path} { set newPath [linsert $path end $dest] Uplevel 1 $script } } } # readdot dotfile -- # # Read a Graphviz .dot file and construct a digraph based on the # information contained in it. Currently this just forms a simple # unweighted graph and ignores most information in the file. # proc readdot {dotfile} { set in [open $dotfile] set g [create] foreach line [split [read $in] \n] { if {[regexp {(.*)->(.*);} $line -> source dest]} { edge g [string trim $source] [string trim $dest] } } return $g } # STRATEGIES... proc depth-first {queue element cost} { # add to front of queue linsert $queue 0 [list $element $cost] } proc breadth-first {queue element cost} { # add to rear of queue linsert $queue end [list $element $cost] } # expand nodes with lowest cost-so-far first proc uniform-cost {queue element cost} { # find place to insert in queue set idx 0 foreach elem $queue { lassign $elem path itemcost if {$itemcost >= $cost} { break } incr idx } linsert $queue $idx [list $element $cost] } # expand nodes with best (lowest) heuristic cost first proc best-first {f queue element cost} { set node [lindex $element end] set h [Invoke #0 $f $node] # find place to insert in queue set idx 0 foreach item $queue { lassign $item path itemg itemh if {$itemh >= $h} { break } incr idx } linsert $queue $idx [list $element $cost $h] } proc a-star {heuristic queue element cost} { best-first [namespace code [list A* $heuristic $cost]] \ $queue $element $cost } proc A* {h cost element} { expr {[Invoke #0 $h $element]+$cost} } # Private helper utilities. proc Do {script _while_ cond} { set rc [catch { uplevel 1 $script } result] if {$rc == 3} { return } if {$rc != 0 && $rc != 4} { return -code $rc $result } Uplevel 1 [list while $cond $script] } proc Invoke {level cmd args} { if {[llength $cmd] == 0} { return } if {[string is integer -strict $level]} { incr level } uplevel $level $cmd $args } proc Uplevel {level script} { if {[string is integer -strict $level]} { incr level } set rc [catch { uplevel $level $script } result] if {$rc == 0} { return } if {$rc != 1} { return -code $rc $result } return -code error -errorcode $::errorCode -errorinfo $::errorInfo $result } }
Example I'll try and update my pages on state space searching to use this simple package now. Until then, here is the example code that I was using to generate least-cost routes (I store the routes in an existing SQLite database):
package require Tcl 8.5
package require digraph 0.1
package require sqlite3 3.3
proc routes {graph file} {
sqlite3 db $file
db transaction {
digraph nodes $graph -progress ::progress source {
digraph search $graph $source {digraph least-cost} path {
set dest [lindex $path end]
if {$dest eq $source} { continue }
db eval {INSERT INTO route VALUES($source, $dest, $path)}
}
}
}
db close
}
proc progress {done total} {
set percent [expr {int(double($done)/double($total)*100)}]
puts -nonewline [format "\rProgress: |%-50.50s| %3d%% (%d/%d)" \
[string repeat "=" [expr {$percent/2}]]> $percent \
$done $total]
flush stdout
}
set rhun [digraph readdot ~/Desktop/Rhun_map.dot]
puts "Computing routes..."
routes $rhun rhun_routes.db
puts "\nDone."