}
package require Tk

set info "TkSnake 1.0 - Richard Suchenwirth 2003


Click 'New' to start.
Steer snake with cursor keys.
Snake dies if it touches itself.
Red fruit is good, makes snake grow.
Blue fruit is poison, makes snake die."

frame .f
button .f.1 -text New -command {reset .c}
button .f.2 -text Pause -command {set pause [expr {!$pause]}}
set pause 0
label .f.3 -textvar g(score) -background black -foreground green -width 6
checkbutton .f.4 -text Poison -variable g(poison)
eval pack [winfo children .f] -side left
canvas .c -bg lightgreen
.c create rect 5 5 235 235 -fill {} -width 3 -tag barrier
.c create text 20 20 -text $info -anchor nw -tag snake
eval pack [winfo children .] 
wm geometry . 240x300+0+0
bind . <Up>    {set g(direction) {0 -1}}
bind . <Down>  {set g(direction) {0  1}}
bind . <Left>  {set g(direction) {-1 0}}
bind . <Right> {set g(direction) {1  0}}
bind . <Return> {reset .c}


proc reset c {
    global g
    array set g {score 0 snake {} direction {0 -1} poison 0}
    $c delete snake food poison
    set x 100
    set y 140
    foreach i {1 2 3 4} {box $c $x [incr y -8]}
    somewhere $c food
    foreach event [after info] {after cancel $event}
    every 250 {move .c}
}


proc box {c x y} {
    global g
    set id [$c create rect [expr {$x-4}] [expr {$y-4}] \
        [expr {$x+4}] [expr {$y+4}] -fill darkgreen -tag snake]
    set g(snake) [linsert $g(snake) 0 $id]
}


proc every {ms body} {eval $body; after $ms [namespace code [info level 0]]}


proc somewhere {c tag} {
    set ok 0
    while {!$ok} {
        set x [expr {12+int(rand()*27)*8}]
        set y [expr {12+int(rand()*27)*8}]
        set closest [$c find closest $x $y 3]
        set tags [$c gettags $closest]
        if {$tags != "snake"} {incr ok}
    }
    set color [expr {$tag eq {food}? {red} : {blue}}]
    $c create oval [expr {$x-3}] [expr {$y-3}] [
        expr {$x+3}] [expr {$y+3}] -fill $color -outline $color -tag $tag
}


proc move c {
    if $::pause return
    global g
    set neck [lindex $g(snake) 0]
    foreach {x0 y0 x1 y1} [$c bbox $neck] break
    foreach {fx fy} $g(direction) break
    set x [expr {($x1+$x0)/2 + 8*$fx}]
    set y [expr {($y1+$y0)/2 + 8*$fy}]
    set next [$c find closest $x $y 2]
    set target [$c gettags $next]
    if {$next == [lindex $g(snake) 1]} return ;# (1)
    if {$next == $neck} {set target ""}
    set fed 0
    switch -- $target {
        poison - snake {
            $c itemconfig snake -fill red
            $c create text 120 120 -text "GAME OVER" \
                -font {Helvetica 24 bold} -tag snake
            return
        }
        barrier {
            set g(direction) [list $fy $fx]
            return
        }
        food {
            set lsnake [llength $g(snake)]
            if {$g(score)<100 && $g(score)+$lsnake>100} {
                set g(poison) 1
            }
            incr g(score) $lsnake
            $c delete food
            $c itemconfig snake -fill yellow
            after 200 $c itemconfig snake -fill darkgreen
            somewhere $c food
            if $g(poison) {somewhere $c poison}
            incr fed
        }
    }
    box $c $x $y
    if !$fed {
        $c delete [lindex $g(snake) end]
        set g(snake) [lrange $g(snake) 0 end-1]
    }
}

if 0 {