if 0 {[Richard Suchenwirth] 2003-04-21 - This little Tk game features a
snake that creeps around its place, eating fruit where available and
growing from it, while touching itself or eating poison mean sure death.

[http://mini.net/files/TkSnake.jpg]
}
 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 [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=="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]
    }
  }

----

''[escargo] 22 Apr 2003'' - Note that hitting a cursor key that makes you go backward
counts as hitting yourself and is instantly fatal. - [RS]: Thanks for testing and reporting! The added line marked (1) above changes the behavior to more intuitive: the snake stops when directed backward, and moves on when you hit another arrow key. An alternative to the [[Pause]] button.
----
[Category Games] - [Arts and crafts of Tcl-Tk programming]