Version 7 of paths and cycles

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 been 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
 }

In an undirected graph, paths 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}

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
 }

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]]
 }

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}
 }

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
 }