#! /bin/env tclsh

package require Tk
# 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 <ButtonPress-1> [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 eq "auto"} {
        set weight [expr {hypot($dx,$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
}

proc done {} {
    .c configure -cursor {}
    set ::working 0
}

proc walk {} {
    global T
    updateState
    set stop 1
    foreach t $T {if {[info exists ::cost($t)]} {set stop 0; break}}
    if $stop {done ;return}

    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} {done ;return}

    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
        }
    }
    after 500 after idle walk
}

# here's the algorithm itself

proc dijkstra {s} {
    global T
    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
    }

    walk
}

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

pack [label .l -text "Click on a vertex to start Dijkstra's Shortest Path algorithm starting from there"]
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}

pack .c