# ACTIVESTATE TEAPOT-PKG BEGIN TM -*- tcl -*-
# -- Tcl Module
# @@ Meta Begin
# Package struct::graph::op 0.4
# Meta as::origin http://sf.net/projects/tcllib
# Meta license BSD
# Meta platform tcl
# Meta require {Tcl 8.4}
# Meta require struct::disjointset
# Meta require struct::prioqueue
# Meta require struct::queue
# Meta require struct::stack
# @@ Meta End
# ACTIVESTATE TEAPOT-PKG BEGIN REQUIREMENTS
package require Tcl 8.4
package require struct::disjointset
package require struct::prioqueue
package require struct::queue
package require struct::stack
# ACTIVESTATE TEAPOT-PKG END REQUIREMENTS
# ACTIVESTATE TEAPOT-PKG BEGIN DECLARE
package provide struct::graph::op 0.4
# ACTIVESTATE TEAPOT-PKG END DECLARE
# ACTIVESTATE TEAPOT-PKG END TM
# graphops.tcl --
#
# Operations on and algorithms for graph data structures.
#
# Copyright (c) 2008 Alejandro Paz , algorithm implementation
# Copyright (c) 2008 Andreas Kupries, integration with Tcllib's struct::graph
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: graphops.tcl,v 1.5 2008/11/13 05:36:53 andreas_kupries Exp $
# ### ### ### ######### ######### #########
## Requisites
package require Tcl 8.4
package require struct::disjointset ; # Used by kruskal
package require struct::prioqueue ; # Used by kruskal, prim
package require struct::queue ; # Used by isBipartite?
package require struct::stack ; # Used by tarjan
# ### ### ### ######### ######### #########
##
namespace eval ::struct::graph::op {}
# ### ### ### ######### ######### #########
##
# This command constructs an adjacency matrix representation of the
# graph argument.
# Reference: http://en.wikipedia.org/wiki/Adjacency_matrix
#
# Note: The reference defines the matrix in such a way that some of
# the limitations of the code here are not present. I.e. the
# definition at wikipedia deals properly with arc directionality
# and parallelism.
#
# TODO: Rework the code so that the result is in line with the reference.
# Add features to handle weights as well.
proc ::struct::graph::op::toAdjacencyMatrix {g} {
set nodeList [lsort -dict [$g nodes]]
# Note the lsort. This is used to impose some order on the matrix,
# for comparability of results. Otherwise different versions of
# Tcl and struct::graph (critcl) may generate different, yet
# equivalent matrices, dependent on things like the order a hash
# search is done, or nodes have been added to the graph, or ...
# Fill an array for index tracking later. Note how we start from
# index 1. This allows us avoid multiple expr+1 later on when
# iterating over the nodes and converting the names to matrix
# indices. See (*).
set i 1
foreach n $nodeList {
set nodeDict($n) $i
incr i
}
set matrix {}
lappend matrix [linsert $nodeList 0 {}]
# Setting up a template row with all of it's elements set to zero.
set baseRow 0
foreach n $nodeList {
lappend baseRow 0
}
foreach node $nodeList {
# The first element in every row is the name of its
# corresponding node. Using lreplace to overwrite the initial
# data in the template we get a copy apart from the template,
# which we can then modify further.
set currentRow [lreplace $baseRow 0 0 $node]
# Iterate over the neighbours, also known as 'adjacent'
# rows. The exact set of neighbours depends on the mode.
foreach neighbour [$g nodes -adj $node] {
# Set value for neighbour on this node list
set at $nodeDict($neighbour)
# (*) Here we avoid +1 due to starting from index 1 in the
# initialization of nodeDict.
set currentRow [lreplace $currentRow $at $at 1]
}
lappend matrix $currentRow
}
# The resulting matrix is a list of lists, size (n+1)^2 where n =
# number of nodes. First row and column (index 0) are node
# names. The other entries are boolean flags. True when an arc is
# present, False otherwise. The matrix represents an
# un-directional form of the graph with parallel arcs collapsed.
return $matrix
}
# ### ### ### ######### ######### #########
##
# This command finds a minimum spanning tree/forest (MST) of the graph
# argument, using the algorithm developed by Joseph Kruskal. The
# result is a set (as list) containing the names of the arcs in the
# MST. The set of nodes of the MST is implied by set of arcs, and thus
# not given explicitly. The algorithm does not consider arc
# directions. Note that unconnected nodes are left out of the result.
# Reference: http://en.wikipedia.org/wiki/Kruskal%27s_algorithm
proc ::struct::graph::op::kruskal {g} {
# Check graph argument for proper configuration.
VerifyWeightsAreOk $g
# Transient helper data structures. A priority queue for the arcs
# under consideration, using their weights as priority, and a
# disjoint-set to keep track of the forest of partial minimum
# spanning trees we are working with.
set consider [::struct::prioqueue -dictionary consider]
set forest [::struct::disjointset forest]
# Start with all nodes in the graph each in their partition.
foreach n [$g nodes] {
$forest add-partition $n
}
# Then fill the queue with all arcs, using their weight to
# prioritize. The weight is the cost of the arc. The lesser the
# better.
foreach {arc weight} [$g arc weights] {
$consider put $arc $weight
}
# And now we can construct the tree. This is done greedily. In
# each round we add the arc with the smallest weight to the
# minimum spanning tree, except if doing so would violate the tree
# condition.
set result {}
while {[$consider size]} {
set minarc [$consider get]
set origin [$g arc source $minarc]
set destin [$g arc target $minarc]
# Ignore the arc if both ends are in the same partition. Using
# it would add a cycle to the result, i.e. it would not be a
# tree anymore.
if {[$forest equal $origin $destin]} continue
# Take the arc for the result, and merge the trees both ends
# are in into a single tree.
lappend result $minarc
$forest merge $origin $destin
}
# We are done. Get rid of the transient helper structures and
# return our result.
$forest destroy
$consider destroy
return $result
}
# ### ### ### ######### ######### #########
##
# This command finds a minimum spanning tree/forest (MST) of the graph
# argument, using the algorithm developed by Prim. The result is a
# set (as list) containing the names of the arcs in the MST. The set
# of nodes of the MST is implied by set of arcs, and thus not given
# explicitly. The algorithm does not consider arc directions.
# Reference: http://en.wikipedia.org/wiki/Prim%27s_algorithm
proc ::struct::graph::op::prim {g} {
VerifyWeightsAreOk $g
# Fill an array with all nodes, to track which nodes have been
# visited at least once. When the inner loop runs out of nodes and
# we still have some left over we restart using one of the
# leftover as new starting point. In this manner we get the MST of
# the whole graph minus unconnected nodes, instead of only the MST
# for the component the initial starting node is in.
array set unvisited {}
foreach n [$g nodes] { set unvisited($n) . }
# Transient helper data structure. A priority queue for the nodes
# and arcs under consideration for inclusion into the MST. Each
# element of the queue is a list containing node name, a flag bit,
# and arc name, in this order. The associated priority is the
# weight of the arc. The flag bit is set for the initial queue
# entry only, containing a fake (empty) arc, to trigger special
# handling.
set consider [::struct::prioqueue -dictionary consider]
# More data structures, the result arrays.
array set weightmap {} ; # maps nodes to min arc weight seen so
# far. This is the threshold other arcs
# on this node will have to beat to be
# added to the MST.
array set arcmap {} ; # maps arcs to nothing, these are the
# arcs in the MST.
while {[array size unvisited]} {
# Choose a 'random' node as the starting point for the inner
# loop, prim's algorithm, and put it on the queue for
# consideration. Then we iterate until we have considered all
# nodes in the its component.
set startnode [lindex [array names unvisited] 0]
$consider put [list $startnode 1 {}] 0
while {[$consider size] > 0} {
# Pull the next minimum weight to look for. This is the
# priority of the next item we can get from the queue. And the
# associated node/decision/arc data.
set arcweight [$consider peekpriority 1]
foreach {v arcundefined arc} [$consider get] break
#8.5: lassign [$consider get] v arcundefined arc
# Two cases to consider: The node v is already part of the
# MST, or not. If yes we check if the new arcweight is better
# than what we have stored already, and update accordingly.
if {[info exists weightmap($v)]} {
set currentweight $weightmap($v)
if {$arcweight < $currentweight} {
# The new weight is better, update to use it as
# the new threshold. Note that this fill not touch
# any other arcs found for this node, as these are
# still minimal.
set weightmap($v) $arcweight
set arcmap($arc) .
}
} else {
# Node not yet present. Save weight and arc. The
# latter if and only the arc is actually defined. For
# the first, initial queue entry, it is not. Then we
# add all the arcs adjacent to the current node to the
# queue to consider them in the next rounds.
set weightmap($v) $arcweight
if {!$arcundefined} {
set arcmap($arc) .
}
foreach adjacentarc [$g arcs -adj $v] {
set weight [$g arc getweight $adjacentarc]
set neighbour [$g node opposite $v $adjacentarc]
$consider put [list $neighbour 0 $adjacentarc] $weight
}
}
# Mark the node as visited, belonging to the current
# component. Future iterations will ignore it.
unset -nocomplain unvisited($v)
}
}
# We are done. Get rid of the transient helper structure and
# return our result.
$consider destroy
return [array names arcmap]
}
# ### ### ### ######### ######### #########
##
# This command checks whether the graph argument is bi-partite or not,
# and returns the result as a boolean value, true for a bi-partite
# graph, and false otherwise. A variable can be provided to store the
# bi-partition into.
#
# Reference: http://en.wikipedia.org/wiki/Bipartite_graph
proc ::struct::graph::op::isBipartite? {g {bipartitionvar {}}} {
# Handle the special cases of empty graphs, or one without arcs
# quickly. Both are bi-partite.
if {$bipartitionvar ne ""} {
upvar 1 $bipartitionvar bipartitions
}
if {![llength [$g nodes]]} {
set bipartitions {{} {}}
return 1
} elseif {![llength [$g arcs]]} {
if {$bipartitionvar ne ""} {
set bipartitions [list [$g nodes] {}]
}
return 1
}
# Transient helper data structure, a queue of the nodes waiting
# for processing.
set pending [struct::queue pending]
set nodes [$g nodes]
# Another structure, a map from node names to their 'color',
# indicating which of the two partitions a node belngs to. All
# nodes start out as undefined (0). Traversing the arcs we
# set and flip them as needed (1,2).
array set color {}
foreach node $nodes {
set color($node) 0
}
# Iterating over all nodes we use their connections to traverse
# the components and assign colors. We abort when encountering
# paradox, as that means that the graph is not bi-partite.
foreach node $nodes {
# Ignore nodes already in the second partition.
if {$color($node)} continue
# Flip the color, then travel the component and check for
# conflicts with the neighbours.
set color($node) 1
$pending put $node
while {[$pending size]} {
set current [$pending get]
foreach neighbour [$g nodes -adj $current] {
if {!$color($neighbour)} {
# Exchange the color between current and previous
# nodes, and remember the neighbour for further
# processing.
set color($neighbour) [expr {3 - $color($current)}]
$pending put $neighbour
} elseif {$color($neighbour) == $color($current)} {
# Color conflict between adjacent nodes, should be
# different. This graph is not bi-partite. Kill
# the data structure and abort.
$pending destroy
return 0
}
}
}
}
# The graph is bi-partite. Kill the transient data structure, and
# move the partitions into the provided variable, if there is any.
$pending destroy
if {$bipartitionvar ne ""} {
# Build bipartition, then set the data into the variable
# passed as argument to this command.
set X {}
set Y {}
foreach {node partition} [array get color] {
if {$partition == 1} {
lappend X $node
} else {
lappend Y $node
}
}
set bipartitions [list $X $Y]
}
return 1
}
# ### ### ### ######### ######### #########
##
# This command computes a maximal matching, if it exists, for the
# graph argument G and its bi-partition as specified through the node
# sets X and Y. As is implied, this method requires that the graph is
# bi-partite. Use the command 'isBipartite?' to check for this
# property, and to obtain the bi-partition.
proc ::struct::graph::op::maxMatching {g X Y} {
return -code error "not implemented yet"
}
# ### ### ### ######### ######### #########
##
# This command computes the strongly connected components (SCCs) of
# the graph argument G. The result is a list of node-sets, each set
# containing the nodes of one SCC of G. In anny SCC there is directed
# path between any two nodes U, V from U to V. If all SCCs contain
# only a single node the graph is acyclic.
proc ::struct::graph::op::tarjan {g} {
set all [$g nodes]
# Quick bailout for simple special cases, i.e. graphs without
# nodes or arcs.
if {![llength $all]} {
# No nodes => no SCCs
return {}
} elseif {![llength [$g arcs]]} {
# Have nodes, but no arcs => each node is its own SCC.
set r {} ; foreach a $all { lappend r [list $a] }
return $r
}
# Transient data structures. Stack of nodes to consider, the
# result, and various state arrays. TarjanSub upvar's all them
# into its scope.
set pending [::struct::stack pending]
set result {}
array set index {}
array set lowlink {}
array set instack {}
# Invoke the main search system while we have unvisited
# nodes. TarjanSub will remove all visited nodes from 'all',
# ensuring termination.
while {[llength $all]} {
TarjanSub [lindex $all 0] 0
}
# Release the transient structures and return result.
$pending destroy
return $result
}
proc ::struct::graph::op::TarjanSub {start counter} {
# Import the tracer state from our caller.
upvar 1 g g index index lowlink lowlink instack instack result result pending pending all all
struct::set subtract all $start
set component {}
set index($start) $counter
set lowlink($start) $counter
incr counter
$pending push $start
set instack($start) 1
foreach outarc [$g arcs -out $start] {
set neighbour [$g arc target $outarc]
if {![info exists index($neighbour)]} {
# depth-first-search of reachable nodes from the neighbour
# node. Original from the chosen startnode.
TarjanSub $neighbour $counter
set lowlink($start) [Min $lowlink($start) $lowlink($neighbour)]
} elseif {[info exists instack($neighbour)]} {
set lowlink($start) [Min $lowlink($start) $index($neighbour)]
}
}
# Check if the 'start' node on this recursion level is the root
# node of a SCC, and collect the component if yes.
if {$lowlink($start) == $index($start)} {
while {1} {
set v [$pending pop]
unset instack($v)
lappend component $v
if {$v eq $start} break
}
lappend result $component
}
return
}
#
## place holder for the operations to come
#
# ### ### ### ######### ######### #########
## Internal helpers
proc ::struct::graph::op::Min {first second} {
if {$first > $second} {
return $second
} else {
return $first
}
}
# This method verifies that every arc on the graph has a weight
# assigned to it. This is required for some algorithms.
proc ::struct::graph::op::VerifyWeightsAreOk {g} {
if {![llength [$g arc getunweighted]]} return
return -code error "Operation invalid for graph with unweighted arcs."
}
# ### ### ### ######### ######### #########
## Ready
namespace eval ::struct::graph::op {
#namespace export ...
}
package provide struct::graph::op 0.4