Version 20 of A lightweight digraph package

Updated 2007-05-23 13:33:46 by NEM

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.

 # digraph.tcl --
 #
 #       A basic directed graph library.
 #
 # Copyright (c) 2007 Neil Madden ([email protected]).
 #
 # 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
     }
 }

[ Category Data Structure ]