##+##########################################################################
#
# robots.tcl -- Plays the old Unix game Robots
# by Keith Vetter, April 2008
#

# TODO:
# faster robots (aliens)
# ?button bar?

package require Tk

image create photo ::img::org::R -data {
    R0lGODlhIgAiALMAAAUEBo6NjgQC/KJSCFEnBkhISc/P0CoqK21ubaipqPj6+NVsBhwYFlVWWLi5
    uG81BCH5BAEAAAIALAAAAAAiACIAAwT/UMhJW6FY2MxzAQzTHeDRnQKQKEAHGEaLckwTyBmD3LML
    XBwEAIDodRAMWADRQCQMh4LDeAoNrUMclQM4BAyKsENo2maI4bQCDNWa0WpFYxhQHMpmRkGRYBzA
    QksvMWYSAGEADXp2CGFRCjxbBw1rLwEHCgx1CgV7LG8OYVaNDQcODgCbnVsMaQYFlGsMQ56QIlSY
    cWoBK2kJbii5usMKqJLExMa4bGHMzmuRHbNZ1Fmz09XZQBNEAYIED+HiXTve5nflBXiGrgADC/AL
    Aw8qwwi1fRiHze7xA0ONhllIE+AWNzCV3sEj0ArZPYLrUqRB9W7Av03DHHQiaNAQwhgWYK8g1PXr
    B0R97QYQONCL2AGGsWzp62QhS0tdBn7N02PhDgYSQH/cjFOSwIIHfroQwYDAFABUI4e9VEigQYI/
    wJAo+uXEWwKv5gAQmIfUhg5gN7o4wJatLRFUIArJnVsoAgA7}
image create photo ::img::org::M -data {
    R0lGODlhIgAiALMAAAQCBPyaBAQC/PxmBDT+zPwCBPz+BJwC/Pz+zPwyZBYAQQAAfhDEAGDuABYS
    AAAAACH5BAEAAAIALAAAAAAiACIAAwTYUMhJKQDz1s07SAn2hV3JXWiqmawAGHAcY635yjJde8YF
    o71d6QVAEI3BjEjHIt56RMty98QlJYBClmnrFb7fqJTbhQKvElBCqGpX1MJMYB7owCvtvD51p6gP
    gIBqg4QJgQd9E3+HhY2MIBtqKo2FeZGQfiEgKJuYLIkCIQQjpKNrLaAABKsXo6qsNSgVq7S1tS1Z
    YWN7ZBsaKxaUvb5TGYfHgXF4yMjKFszHzsbQydJpm8Ek1qHYGd3WktnDuHRzAxLlc+NDbi7tcVsC
    ui5a8vXK8bL0xRwRADs=}
image create photo ::img::org::S -data {
    R0lGODlhIAAgALMAAMwyBPyaNMxmBPz+/PxmNPyaZPxmBAAAAOAB32IA2hYAQQAAfujEAGLuABYS
    AAAAACH5BAEAAAMALAAAAAAgACAAAwTecMhJq7046827/6AnUIABeMB4AefApl8JT+UkpG33Vrv7
    5hsc7za0qEKbmwlpOpJ+GUAA6LqxKs1cTWIgFGQU5cBZ5eEAhECaQCSRMYCCN+6dGyptjXQ9Vfup
    RlR0cnImhHVycFc2fGk4fnyAA02Mh00EhpiIMzRmayxTaFZ7fxkCc0qDbHSnhDJkKY2gkX8so2on
    sa2Iq4e7h8C5pI2htMSyl8B2vDfKwXu2ssdTVsexcs3MvJY4WV97N5B/4saQaCVzwUrb6bxZpMOn
    5JDy1ru/qsq/2z/9/v8AX0QAADs=}
image create photo ::img::org::D -data {
    R0lGODlhIgAiALMAAAQCBPyaBAQC/PxmBDT+zPwCBPz+BJwC/Pz+zPwyZBkAQQAAfgjEAJDuABkS
    AAAAACH5BAEAAAIALAAAAAAiACIAAwTyMElBqxUA1Hyv/FNHAZJGJpoIrmLmvpy3shdg3DieVrPQ
    W7ZcbuejFUFAQ+bmUvKMlB9GibABqs7jhxilWYNKq7bE7SLBQuUMUCibt8qCXG5bx0TjBPNl6H3w
    TyAwJ0hHgIFbAYpSfzWDdnYZjRYfB5aWM5mXB5OBm5yZK5udZjChK4NlpCWZJ4eBHoQrBCSvZjWn
    CbS2GHdvoQS2bHSIZFKAHDG5xy0mGjOfoIW80NHSpHjV1tchgGvbl8yUNFtArFDFCYFEJ8/ox+Ub
    Jb/q9BuK+AMU+PjuSMepRgyih46NBmIY2ghAmAebwV4pHvrSEgEAOw==}

