[FF] - 2009-01-31 - Yeah! This is the season of graphs! :-) This program is an animated demonstration of Dijkstra's algorithm for finding the minimum cost path (a.k.a. shortest path) in a cyclic graph. See also [Tcllib]'s package [struct::graphop], a companion package to [struct::graph] which provides a number of graph algorithms, including Dijkstra. [http://dev.gentoo.org/~mescalinum/tclwiki-img/dijkstra.gif] # Again, the procedures which add vertices and edges to canvas, and also in memory (array vertex, edge) proc addVertex {x y} { array set ::vertex {} if {![info exists ::seq]} {set ::seq 0} set ::vertex($::seq) [list $x $y] set r 9 .c create oval \ [expr {$x-$r}] [expr {$y-$r}] \ [expr {$x+$r}] [expr {$y+$r}] \ -fill green -outline black \ -tags [list vertex vertex:$::seq] .c create text $x $y -text [expr {1+$::seq}] \ -tags [list vertex_id vertex_id:$::seq] foreach tag [list vertex:$::seq vertex_id:$::seq] { .c bind $tag [list start $::seq] } return [expr {[incr ::seq]-1}] } proc addEdge {a b {bidi 1} {weight auto}} { array set ::edge {} if {$a == $b} {return} incr a -1 ; incr b -1 set dx [expr {[lindex $::vertex($b) 0]-[lindex $::vertex($a) 0]}] set dy [expr {[lindex $::vertex($b) 1]-[lindex $::vertex($a) 1]}] .c create line \ [lindex $::vertex($a) 0] [lindex $::vertex($a) 1] \ [lindex $::vertex($b) 0] [lindex $::vertex($b) 1] \ -width 1 -fill gray -tags [list edge edge:$a:$b] .c raise vertex .c raise vertex_id if {$weight == "auto"} { set weight [expr {sqrt($dx*$dx+$dy*$dy)}] } set ::edge($a:$b) $weight if $bidi {set ::edge($b:$a) $weight} if {$weight == 0} {return} .c create text \ [expr {[lindex $::vertex($a) 0]+$dx/2}] \ [expr {[lindex $::vertex($a) 1]+$dy/2}] \ -text [expr {round($weight)}] -tags weight } proc adj v { set r {} foreach v [array names ::edge $v:*] {lappend r [lindex [split $v :] 1]} return $r } # here's the algorithm itself proc dijkstra {s} { set T [array names ::vertex] set S [list] array set ::cost {} array set ::prev {} set cur $s lappend S $cur set T [lreplace $T [lsearch -exact $T $cur] [lsearch -exact $T $cur]] foreach v [adj $cur] { set ::cost($v) $::edge($cur:$v) set ::prev($v) $cur } set v_min -1 while 1 { after 500 updateState ; update set stop 1 foreach t $T {if {[info exists ::cost($t)]} {set stop 0; break}} if $stop {break} unset v_min foreach j $T { if {![info exists ::cost($j)]} {continue} if {![info exists v_min] || $::cost($j) <= $::cost($v_min)} { set v_min $j } } set cur $v_min lappend S $v_min set T [lreplace $T [lsearch -exact $T $v_min] [lsearch -exact $T $v_min]] if {[llength $T] == 0} {break} foreach i [adj $v_min] { if {[lsearch -exact $T $i] < 0} {continue} if {![info exists ::cost($i)] || $::cost($i) > [expr {$::cost($v_min)+$::edge($v_min:$i)}]} { set ::cost($i) [expr {$::cost($v_min)+$::edge($v_min:$i)}] set ::prev($i) $v_min } } } } # and the usual GUI stuff: proc updateState {} { .c itemconfigure edge -width 1 -fill gray .c delete cost foreach v [array names ::prev] { .c itemconfigure edge:$v:$::prev($v) -width 3 -fill red .c itemconfigure edge:$::prev($v):$v -width 3 -fill red .c create text \ [expr {[lindex $::vertex($v) 0]+12}] \ [expr {[lindex $::vertex($v) 1]-2}] \ -tags cost -fill red -text [expr {round($::cost($v))}] -anchor nw } } proc start {v} { catch {if $::working return} set ::working 1 .c itemconfigure vertex -fill green .c itemconfigure vertex_id -fill black .c itemconfigure edge -width 1 -fill gray .c delete cost array unset ::cost array unset ::prev .c itemconfigure vertex:$v -fill black .c itemconfigure vertex_id:$v -fill white .c configure -cursor watch dijkstra $v .c configure -cursor {} set ::working 0 } package require Tk pack [label .l -text "Click on a vertex to start Dijkstra's Shortest Path algorithm starting from there"] pack [canvas .c -width 600 -height 500 -background white] foreach {x y} { 20 100 180 120 260 70 80 30 60 180 170 60 180 190 290 150 370 200 420 110 300 10 410 30 510 80 300 240 120 260 490 190 580 150 530 270 400 280 20 270 85 350 205 320 300 320 400 340 540 350 30 430 95 470 190 415 350 450 490 415 570 460 } {addVertex $x $y} foreach {a b} { 10 12 1 4 1 5 1 2 1 6 5 7 2 7 2 6 2 3 7 8 3 8 4 11 9 11 6 3 2 8 8 9 9 10 10 11 3 11 6 11 6 4 5 15 7 15 14 15 7 14 8 14 10 12 11 12 10 13 12 13 14 19 9 19 9 16 10 16 19 16 19 18 16 18 16 17 10 16 13 17 18 17 5 20 20 15 20 21 21 22 21 26 21 27 26 27 21 28 22 28 22 23 23 24 24 29 30 25 30 31 14 23 24 25 28 29 30 29 17 31 } {addEdge $a $b} ---- See also: * [Graphs: BFS an DFS animated demo] * [Graph theory in Tcl] * [More graph theory] ---- !!!!!! %|[Category Graph theory] | [Category Mathematics]|% !!!!!!