[Richard Suchenwirth] - Another weekend, more input to [the Tcler's Wiki]. In this continuation to [Graph theory in Tcl], I tried to find paths in graphs as efficient as Tcl can get (C routines would have be faster, but not a weekend fun project ;-). First, a general path enumerator, giving all paths of length >1, which uses an array to collapse multiple instances of a normalized path: proc paths g { set todo [nodes $g] foreach node $todo {set neighbors($node) [neighbors $node $g]} while {[llength $todo]} { set path [lpop todo] set last [lindex $path end] set last2 [lindex $path end-1] foreach i $neighbors($last) { if {$i==$last2} continue ;# avoid digons if {[lsearch $path $i]<0} { set newpath [concat $path [list $i]] set t([normalizePath $newpath]) . ;# value doesn't matter lappend todo $newpath } } } lsort [array names t] } proc neighbors {n g} { set res {} foreach edge $g { foreach {from to} [split $edge ,] break if {$from==$n && $to!=""} {lappend res $to} if {$to==$n} {lappend res $from} } set res } if 0 {In an undirected graph, pathes ''a b c'' and ''c b a'' are equivalent. The lexically smaller variant is preferred:} proc normalizePath p {lindex [lsort [list $p [lrevert $p]]] 0} if 0 {''Cycles'' are paths where the first and the last vertex coincide (I experimented with "trimming legs", removing nodes of degree <2 that could not possibly be part of a cycle, but it didn't increase performance): } proc cycles g { #set g [trimLegs $g] foreach path [paths $g] { if {[llength $path]>2} { set from [lindex $path 0] set to [lindex $path end] if {[lsearch $g $from,$to]>=0 || [lsearch $g $to,$from]>=0} { set t([normalizeCycle $path]) . } } } lsort [array names t] } proc trimLegs g { foreach node [nodes $g] { if {[degree $node $g]<2} {removeNode $node g} } set g } proc removeNode {node _g} { upvar 1 $_g g set res {} foreach i $g { foreach {from to} [split $i ,] break if {$from!=$node && $to!=$node} {lappend res $i} } set res } if 0 {Cycles in an undirected graph can come under many names. Ambiguity is reduced by requiring each cycle to start with its (lexical) minimal node, and picking the lexical smaller of its two directions (e.g. ''a b c a'' is preferred to ''a c b a'', or ''c b a c''):} proc normalizeCycle c { set min [lindex [lsort $c] 0] set pos [lsearch $c $min] set t [concat [lrange $c $pos end] [lrange $c 0 [expr {$pos-1}]]] normalizePath [concat $t [lindex $t 0]] } if 0 {A ''Hamiltonian'' cycle is a cycle that traverses all vertices of a graph exactly once. Having all cycles, it's easy to filter out the Hamiltonian ones, which have as many nodes as the graph, plus the final repetition of the first node:} proc hamiltonCycles g { set n [llength [nodes $g]] set res {} foreach cycle [cycles $g] { if {[llength $cycle]==$n+1} {lappend res $cycle} } set res } proc isHamiltonian g { expr {[llength [hamiltonCycles $g]]>0} } if 0 {Another by-product of ''cycles'' is to tell if a graph is bipartite (nodes fall into two classes so that every edge has its ends in different classes, like the famous ''Gas-Water-Electricity'' graph K3,3):} proc isBipartite g { foreach cycle [cycles $g] { if {[llength $cycle]%2==0} {return 0} } return 1 } # Finally, some more possibly helpful routines: proc girth g { set cycles [cycles $g] set min [llength [lindex $cycles 0]] foreach cycle [lrange $cycles 1 end] { if {[llength $cycle]<$min} {set min [llength $cycle]} } set min } proc circumference g { set cycles [cycles $g] set max [llength [lindex $cycles 0]] foreach cycle [lrange $cycles 1 end] { if {[llength $cycle]>$max} {set max [llength $cycle]} } set max } ---- [Arts and crafts of Tcl-Tk programming]