set S(title) "Tk Robots"
set S(w,org) 35
set S(h,org) 25
set S(clrs) {\#7590AE \#5d738b}
set S(robotsPerLevel) 10
set S(score,R) 10
set S(maxSafe) 10
set S(delay,round) 1000
set S(delay,dead) 2000
set S(delay,wait) 200
set S(delay,splat) 1000

set G(state) dead
set G(p,full) 1
set G(p,safe) 1
set G(p,push) 1
set G(p,aliens) 0
##+##########################################################################
#
# Init -- Sets up the size of everything based off of image size
#
proc Init {} {
    global S

    # All sizes based off of image size
    set S(sz) [image width ::img::R]
    set S(w) $S(w,org)
    set S(h) $S(h,org)
    set W [winfo screenwidth .]
    set H [winfo screenheight .]

    set rows [expr {($H - 200) / $S(sz)}]
    if {$S(h) > $rows} { set S(h) $rows}
    set cols [expr {($W - 100) / $S(sz)}]
    if {$S(w) > $cols} { set S(w) $cols}

    set S(cw) [expr {$S(sz)*$S(w)}]
    set S(ch) [expr {$S(sz)*$S(h)}]

    set S(w2) [expr {$S(w)/2}]
    set S(h2) [expr {$S(h)/2}]
    set S(maxRobots) [expr {$S(w)*$S(h)/2}]
}
##+##########################################################################
#
# DoDisplay -- Sets up our game display
#
proc DoDisplay {} {
    global S

    wm title . $S(title)
    wm resizable . 0 0
    if {[lsearch [font names] doneFont] == -1} {
        label .dummy
        set font [font actual [.dummy cget -font]]
        destroy .dummy
        eval font create doneFont "$font -weight bold -size 18"
        eval font create splatFont "$font -weight bold"
        eval font create lblFont "$font -weight bold"
        option add *Label.font lblFont
    }

    frame .btns -bd 2 -relief sunken
    label .btns.left -textvariable G(left) -width 5
    label .btns.lleft -text "Remaining:"
    label .btns.safe -textvariable G(safe) -width 5
    label .btns.lsafe -text "Safe Teleports:"
    label .btns.score -textvariable G(score,pretty) -width 10
    label .btns.lscore -text Score:
    label .btns.lvl -textvariable G(lvl) -width 5
    label .btns.llvl -text "Level:"

    frame .f -bd 2 -relief ridge
    canvas .c -width $S(cw) -height $S(ch) -bd 0 -highlightthickness 0
    .c config -bg [lindex $S(clrs) 0]

    pack .btns -side bottom -fill x
    eval pack [winfo child .btns] -side right
    pack .f -side top
    pack .c -in .f -side top -fill both -expand 1
    DrawGrid
    DoMenus
    DoBindings
}
##+##########################################################################
#
# DoMenus -- Puts up our menus
#
proc DoMenus {} {
    menu .m -tearoff 0
    . configure -menu .m                        ;# Attach menu to main window
    .m add cascade -menu .m.file -label "File" -underline 0
    .m add cascade -menu .m.pref -label "Preferences" -underline 0
    .m add cascade -menu .m.xhelp -label "Help" -underline 0

    menu .m.file -tearoff 0
    .m.file add command -label "New Game" -underline 0 -command NewGame -acc F2
    .m.file add separator
    .m.file add command -label Exit -underline 1 -command exit

    menu .m.pref -tearoff 0
    .m.pref add checkbutton -label "Full Size" -underline 0 -var G(p,full) \
        -command Resize
    .m.pref add separator
    .m.pref add checkbutton -label "Safe Mode" -underline 0 -var G(p,safe)
    .m.pref add checkbutton -label "Push Scrap" -underline 0 -var G(p,push)
    .m.pref add checkbutton -label "Aliens" -underline 0 -var G(p,aliens) \
        -state disabled

    menu .m.xhelp -tearoff 0
    .m.xhelp add command -label "$::S(title) Help" -underline 10 -command Help
    .m.xhelp add command -label "About $::S(title)" -underline 0 -command About
}
##+##########################################################################
#
# DoBindings -- Sets up our keyboard bindings. Different between systems.
#
proc DoBindings {} {
    focus .c

    set win32 {
        <Key-End>         <Key-End>        <Shift-Key-End>   <Shift-Key-End>
        <Key-Down>        <Key-Down>       <Shift-Key-Down>  <Shift-Key-Down>
        <Key-Next>        <Key-Next>       <Shift-Key-Next>  <Shift-Key-Next>
        <Key-Left>        <Key-Left>       <Shift-Key-Left>  <Shift-Key-Left>
        <Key-Clear>       <Key-Clear>      <Shift-Key-Clear> <Shift-Key-Clear>
        <Key-Right>       <Key-Right>      <Shift-Key-Right> <Shift-Key-Right>
        <Key-Home>        <Key-Home>       <Shift-Key-Home>  <Shift-Key-Home>
        <Key-Up>          <Key-Up>         <Shift-Key-Up>    <Shift-Key-Up>
        <Key-Prior>       <Key-Prior>      <Shift-Key-Prior> <Shift-Key-Prior>
        <Key-Return>      <Key-Return>
        <Key-asterisk>    <Key-asterisk>
        <Key-plus>        <Key-plus>
    }
    set x11 {
        <Key-End>         <Key-KP_End>     <Shift-Key-End>   <Shift-Key-KP_1>
        <Key-Down>        <Key-KP_Down>    <Shift-Key-Down>  <Shift-Key-KP_2>
        <Key-Next>        <Key-KP_Next>    <Shift-Key-Next>  <Shift-Key-KP_3>
        <Key-Left>        <Key-KP_Left>    <Shift-Key-Left>  <Shift-Key-KP_4>
        <Key-Clear>       <Key-KP_Begin>   <Shift-Key-Clear> <Shift-Key-KP_5>
        <Key-Right>       <Key-KP_Right>   <Shift-Key-Right> <Shift-Key-KP_6>
        <Key-Home>        <Key-KP_Home>    <Shift-Key-Home>  <Shift-Key-KP_7>
        <Key-Up>          <Key-KP_Up>      <Shift-Key-Up>    <Shift-Key-KP_8>
        <Key-Prior>       <Key-KP_Prior>   <Shift-Key-Prior> <Shift-Key-KP_9>
        <Key-Return>      <Key-KP_Enter>
        <Key-asterisk>    <Key-KP_Multiply>
        <Key-plus>        <Key-KP_Add>
    }
    array set K $win32
    if {[tk windowingsystem] eq "x11"} {
        array set K $x11
    }

    bind .c $K(<Key-Up>)           [list MoveMan -1  0 0]
    bind .c $K(<Shift-Key-Up>)     [list MoveMan -1  0 1]
    bind .c $K(<Key-Down>)         [list MoveMan  1  0 0]
    bind .c $K(<Shift-Key-Down>)   [list MoveMan  1  0 1]
    bind .c $K(<Key-Left>)         [list MoveMan  0 -1 0]
    bind .c $K(<Shift-Key-Left>)   [list MoveMan  0 -1 1]
    bind .c $K(<Key-Right>)        [list MoveMan  0  1 0]
    bind .c $K(<Shift-Key-Right>)  [list MoveMan  0  1 1]
    bind .c $K(<Key-Prior>)        [list MoveMan -1  1 0]
    bind .c $K(<Shift-Key-Prior>)  [list MoveMan -1  1 1]
    bind .c $K(<Key-Home>)         [list MoveMan -1 -1 0]
    bind .c $K(<Shift-Key-Home>)   [list MoveMan -1 -1 1]
    bind .c $K(<Key-Next>)         [list MoveMan  1  1 0]
    bind .c $K(<Shift-Key-Next>)   [list MoveMan  1  1 1]
    bind .c $K(<Key-End>)          [list MoveMan  1 -1 0]
    bind .c $K(<Shift-Key-End>)    [list MoveMan  1 -1 1]
    bind .c $K(<Key-Clear>)        [list MoveMan  0  0 0]
    bind .c $K(<Shift-Key-Clear>)  [list MoveMan  0  0 1]

    bind .c $K(<Key-Return>)       [list SpecialMove wait]
    bind .c $K(<Key-asterisk>)     [list SpecialMove transport]
    bind .c $K(<Key-plus>)         [list SpecialMove safetransport]

    bind .c <F2> NewGame
    bind all <F3> {console show}

    return
    proc foo {args} {
        foreach {a b} $args { puts "$a: '$b'"}
    }
    bind .c <Key> [list foo %%K %K %%k %k %%A %A %%N %N]
}
##+##########################################################################
#
# SpecialMove -- Handle teleport and Wait player moves
#
proc SpecialMove {how} {
    global B G

    if {$G(state) ne "go"} return

    if {$how eq "transport" || $how eq "safetransport"} {
        set safe 0
        if {$how eq "safetransport"} {
            if {$G(safe) > 0} {
                incr G(safe) -1
                incr safe
            }
        }
        set empty [GetEmpty $safe]
        if {$empty eq {}} { set empty [GetEmpty 0] } ;# No safe places
        lassign [lindex [Shuffle $empty] 0] r c
        lassign $B(man) r0 c0
        set B($r0,$c0) ""
        set B($r,$c) M
        set B(man) [list $r $c]
        set G(state) transport
    } elseif {$how eq "wait"} {
        if {$G(p,safe) && ! [eval IsSafe $B(man)]} return
        set G(state) wait
        set G(thisWait) $G(left)
        puts $G(left)
    } else {
        DIE "Bad SpecialMove '$how'"
    }
    MoveRobots
    if {$G(state) eq "transport"} {
        FlashMan
        set G(state) go
    }
    CanMoveSafely
}
##+##########################################################################
#
# MoveMan -- Moves player one unit
#
proc MoveMan {dr dc forever} {
    global B G

    if {! $G(p,safe) && $forever eq "1"} return ;# Unsafe => no auto move

    if {$forever eq "auto"} {
        lassign $G(auto) dr dc
    } elseif {$G(state) ne "go"} return

    set G(auto) [list $dr $dc]

    lassign $B(man) r0 c0
    set r1 [expr {$r0 + $dr}]
    set c1 [expr {$c0 + $dc}]

    set legal [IsLegal $r0 $c0 $dr $dc]
    if {$legal == 0} { set G(state) go; return }
    if {$legal == 2} {                          ;# Scrap
        if {! [MoveScrap $r1 $c1 $dr $dc]} {
            set G(state) go
            return
        }
    } elseif {$G(p,safe) && ! [IsSafe $r1 $c1]} { set G(state) go; return }

    set B($r0,$c0) ""
    set B($r1,$c1) M
    set B(man) [list $r1 $c1]

    if {$forever ne "0"} {
        set G(state) auto
    } else {
        set G(state) go
    }
    MoveRobots
    CanMoveSafely
}
##+##########################################################################
#
# MoveScrap -- Tries moving scrap at r1,c1 in direction dr,dc
#
proc MoveScrap {r1 c1 dr dc} {
    global G B S

    if {[GetCell $r1 $c1] ne "S"} { return 0 }  ;# Not pushing scrap
    if {! $G(p,push)} { return 0}               ;# Not legal to move scrap
    set r2 [expr {$r1 + $dr}]
    set c2 [expr {$c1 + $dc}]
    set what [GetCell $r2 $c2]
    if {$what ne "" && $what ne "R"} { return 0 } ;# Not empty beyond

    # So we can push scrap, is it safe?
    set B($r1,$c1) ""
    set B($r2,$c2) S
    if {$G(p,safe) && ! [IsSafe $r1 $c1]} {
        set B($r1,$c1) S
        set B($r2,$c2) $what
        return 0
    }
    if {$what eq "R"} {
        ldelete B(robots) [list $r2 $c2]
        incr G(score) $S(score,$what)
        incr G(score) $S(score,$what)
        ShowSplat $r2 $c2
    }

    return 1

}
##+##########################################################################
#
# GetEmpty -- Returns list of empty (and optionally safe) board positions
#
proc GetEmpty {safeOnly} {
    global S B

    set empty {}
    for {set row 0} {$row < $S(h)} {incr row} {
        for {set col 0} {$col < $S(w)} {incr col} {
            if {$B($row,$col) eq ""} {
                if {$safeOnly && ! [IsSafe $row $col]} continue
                lappend empty [list $row $col]
            }
        }
    }
    return $empty
}
##+##########################################################################
#
# IsSafe -- Is it safe to move to this square
#
proc IsSafe {r c} {
    global B

    foreach dr {-1 0 1} {
        foreach dc {-1 0 1} {
            set r1 [expr {$r+$dr}]
            set c1 [expr {$c+$dc}]
            if {! [info exists B($r1,$c1)]} continue
            if {$B($r1,$c1) eq "R"} { return 0 }
        }
    }
    return 1
}
##+##########################################################################
#
# IsLegal -- checks for legal move from r,c in direction dr,dc
#   0 if not legal
#   1 if ok (maybe not safe)
#   2 if push scrap
#
proc IsLegal {r c dr dc } {
    set r1 [expr {$r + $dr}]
    set c1 [expr {$c + $dc}]
    set what [GetCell $r1 $c1]
    if {$what eq "X"} { return 0 }              ;# Off the board
    if {$what ne "S"} { return 1 }              ;# Legal, but maybe not safe

    # Hit scrap, see if we can push it
    if {! $::G(p,push)} { return 0}             ;# Forbidden
    set r2 [expr {$r1 + $dr}]
    set c2 [expr {$c1 + $dc}]
    set what [GetCell $r2 $c2]
    if {$what eq "X" || $what eq "S"} { return 0 }
    return 2
}
##+##########################################################################
#
# GetCell -- Get contents of a board position, X for off the board
#
proc GetCell {r c} {
    if {! [info exists ::B($r,$c)]} { return "X" } ;# Off the board
    return $::B($r,$c)
}
##+##########################################################################
#
# Cell2CanvasBox -- Returns l,t,r,b of a cell
#
proc Cell2CanvasBox {row col} {
    global S
    set x0 [expr {$S(sz)*$col}]
    set y0 [expr {$S(sz)*$row}]
    set x1 [expr {$x0 + $S(sz)}]
    set y1 [expr {$y0 + $S(sz)}]
    return [list $x0 $y0 $x1 $y1]
}
##+##########################################################################
#
# Cell2Canvas -- Returns x,y of center of cell
#
proc Cell2Canvas {row col} {
    set x0 [expr {$::S(sz)*$col + $::S(sz)/2}]
    set y0 [expr {$::S(sz)*$row + $::S(sz)/2}]
    return [list $x0 $y0]
}
##+##########################################################################
#
# DrawGrid -- Draws our playing grid
#
proc DrawGrid {} {
    global S

    set clr [lindex $S(clrs) 1]
    for {set row 0} {$row < $S(h)} {incr row} {
        set left [expr {($row & 1) ? 1 : 0}]
        for {set col $left} {$col < $S(w)} {incr col 2} {
            set xy [Cell2CanvasBox $row $col]
            .c create rect $xy -fill $clr -outline {} -width 0
        }
    }
}
##+##########################################################################
#
# NewGame -- Starts a new game
#
proc NewGame {} {
    global G S

    foreach aid [after info] {
        after cancel $aid
    }
    if {$G(state) ne "dead"} {
        set msg "Quit current games?"
        set ans [tk_messageBox -icon question -type yesno -message $msg \
                     -title $S(title)]
        if {$ans ne "yes"} return
    }
    set G(lvl) 0
    set G(score) 0
    set G(score,pretty) 0
    set G(longestWait) 0
    set G(thisWait) 0
    set G(safe) 3
    NextLevel
}
##+##########################################################################
#
# NextLevel -- Initiates next level of play
#
proc NextLevel {} {
    global G S

    incr G(lvl)
    set G(left) [expr {$G(lvl) * $S(robotsPerLevel)}]
    if {$G(left) > $S(maxRobots)} { set G(left) $S(maxRobots) }
    CreateRobots $G(left)
    DrawBoard
    CanMoveSafely
    set G(state) go
}
##+##########################################################################
#
# FinishLevel -- GUI for finishing a level
#
proc FinishLevel {} {
    global G B S
    if {$G(thisWait) > $G(longestWait)} { set G(longestWait) $G(thisWait)}
    set G(state) finished
    ShowMessage $B(man) "Finished Round" done
    after $S(delay,round) NextLevel
}
##+##########################################################################
#
# ShowSplat -- GUI for displaying splat'd robots
#
proc ShowSplat {r c} {
    ShowMessage [list $r $c] Splat! splat
    after $::S(delay,splat) .c delete splat
}
##+##########################################################################
#
# ShowMessage -- Displays a message on our game board, handles clipping
#
proc ShowMessage {xy txt tag} {
    global G B S

    .c delete $tag
    lassign $xy r c
    if {$r < 2} {
        incr r
        set anchor n
    } else {
        incr r -1
        set anchor s
    }
    lassign [Cell2Canvas $r $c] x y

    set n [.c create text $x $y -text $txt -font ${tag}Font -fill red \
              -tag $tag -anchor $anchor]
    set xy [.c bbox $n]
    set xy2 {}
    foreach val $xy dxy {-10 -10 10 10} { lappend xy2 [expr {$val + $dxy}]}
    set what [expr {$tag eq "splat" ? "oval" : "rect"}]
    set n2 [.c create $what $xy2 -fill white -outline black -width 3 -tag $tag]
    .c raise $n $n2

    # Remove left/right clipping
    lassign [.c bbox $tag] x0 . x1 .
    if {$x0 < 0} { .c move $tag [expr {0 - $x0}] 0 }
    if {$x1 > $S(cw)} { .c move $tag [expr {$S(cw) - $x1}] 0}
}
##+##########################################################################
#
# CreateRobots -- Puts N robots on the board
#
proc CreateRobots {n} {
    global B S

    unset -nocomplain B

    set empty {}
    for {set row 0} {$row < $S(h)} {incr row} {
        for {set col 0} {$col < $S(w)} {incr col} {
            set B($row,$col) ""
            lappend empty [list $row $col]
        }
    }
    set B(man) [list $S(h2) $S(w2)]
    set B($S(h2),$S(w2)) "M"
    ldelete empty $B(man)

    set empty [Shuffle $empty]

    for {set i 0} {$i < $n} {incr i} {
        lassign [lindex $empty $i] r c
        if {$B($r,$c) ne ""} {DIE "Bad empty list" }
        set B($r,$c) R
        lappend B(robots) [list $r $c]
    }
}
##+##########################################################################
#
# DrawBoard -- Displays the current game board
#
proc DrawBoard {} {
    global S B
    .c delete R M S D done flash

    for {set row 0} {$row < $S(h)} {incr row} {
        for {set col 0} {$col < $S(w)} {incr col} {
            if {$B($row,$col) ne ""} { DrawItem $row $col $B($row,$col)}
        }
    }
    .c raise splat
}
##+##########################################################################
#
# DrawItem -- Draws one item on the board
#
proc DrawItem {row col what} {
    if {$what eq ""} return
    set xy [Cell2Canvas $row $col]
    set img "::img::$what"
    if {[info commands $img] ne ""} {
        .c create image $xy -tag $what -image $img -anchor c
    } else {
        .c create text $xy -tag $what -anchor c -text $what -fill white
    }
}
##+##########################################################################
#
# StepBoard -- Moves all robots one step
#
proc StepBoard {} {
    global B G S

    # Erase robots from old board
    foreach robot $B(robots) {
        lassign $robot r c
        set B($r,$c) ""
    }

    lassign $B(man) r0 c0
    set dead 0
    set new {}
    foreach robot $B(robots) {
        lassign $robot r c

        set dr [expr {$r > $r0 ? -1 : $r < $r0 ? 1 : 0}]
        set dc [expr {$c > $c0 ? -1 : $c < $c0 ? 1 : 0}]
        incr r $dr
        incr c $dc

        set what $B($r,$c)
        if {$what eq ""} {
            set B($r,$c) R
            lappend new [list $r $c]
        } elseif {$what eq "S"} {
            incr G(score) $S(score,R)
            if {$G(state) eq "wait" && $G(safe) < $S(maxSafe)} {
                incr G(safe)
            }
        } elseif {$what eq "R"} {
            set B($r,$c) S
            ldelete new [list $r $c]
            incr G(score) $S(score,R)
            incr G(score) $S(score,R)
            if {$G(state) eq "wait" && $G(safe) < $S(maxSafe)} {
                incr G(safe)
            }
            if {$G(state) eq "wait" && $G(safe) < $S(maxSafe)} {
                incr G(safe)
            }
        } elseif {$what eq "M" || $what eq "D"} {
            set B($r,$c) D
            set dead 1
        } else {
            DIE "bad square: $r $c '$what'"
        }
    }
    set B(robots) $new
    set G(left) [llength $B(robots)]
    set G(score,pretty) [comma $G(score)]
    return $dead
}
##+##########################################################################
#
# MoveRobots -- Handles high-level of moving all robots
#
proc MoveRobots {} {
    global G B S

    set n [StepBoard]
    DrawBoard
    if {$n} {
        GameOver
    } elseif {$B(robots) eq {}} {
        FinishLevel
    } elseif {$G(state) eq "wait"} {
        after $S(delay,wait) MoveRobots
    } elseif {$G(state) eq "auto"} {
        after $S(delay,wait) MoveMan - - auto
    }
}
##+##########################################################################
#
# GameOver -- End of game stuff
#
proc GameOver {} {
    global B G S
    set G(state) dead
    ShowMessage $B(man) "You died!" done
    after $S(delay,dead) PlayAgain
}
##+##########################################################################
#
# PlayAgain -- After handler for playing again
#
proc PlayAgain {} {
    global G S

    .c delete done
    set msg "Level: $G(lvl)\n"
    append msg "Score: $G(score,pretty)\n"
    append msg "Wait: $G(longestWait)\n\n"
    append msg "Play Again?"
    set ans [tk_messageBox -icon question -type yesno -message $msg \
                 -title $S(title)]
    if {$ans eq "yes"} NewGame
}
##+##########################################################################
#
# Shuffle -- Randomizes a list
#
proc Shuffle { l } {
    set len [llength $l]
    set len2 $len
    for {set i 0} {$i < $len-1} {incr i} {
        set n [expr {int($i + $len2 * rand())}]
        incr len2 -1

        set temp [lindex $l $i]                 ;# Swap elements at i & n
        lset l $i [lindex $l $n]
        lset l $n $temp
    }
    return $l
}
##+##########################################################################
#
# FlashMan -- Flashes our player after a teleport so you can find it
#
proc FlashMan {} {
    global B

    set clr [expr {[CanMoveSafely] ? "yellow" : "red"}]
    set xy [eval Cell2CanvasBox $B(man)]
    .c delete flash
    .c create rect $xy -tag flash -fill white
    .c raise M flash

    for {set i 0} {$i < 3} {incr i} {
        .c itemconfig flash -fill white
        update idletasks; after 100
        .c itemconfig flash -fill $clr
        update idletasks; after 100
    }
    .c delete flash
}
##+##########################################################################
#
# CanMoveSafely -- Determines if a player has a safe move to make
#
proc CanMoveSafely {} {
    global B

    lassign $B(man) r0 c0
    foreach dr {-1 0 1} {
        foreach dc {-1 0 1} {
            set r1 [expr {$r0+$dr}]
            set c1 [expr {$c0+$dc}]
            set n [IsLegal $r0 $c0 $dr $dc]
            if {$n == 0} continue

            ;# BUG: some pushes are actually safe because we splat the robot
            if {[IsSafe $r1 $c1]} {return 1}
        }
    }
    set xy [eval Cell2CanvasBox $B(man)]
    .c delete flash
    .c create rect $xy -tag flash -fill red
    .c raise M flash
    return 0
}
##+##########################################################################
#
# About -- Simple about dialog
#
proc About {} {
    set msg "$::S(title)\nby Keith Vetter April 2008\n\n"
    append msg "A tk implementation of the hoary Robots game."
    tk_messageBox -message $msg -icon info
}
##+##########################################################################
#
# comma -- Puts commas into a number
#
proc comma { num } {
    while {[regsub {^([-+]?[0-9]+)([0-9][0-9][0-9])} $num {\1,\2} num]} {}
    return $num
}
##+##########################################################################
#
# ldelete -- deletes element from a list
#
proc ldelete {listName elem} {
    upvar 1 $listName myList
    set n [lsearch $myList $elem]
    set myList [lreplace $myList $n $n]
    return $myList
}
##+##########################################################################
#
# DIE -- Our error handler
#
proc DIE {msg} {
    puts $msg
    error $msg
    set ::G(state) error
}
##+##########################################################################
#
# FullSize -- Installs full size images
#
proc FullSize {} {
    foreach img [info commands ::img::org::*] {
        set name [lindex [split $img ":"] end]
        set iname "::img::$name"
        catch {image delete $iname}
        image create photo $iname
        $iname copy $img
    }
}
##+##########################################################################
#
# HalfSize -- Installs half sized images
#
proc HalfSize {} {
    foreach img [info commands ::img::org::*] {
        set name [lindex [split $img ":"] end]
        set iname "::img::$name"
        catch {image delete $iname}
        image create photo $iname
        $iname copy $img -subsample 2 2
    }
}
##+##########################################################################
#
# Help -- Simple help screen
#
proc Help {} {
    catch {destroy .helper}
    toplevel .helper
    wm transient .helper .
    wm title .helper "$::S(title) Help"
    if {[regexp {(\+[0-9]+)(\+[0-9]+)$} [wm geom .] => wx wy]} {
        wm geom .helper "+[expr {$wx+35}]+[expr {$wy+35}]"
    }
    set w .helper.t
    scrollbar .helper.sb -command [list $w yview]
    text $w -wrap word -width 70 -height 29 -pady 10 \
        -yscrollcommand [list .helper.sb set]

    button .helper.quit -text Dismiss -command {catch {destroy .helper}}
    pack .helper.quit -side bottom -pady 10
    pack .helper.sb -side right -fill y
    pack $w -side left -fill both -expand 1

    $w tag config title -justify center -font {{Times Roman} 18 bold}
    $w tag config red -foreground red
    $w tag config header -font {{Times Roman} 12 bold} -lmargin1 5

    #$w tag config n -lmargin1 5 -lmargin2 5
    $w tag config n -lmargin1 .25i
    set lm2 [expr {5 + [font measure [$w cget -font] " o "]}]
    $w tag config b -lmargin1 5 -lmargin2 $lm2

    $w insert end "$::S(title)" {title red} "\nby Keith Vetter\n" title
    $w insert end "April 2008\n\n" title

    # Objective
    set txt "The object of the game is to avoid being overrun by \n"
    append txt "rampaging robots who's only goal is to kill you.\n\n"
    append txt "Your player starts in the middle of a rectangular grid\n"
    append txt "with robots placed at random locations. Your turn consist\n"
    append txt "of moving up, down, left, right, diagonally or staying put,\n"
    append txt "followed by every robot moving one square closer to you.\n\n"
    append txt "If you collide with a robot, you die and the game ends.\n"
    append txt "However, if two robots collide they both die and leave behind\n"
    append txt "a scrap heap. Also, if a robot hits a scrap heap, it dies.\n\n"
    $w insert end "Objective\n" header $txt n

    # Teleport
    set txt "A player can also teleport--jump to a different place on the\n"
    append txt "grid. Beware, the location selected is random and you might\n"
    append txt "land next to a robot and die. However, there are a limited\n"
    append txt "number of 'safe' teleports which are guaranteed to land you\n"
    append txt "safely (see 'WAIT' below).\n\n"
    $w insert end "Teleport\n" header $txt n

    # Moving
    set txt "You move your player by using the 1-9 keys on the numeric\n"
    append txt "keypad (the 5 key stays in place). Holding down the shift\n"
    append txt "key while pressing a movement key will auto-repeat that move\n"
    append txt "while it's safe to do so.\n\n"
    append txt "The '*' key teleports randomly and the '+' key teleports\n"
    append txt "safely. The 'Enter' key is the 'WAIT' button.\n\n"
    $w insert end "Moving\n" header $txt n

    # Wait
    set txt "When you press the 'WAIT' button, you will no longer be able\n"
    append txt "to move until all the robots are dead or you are killed.\n"
    append txt "Doing so is dangerous, but you earn an extra safe teleport\n"
    append txt "for every robot that dies, up to a maximum of ten.\n\n"
    $w insert end "Wait\n" header $txt n

    # Scoring
    set txt "You get 10 points for every robot death, double if\n"
    append txt "push a scrap heap on top of one.\n\n"
    $w insert end "Scoring\n" header $txt n

    $w insert end "Preferences\n" header
    set txt " o 'Safe Mode' won't let you move into the path of a robot\n"
    $w insert end $txt b
    set txt " o 'Push Scrap' lets you push scrap around--bonus for killing "
    append txt "a robot\n"
    $w insert end $txt b
    set txt " o 'Aliens' are creatures twice as fast robots "
    append txt "(not yet implemented)"
    $w insert end $txt b
    $w config -state disabled

}
##+##########################################################################
#
# Resize -- Toggles between half and full size
#
proc Resize {} {
    global S G

    if {$G(state) ne "dead"} {
        set msg "Quit current games?"
        set ans [tk_messageBox -icon question -type yesno -message $msg \
                     -title $S(title)]
        if {$ans ne "yes"} return
    }
    if {$G(p,full)} {
        FullSize
    } else {
        HalfSize
    }

    set G(state) dead
    eval destroy [winfo child .]
    wm geom . {}
    . config -width 200 -height 200
    Init
    DoDisplay
    NewGame
}

################################################################
FullSize
# HalfSize
Init
DoDisplay
NewGame
return