[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. # digraph.tcl -- # # A basic directed graph library. # # Copyright (c) 2007 Neil Madden (nem@cs.nott.ac.uk). # # RCS: $Id: digraph.tcl,v 1.1 2007/05/23 13:25:00 nem Exp $ package require Tcl 8.5 package provide digraph 0.1 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 {graph name} { 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 {graph source dest {cost 1}} { 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 node encountered the script is called with the current path # from the source node to that node and the total cost of that path. # Each node is only visited once. # proc search {graph source strategy vars script} { lassign $vars pathVar costVar upvar 1 $pathVar path $costVar cost set visited [dict create] set queue [list [list $source] 0] Do { # pop first item off queue set queue [lassign $queue path cost] set node [lindex $path end] # have we seen this node before? if {[dict exists $visited $node]} { continue } dict set visited $node 1 # expand this node expand $graph $node $path {newPath newCost} { set queue [Invoke 1 $strategy $queue $newPath \ [expr {$cost+$newCost}]] } # visit the node Uplevel 1 $script } 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]} { set g [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 $element $cost } proc breadth-first {queue element cost} { # add to rear of queue linsert $queue end $element $cost } proc least-cost {queue element cost} { # find place to insert in queue set idx 0 foreach {item itemcost} $queue { if {$itemcost >= $cost} { break } incr idx 2 } linsert $queue $idx $element $cost } proc best-first {heuristic queue element cost} { # Do A* style search, where we rank based on cost so far + estimated # cost to destination from the current node. Heuristic should be # admissable -- i.e., it should never overestimate the cost to the # goal. set totalcost [expr {[Invoke 0 $heuristic $element]+$cost}] least-cost $queue $element $totalcost } # Private helper utilities. proc Do {script _while_ cond} { Uplevel 1 $script 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 || $rc == 4} { 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." ---- [[ [Category Data Structure] ]]