[NEM] ''23 May 2007'': I've just moved house, and found myself last night needing to precompute some route plans for a group of [agent]s 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 [dict]s 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 (nem@cs.nott.ac.uk). # # 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 { set visited [dict create] digraph search $graph $source {digraph least-cost} path { set dest [lindex $path end] if {[dict exists $visited $dest]} { continue } ;# don't expand again dict set visited $dest 1 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." ---- See also [Heuristic Searches] for another example. ---- [[ [Category Data Structure] ]]