Tk Robots2
Keith Vetter 2008-04-29 - Here's an enhancement to my recent Tk Robots game. The main difference is a new type of robot, which I'm calling an alien, which moves twice as fast as a normal robot.
New Features in 2.0:
- faster alien robots
- 5 levels of difficulty
- show safe moves mode
- high scores saved and displayed (see High Score Package)
- 6 new human character images
uniquename 2013aug01
This image shows one of the human character types (in the middle of the board), as well as a couple of robot types.
##+##########################################################################
#
# robots2.tcl -- Plays the old Unix game Robots w/ some new features
# by Keith Vetter, April 2008
#
# New Features:
# o twice as fast robots (aliens)
# o 5 levels of difficulty
# o show safe mode
# o high scores
# o 6 new human images
package require Tk 8.5
#package require highscore (included in this source)
set S(title) "Tk Robots2"
set S(clrs) {\#7590AE \#5d738b}
set S(delay,dead) 2000
set S(delay,high) 500
set S(delay,round) 1000
set S(delay,splat) 1000
set S(delay,wait) 200
set S(w,org) 35
set S(h,org) 25
set S(maxSafe) 10
set S(score,A) 20
set S(score,R) 10
# TYPE: robots aliens canPush safeTeleports canSafeteleport
array set T {
"Classic" {10 0 0 0 0}
"Safe Classic" {10 0 1 3 1}
"Robots2" {8 2 1 3 1}
"Hard" {5 5 1 3 1}
"Killer" {2 8 1 3 1}
}
set T(names) {"Classic" "Safe Classic" "Robots2" "Hard" "Killer"}
foreach t $T(names) { set HIGH($t) {} }
set G(type) Robots2
set G(p,full) 1
set G(p,push) 1
set G(p,safe) 1
set G(p,safeTeleport) 1
set G(p,showSafe) 1
set G(state) dead
##+##########################################################################
#
# 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/3}]
::HighScore::Init $::T(names)
}
##+##########################################################################
#
# 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
LabelLabel .btns.rem "Remaining:" G(left,pretty) 12
LabelLabel .btns.safe "Safe Teleports:" G(safeTeleports) 5
LabelLabel .btns.score "Score:" G(score,pretty) 10
LabelLabel .btns.lvl "Level:" G(lvl) 5
LabelLabel .btns.type "Type:" G(type) 10
eval pack [winfo child .btns] -side right
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
pack .f -side top
pack .c -in .f -side top -fill both -expand 1
DrawGrid
DoMenus
DoBindings
}
##+##########################################################################
#
# LabelLabel -- Creates sunken frame with 2 labels inside
#
proc LabelLabel {w lbl var width} {
frame $w -bd 2 -relief sunken
label $w.a -text $lbl -bd 0
label $w.b -textvariable $var -width $width
pack $w.a -side left -fill x -expand 1 -padx {3 0}
pack $w.b -side left -fill x -expand 1
return $w
}
##+##########################################################################
#
# 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 command -label "High Scores" -underline 0 -command ShowHighScore
.m.file add separator
.m.file add command -label Exit -underline 1 -command exit
menu .m.pref -tearoff 0
.m.pref add cascade -label "Game Type" -underline 0 -menu .m.pref.type
.m.pref add separator
.m.pref add checkbutton -label "Full Size" -underline 0 -var G(p,full) \
-command Resize
.m.pref add checkbutton -label "Safe Mode" -underline 0 -var G(p,safe)
.m.pref add checkbutton -label "Show Moves" -underline 5 \
-var G(p,showSafe) -command CanMoveSafely
.m.pref add separator
.m.pref add command -label "Save Settings" -command {SaveConfig config}
menu .m.pref.type -tearoff 0
foreach lbl $::T(names) {
.m.pref.type add radiobutton -label $lbl -command NewGameType \
-variable G(type) -value $lbl
}
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>
<Key-slash> <Key-slash>
}
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>
<Key-slash> <Key-KP_Divide>
}
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 $K(<Key-slash>) [list ShowSafeMoves]
bind .c <F2> NewGame
bind all <F3> {console show}
return
destroy .top
toplevel .top
proc foo {args} {
foreach {a b} $args { puts -nonewline "$a: '$b' "}
}
bind .top <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(safeTeleports) > 0} {
incr G(safeTeleports) -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 };# Can't move, turn off auto
if {$legal == 2} { ;# Scrap
if {! [MoveScrap $r1 $c1 $dr $dc]} { ;# Can't move, turn off auto
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" && $what ne "A"} { return 0 } ;# Not empty
# 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" || $what eq "A"} {
ldelete B(where,$what) [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
}
##+##########################################################################
#
# 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
}
##+##########################################################################
#
# IsSafe -- Is it safe to move to this square
#
proc IsSafe {r c} {
set sMINI [MakeMiniBoard $r $c]
set n [IsSafe2 $sMINI]
return $n
}
##+##########################################################################
#
# IsSafe2 -- Determines is a position given by MINI board is safe
# MINI board is 5x5 board
#
proc IsSafe2 {b} {
# MINI is 5x5 grid w/ player in the middle
array set MINI $b
foreach r {-1 0 1} {
foreach c {-1 0 1} {
if {$r == 0 && $c == 0} continue
if {$MINI($r,$c) eq "R" || $MINI($r,$c) eq "A"} { return 0 }
}
}
foreach a {-2 -1 0 1 2} {
foreach pos [list 2,$a -2,$a $a,2 $a,-2] {
if {$MINI($pos) ne "A"} continue
set inner [string map {2 1 -1 0 1 0} $pos]
if {$MINI($inner) eq "S"} continue ;# Scrap blocks alien
set cnt 0
set outer1 [string map {1 2 0 -1} $inner]
set outer2 [string map {1 2 0 0} $inner]
set outer3 [string map {1 2 0 1} $inner]
foreach outer [lsort -unique [list $outer1 $outer2 $outer3]] {
if {$MINI($outer) eq "R" || $MINI($outer) eq "A"} { incr cnt }
}
if {$cnt == 0} { DIE "bad IsSafe2" }
if {$cnt == 1} { return 0 } ;# Alien can get you
}
}
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 eq "R" || $what eq "A"} { return 0 }
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 -tag ggrid
}
}
}
##+##########################################################################
#
# NewGame -- Starts a new game
#
proc NewGame {} {
global G S T
foreach aid [after info] {
after cancel $aid
}
::HighScore::_TearDown
if {$G(state) ne "dead" && $G(moves) > 0} {
set msg "Quit current games?"
set ans [tk_messageBox -icon question -type yesno -message $msg -title $S(title)]
if {$ans ne "yes"} return
}
::img::M blank
::img::M copy [lpick [info commands ::img::org::_M*]]
::img::A blank
::img::A copy [lpick [info commands ::img::org::_A*]]
lassign $T($G(type)) G(t,R) G(t,A) G(p,push) G(safeTeleports) G(p,safeTeleport)
set G(lvl) 0
set G(score) 0
set G(score,pretty) 0
set G(longestWait) 0
set G(thisWait) 0
set G(moves) 0
NextLevel
}
##+##########################################################################
#
# NewGameType -- Changes game type and starts a new game
#
proc NewGameType {} {
set ::G(state) dead
NewGame
}
##+##########################################################################
#
# NextLevel -- Initiates next level of play
#
proc NextLevel {} {
global G S B
incr G(lvl)
set lvl [expr {min($G(lvl),$S(maxRobots)/($G(t,R)+$G(t,A)))}]
set R [expr {$lvl * $G(t,R)}]
set A [expr {$lvl * $G(t,A)}]
set G(left) [expr {$R + $A}]
CreateRobots $R $A
set G(left,pretty) "[llength $B(where,R)]+[llength $B(where,A)]=$G(left)"
DrawBoard
set G(state) go
CanMoveSafely
}
##+##########################################################################
#
# 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 {rCnt aCnt} {
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]
set B(where,R) {}
set B(where,A) {}
for {set i 0} {$i < $rCnt+$aCnt} {incr i} {
lassign [lindex $empty $i] r c
if {$B($r,$c) ne ""} {DIE "Bad empty list" }
set who [expr {$i >= $rCnt ? "A" : "R"}]
set B($r,$c) $who
lappend B(where,$who) [list $r $c]
}
}
##+##########################################################################
#
# DrawBoard -- Displays the current game board
#
proc DrawBoard {} {
global S B
.c delete R M S D A 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 {onlyAliens} {
global B G S
set raList [MakeRobotList]
foreach {who r c} $raList {
set B($r,$c) ""
}
lassign $B(man) r0 c0
set dead 0
set new(R) {}
set new(A) {}
foreach {who r c} $raList {
if {$who == "A" || ! $onlyAliens} {
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) $who
lappend new($who) [list $r $c]
} elseif {$what eq "S"} {
incr G(score) $S(score,$who)
if {$G(p,safeTeleport) && $G(state) eq "wait" && $G(safeTeleports) < $S(maxSafe)} {
incr G(safeTeleports)
}
} elseif {$what eq "R" || $what eq "A"} {
set B($r,$c) S
ldelete new($what) [list $r $c]
incr G(score) $S(score,$who)
incr G(score) $S(score,$what)
if {$G(p,safeTeleport) && $G(state) eq "wait" && $G(safeTeleports) < $S(maxSafe)} {
incr G(safeTeleports)
}
if {$G(p,safeTeleport) && $G(state) eq "wait" && $G(safeTeleports) < $S(maxSafe)} {
incr G(safeTeleports)
}
} elseif {$what eq "M" || $what eq "D"} {
set B($r,$c) D
set dead 1
} else {
DIE "bad square: $r $c '$what'"
}
}
set B(where,R) $new(R)
set B(where,A) $new(A)
set G(left) [expr {[llength $B(where,R)] + [llength $B(where,A)]}]
set G(left,pretty) "[llength $B(where,R)]+[llength $B(where,A)]=$G(left)"
set G(score,pretty) [comma $G(score)]
return $dead
}
##+##########################################################################
#
# MakeRobotList -- Makes a list of all robots and aliens
#
proc MakeRobotList {} {
global B
set raList {}
foreach arg {R A} {
if {$B(where,$arg) eq {}} continue
set thisList "$arg [join $B(where,$arg) \ $arg\ ]"
set raList [concat $raList $thisList]
}
return $raList
}
##+##########################################################################
#
# MoveRobots -- Handles high-level of moving all robots
#
proc MoveRobots {} {
global G B S
incr G(moves)
set n [StepBoard 0]
DrawBoard
update idletasks
if {! $n} {
set n [StepBoard 1]
DrawBoard
}
if {$n} {
GameOver
} elseif {$B(where,R) eq {} && $B(where,A) 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
set n [Add2Highscore]
ShowMessage $B(man) "You died!" done
after $S(delay,high) ShowHighScore $n
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"
append msg "Moves: [comma $G(moves)]\n"
append msg "\n"
append msg "Play Again?"
set ans [tk_messageBox -icon question -type yesno -message $msg -title $S(title)]
if {$ans eq "yes"} NewGame
}
##+##########################################################################
#
# FlashMan -- Flashes our player after a teleport so you can find it
#
proc FlashMan {} {
global B G
set n [CanMoveSafely]
if {$G(p,showSafe) && $n} return
set clr [expr {$n ? "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 G
.c delete flash
lassign $B(man) r0 c0
if {$B($r0,$c0) eq "D"} return ;# Already dead
set safeties {}
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
array set MINI [MakeMiniBoard $r1 $c1]
if {$n == 2} { ;# Update w/ pushed scrap
set MINI($dr,$dc) S
}
if {[IsSafe2 [array get MINI]]} {
lappend safeties [list $r1 $c1]
}
}
}
set B(safeties) $safeties
if {$safeties ne {}} {
if {$G(p,showSafe) && $G(state) eq "go"} ShowSafeMoves
return 1
}
set xy [eval Cell2CanvasBox $B(man)]
.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
}
##+##########################################################################
#
# lpick -- Picks an element from a list at random
#
proc lpick {l} {
return [lindex $l [expr {int(rand()*[llength $l])}]]
}
##+##########################################################################
#
# 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
}
}
##+##########################################################################
#
# Resize -- Toggles between half and full size
#
proc Resize {} {
global S G
if {$G(state) ne "dead" && $G(moves) > 0} {
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
}
################################################################
image create photo ::img::org::_A0 -data {
R0lGODlhIgAiALMAAAQKJAT+BFdVTa4CBGZvoiYkHpmWiXp1bNzWxO/t5qesxDEzRVQCBERLa/wC
BLSunCH5BAEAAAEALAAAAAAiACIAAwT/MMhJKxus6s3rcEMnjgFwACRZrGxxIEfLphIAPHiu7/hK
moigcBhMIBJGI6IwAghs0KhUKmCKnICFtsFtEL4JBVe7cFo7TkN20fWCxQ0twLD8PdTs7pcQHs8f
dU0Hd3lce31xBoBngg8AbYdwN4E0JmpTUXSMlTyKO5uVBqKjpKOgNDKpPjRXAgcGp6wbUbGsKDUm
gwiwZ7WzJyWuAjkJBjEllI0ADCbDOsUFzC++EyYP0c07u9iD1BIXGCWYUAHgGT/k5QPr7OHiNj+6
TNk62yXyjdfBB86AovOD9F3hJ9AJPzoGntQgSC2blXG3HP4oU01hjSrVKMr65k7duY0VH4Dcuodg
JMh7OEqiBGRyowktju7BbCkriw2KNm2OiAAAOw== }
image create photo ::img::org::_A1 -data {
R0lGODlhIgAkALMAAAQCFAT+BD9FP4SChLTGuFxiXCQpJairqdvu405XVDo+PKy+tGx5c+z+9IyZ
ksPSxCH5BAEAAAEALAAAAAAiACQAAwT/MMhJq704B8W7V1q4LURjnicoXsqCvulaKU/DOHieM82j
yhtHw0EoGo1Cx0+m4AlhpuRy1RwKANgsQCBkTEVNByOrICiyNy9wsmWMBaXG1X1dswUnRByBMNXt
EgBxBAcCBycEAIBsOCUCjw0EOIqLAQA3JQAGAJFilIuaRA2anJKblWxaWpUdWJuqrgayBkwNfAAL
Dpu7oQu4NbQhLQu3Cw/Htj3IAA8LLsEZCjlXxsguxzUACc0N0BiyAq8JKDwosQZfFQYIsljO7+98
utoJCOkUmu0GOPDvOK/tQuTbJctBgoMIZ8X6hGEglgMGBhyYOHGAgQNZAmo4k1GTRIoHUCwCKKBK
WDstB+Ah8HVSo4YslrKozBiT4QpVtDLKQmUgHq2exNih0rLT1UFvdvY5EwqUD9I1Son9dBD0qYye
VKUGMJAgqFBAs8JuDbsTFaoIADs= }
image create photo ::img::org::_M0 -data {
R0lGODlhIgAiALMAADwXF8qYR2tXJrIUDG9yepmMjw44WJF2MUg2HgT+BOvbftTWNNza1IxGJOBY
NB1qnSH5BAEAAAkALAAAAAAiACIAAwT/MMlJJbo4180rEkcQXIIgIl3qlUfrtC2qrs10NHeL7w51
gClSaUgsNY5I5EWVaTqfstkE8SuyolLOJ6AIlLiBAzZbKSkQXS76R9Z6RXD44dz2hBX4ORdPr1Oo
e2Z8An4eIQJpCoiKhYYjJWiMjY58kpOGeoSXf1BjdRgFBQMApAUOBAUIR34IXAQMBQADA6YDrwVc
NWStIrcBsrMCvrm7Ig3DpCa3vLpSrSgGsCIAcLcJDQHNM88JBqFxvQwo2NpMI90GBuABBATj2bvu
FiQLCwIYFmJZvDIGDw8wAvwzYOGeJw98lqT7x/BBugQX9hycUgmaw3QYHULsgmcixTMWKTV2GwiR
374lI0X6E4mvEIAPMl7e2yRBZkyYNF+2lDnzEqmfNX8CmBEBADs= }
image create photo ::img::org::_M1 -data {
R0lGODlhIgAiALMAABEOF5SSBEtHE6imqB8maDctFGFcTUE8KAT+BObVg9TKBODh4KmbYvz0vfHo
BHRmFCH5BAEAAAgALAAAAAAiACIAAwT/EMlJpbgY1823CIojOkmTCF1afUobiqWDqinruC/ZyHTH
vq6RaNaj/Fqi4EhBLCIy0OjFOSkACgxGYsstMawF6uSa3R4S51LCKh5jD/Bz/MxuI86MBWChze+3
YXYHZQ0NBiaFJl92ElhaaHBdgYwFBo9ZjwkMB4xVlptwj5OdB5WZgJykBgMCpltfAgMGqWJnBgsC
c3EEC4e0RWm3ApjEAr0lvyqDW6sLA14lDQPHyMB9zQvZ2tmyBmbWkAPi4+SyB97JHYNZB9Pb7+to
1uzu5drrm0UFAg8F7c7cAi4oxW9UigIP+gFYyLAhQ4T99BUEQKCixYsErhR0UqAjRYsMLC9e6Wjn
Y0UACExm7JRSZEuQLFWilBkzw8x9F1AyApCBjUYMOts4XJhyqIoIADs= }
image create photo ::img::org::_M2 -data {
R0lGODlhIgAiALMAABwaFa2fPjE/f11JIo6UkoJqPjwwJDEzR0hIRgT+BOzfrObUV+nr30hWtamu
qaSObCH5BAEAAAkALAAAAAAiACIAQwT/MMlJk7Em61u7n8YQBEtpagP3rdNQkOYysCtgAxmi77xx
A7SKgeAoOhAWArGIDHY2mYKrUNA9VM7WYrRgBBjbEmmWxSByvR2xV5YYBI34YR6PC9qUjGuQ0g8e
KXggKSMjIXxUgYIhAXwuC1J8jVhtBlxbl1uUWQY9UJ08ZTefpBo2QSKNCQcCCnWvdgCpZFmsdXcH
r3eCbn4Feg+/vCBRUgaJBsGbThqFh1S/wouEJgGHKYp4jDADMiUKk7ySDAAMBVvkXnziltx81Qi0
gqmNklvy2igvYik7eDugzkBxwCCUExsaeJxRKNDHwVEBGZ75gWoMjgwESvm4gc+Do1WuGGDpSvCx
jS07q0YOEwAHZa5bw0hhgMIiAgA7 }
image create photo ::img::org::_M3 -data {
R0lGODlhIgAiALMAAEYVG7WKTQQC/CBGIyQuTBwtHKxGhDllNXRaHPzutOy2NO3DdXErMvz89ppG
RpQ2dCH5BAEAAAIALAAAAAAiACIAQwT/UMhJqwDY6k2ZA8EijkvgMVw6Yc4YfGpaFNIQBMpxK7Qw
x5vBYTgREoEcgOfDcsCQls9N5GCERAkPdFIYFgKI8CGMCMyOW+5w7U1zEApyyF1Rfhh4JR7/THsA
Cw0ADYGDJXh0EgAOIQ+OIi+JPjoFkFMLBTkDbl0SMwUEAwSfngdbDCKlbG0CqAuJXasHPZIrIAoL
GbW2t7m6knpLi05VAIl/IXl7JlV0fwtOIS8tJ3RVVyKEWFkodItTN9gmu98G5iUOu583xDcFA5uc
QwE2JCUDOQfxUJ3vQ0Lw2nTaIkTVqh4DkThBuCbAmh5LTqWbJAviRDqxDu6S0MLBp44bB+HBKyJS
RQQAOw== }
image create photo ::img::org::_M4 -data {
R0lGODlhIgAiALMAAEkaBa6bQE1DKmdJbT43QUoqE8ZJE8yK/HwvDQT+BPz+xOTORIJuLMGyPHte
e/zqVSH5BAEAAAkALAAAAAAiACIAQwT/MMlJayqYiWK7lwIhjiQhfChgrAYyvC/CGgBaATi+Ik7f
yzSArGaj5I6JY67oARQagYYSx2B6CozG4xHobh8MjlWiagkRLthAhhCuiONCiSAnjTtYgQBX0Af2
dxUCWQtfXwt9gRMCDw0wDQoPjw8niotZhgxVimVoOz4/LEBwKSydoA6jnqQeAg2vG3NzrrB3dSMX
JZYUGINOAgEMOLtJSoOae6x3Gw2Fhg+IlZaDzVzWDwoau4MDBwAHA5Le4NqKe69bfYxbDXrE1A0Y
BQFgm5ZH8A2aSHdloqhATFnp5CmNgxg7RjHxdwoUmzM0Fpr65PDNqiKutiTDoWYAvhzSGj7oOXFL
logEIwOVJJDLzq6VLXHdm1JMyYcIADs= }
image create photo ::img::org::_M5 -data {
R0lGODlhIgAiALMAAA0LHLOOVyUvfnRZNzwuG0k5JZl3SBsfVOy6fAT+BOTm5PzafERKzOy6dKyq
rFxaXCH5BAEAAAkALAAAAAAiACIAQwT/MMlJJSk448o7JY2hAErQBKPSNITnAscBCLHjAIB9CDwD
uJSCaVHAGY9HTIMIrCBxieev2bkQDKtsAGvYUD2EQSBAKJtYX+dOAIPxcDz2mp2ewNY/97vOsZb/
ZQNdfB9XZyAgSywthBYGh2VZaI1Rd2EBCAhjBGxTaXp6CiMkCjtuPl+gOzKdbDxrMoR3bzgxe5RR
tnR6dLgJZRkDggYDBb6/BQRnBl1/XoRlzJJZC4uU0YCLkWXXW0sLA9UL4yeMjZcrY2flxwDokmS4
bTEHgGVrqJ+wr6IYonMC8jXhFQqHgjj0eg3EY4rWGxpxPLko8OCBAzn0jiAUUNGBsSYZHXIBjLMn
JJ9Zu+ZIlKUrj0pfKPPMuNVISiUkQCIAADs= }
image create photo ::img::org::D -data {
R0lGODlhIAAgAPQQAAAAABISEi9PT0VFRVRUVHh4eLIiIv8AAP9jR4AAgIeHh6urq7y8vMzMzN3d
3ebm+v///////wAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACH5BAEA
ABEALAAAAAAgACAAAAX+ICCOZGmeJgSJRys2agw1DdseAKOShM4AOJhsOAMacDuCKKZ7EZ815GoH
GAKET2KNuJRVs9BvrCDS7bDg4Vb1IzXT2iJkITKw7F24TFFbBBIHeDd2eloAAUcGeAhHUoUqfACJ
LkCMjo80komLLYQEjxAEUQYIlAeWhE8OWZqliiKlgUg1IgMwqw0DIzCap4EsqFUkAwIKEAq6IgoA
D4i+rwCWgZ8jCg4DEKvJ1lUEis/AryoDfNdYuQ0OANgrz5wuKrnrMDX0A/fxRrHhs1x58UXcwZL1
L58SNEUknToCjCCATzF01WA3rs7CX9EmiXAgCtInAsZm2MqhkJGgRjhpCs5QU0bdIBsiqF2BQ4vB
KpgxvayoQm8lrysBVsUgQYTOTgjYkh4NEECMCjpOQ3XJhbTqzAaIxNjcKYaOIgEPAEZYOYNAAnFs
RszZcXZalgbevokpwHXBnF4tOsagEbcTALpUUAgeXCIEADs= }
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::S -data {
R0lGODlhIAAgALMAAMwyBPyaNMxmBPz+/PxmNPyaZPxmBAAAAOAB32IA2hYAQQAAfujEAGLuABYS
AAAAACH5BAEAAAMALAAAAAAgACAAAwTecMhJq7046827/6AnUIABeMB4AefApl8JT+UkpG33Vrv7
5hsc7za0qEKbmwlpOpJ+GUAA6LqxKs1cTWIgFGQU5cBZ5eEAhECaQCSRMYCCN+6dGyptjXQ9Vfup
RlR0cnImhHVycFc2fGk4fnyAA02Mh00EhpiIMzRmayxTaFZ7fxkCc0qDbHSnhDJkKY2gkX8so2on
sa2Iq4e7h8C5pI2htMSyl8B2vDfKwXu2ssdTVsexcs3MvJY4WV97N5B/4saQaCVzwUrb6bxZpMOn
5JDy1ru/qsq/2z/9/v8AX0QAADs= }
image create photo ::img::M
image create photo ::img::A
##+##########################################################################
#
# 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 {15 + [font measure [$w cget -font] " o "]}]
$w tag config b -lmargin1 15 -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
# Game Types
set txt "The different game types select between different ratios of\n"
append txt "robots to alients, whether you can safe teleport and whether\n"
append txt "you can push scrap piles around.\n\n"
$w insert end "Game Types\n" header $txt n
# Players
set txt "Your player is the human (one of six possible characters). The\n"
append txt "robots come in two flavors: robots, who move one unit at\n"
append txt "a time, and aliens, who move twice as fast.\n\n"
$w insert end "The Characters\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"
$w insert end "Moving\n" header $txt n
set txt " o the '*' key teleports randomly\n"
$w insert end $txt b
set txt " o the '+' key teleports safely\n"
$w insert end $txt b
set txt " o the '/' key shows all save moves\n"
$w insert end $txt b
set txt " o the 'Enter' key is the 'WAIT' button\n\n"
$w insert end $txt b
# 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 and 20 points for every\n"
append txt "alien death, double if 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 'Full Size' toggles screen size\n"
$w insert end $txt b
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 'Show Safe Moves' highlights your legal moves\n"
$w insert end $txt b
$w config -state disabled
focus $w
}
##+##########################################################################
#
# Add2Highscore -- Adds current score to high score list and saves it
#
proc Add2Highscore {} {
set n [::HighScore::Add2HighScore $::S(title) $::G(type) $::env(USERNAME) \
$::G(score) $::G(lvl) [clock seconds]]
return $n
}
##+##########################################################################
#
# ShowHighScore -- Puts up our high score dialog
#
proc ShowHighScore {{n -1}} {
::HighScore::ShowHighScore .high $::S(title) $::G(type) $n
wm transient .high .
CenterWindow .high .
}
proc CenterWindow {w {W .}} {
wm withdraw $w
update idletasks ;# Need to get geometry correct
set wh [winfo reqheight $w] ; set ww [winfo reqwidth $w]
set sw [winfo width $W] ; set sh [winfo height $W]
set sy [winfo y $W] ; set sx [winfo x $W]
set x [expr {$sx + ($sw - $ww)/2}] ; set y [expr {$sy + ($sh - $wh)/2}]
incr y -130
if {$x < 0} { set x 0 } ; if {$y < 0} {set y 0}
wm geometry $w +$x+$y
wm deiconify $w
}
##+##########################################################################
#
# MakeMiniBoard -- grabs 5x5 section of the board around r,c
#
proc MakeMiniBoard {r c} {
unset -nocomplain MINI
foreach dr {-2 -1 0 1 2} {
foreach dc {-2 -1 0 1 2} {
set r1 [expr {$r + $dr}]
set c1 [expr {$c + $dc}]
set MINI($dr,$dc) [GetCell $r1 $c1]
}
}
return [array get MINI]
}
##+##########################################################################
#
# ShowSafeMoves -- Highlights all legal moves
#
proc ShowSafeMoves {} {
global B
if {$B(safeties) eq {}} return
.c delete flash
foreach pos $B(safeties) {
set xy [eval Cell2CanvasBox $pos]
.c create rect $xy -tag flash -fill yellow
}
.c lower flash
.c lower ggrid
}
##+##########################################################################
#
# ReadConfig -- Reads either config or high score file
#
proc ReadConfig {what} {
set fname [GetConfigFileName $what]
if {! [file readable $fname]} return
if {$n} {
set msg "ERROR: Cannot read settings:\n$emsg"
tk_messageBox -message $msg -icon error -title "Tk Robots Error"
return
}
catch {interp delete myInterp}
interp create -safe myInterp
myInterp invokehidden source $fname
array set ::G [myInterp eval array get G]
}
##+##########################################################################
#
# SaveConfig -- Saves either our configuration or our high score
#
proc SaveConfig {what} {
global G HIGH
set fname [GetConfigFileName $what]
set n [catch {set fout [open $fname w]} emsg]
if {$n} {
if {$what eq "config"} {
set msg "ERROR: Cannot save settings:\n$emsg"
tk_messageBox -message $msg -icon error -title "Tk Robots Error"
}
return
}
if {$what eq "config"} {
foreach arr {type p,safe p,full p,showSafe} {
puts $fout "set G($arr) $G($arr)"
}
} else {
puts $fout "array set HIGH { [array get HIGH] }"
}
close $fout
}
##+##########################################################################
#
# GetConfigFileName -- Returns name of either our config or high score file
#
proc GetConfigFileName {what} {
global env
set baseName [string tolower [string map {" " ""} $::S(title)]]
if {$::tcl_platform(platform) eq "windows"} {
append baseName [expr {$what eq "high" ? ".hs" : ".cfg"}]
} else {
append baseName [expr {$what eq "high" ? "_hs" : "_rc"}]
set baseName ".$baseName"
}
set fname [file join ~ $baseName]
if {[info exists env(APPDATA)]} {
set fname [file join $env(APPDATA) $baseName]
}
return $fname
}
################################################################
##+##########################################################################
#
# highScore.tcl -- package for showing, adding to and saving high scores
# by Keith Vetter, April 28
#
# This package provides routines for showing, adding to and saving high scores.
# It supports multiple high score tables for different skill levels (buts
# works fine with only one table).
#
# A high score entry consists of: username, score, level reached and date,
# and sorts entries first by score, then by level. Changing this is easy
# but requires code changes.
#
# The scores are kept in a file based on the application name and stored in
# either APPDATA or HOME directory.
#
# Three procs are exported:
# ::HighScore::ShowHighScore toplevel appName ?skillLevel? ?highlight?
# toplevel -- name for the dialog's toplevel window
# appName -- for locating correct highscore data file
# skillLevel -- which table to show initially
# ?highlight? -- if > 0, which entry to high and to say Congratulations
#
# ::HighScore::Add2HighScore appName skillLevel name score lvl date
# appName -- for locating correct highscore data file
# skillLevel -- which high score table to add to
# name -- name value for table
# score -- score value for table
# level -- level value for table
# date -- usually just [clock seconds]
#
# ::HighScore::GetHighScoreFileName appName
# appName -- for locating correct highscore data file
package require Tk 8.5
package provide highscore 1.0
namespace eval ::HighScore {
variable W .highscores
variable HIGH {}
variable which ;# Which table to display
variable skillLevels {}
variable headers {Name Score Level Date}
variable headerWidths {100 60 50 85}
namespace export ShowHighScore Add2HighScore GetHighScoreFileName
foreach t [trace info variable which] { ;# For easier debugging
trace remove variable which {*}$t
}
}
##+##########################################################################
#
# ::HighScore::Init -- Lets you fix the ordering of skillLevels
#
proc ::HighScore::Init {skillLevels} {
set ::HighScore::skillLevels $skillLevels
}
##+##########################################################################
#
# ::HighScore::ShowHighScore -- Puts up the high score dialog
# toplevel -- name for the dialog's toplevel window
# appName -- for locating correct highscore data file
# skillLevel -- which table to show initially
# highlight -- if > 0, which entry to high and to say Congratulations
#
proc ::HighScore::ShowHighScore {top appName {skillLevel ""} {highlight -1}} {
variable W $top
variable HIGH
variable which
::HighScore::_ReadHighScores $appName
::HighScore::_TearDown
toplevel $W
wm title $W "$appName Scores"
wm protocol $W WM_DELETE_WINDOW ::HighScore::_TearDown
# Allow a game to have several high score tables
set keys [dict keys $HIGH]
if {$skillLevel eq ""} { set skillLevel [lindex $keys 0] }
if {$skillLevel ni $keys} {
set msg "ERROR: unknown skill level '$skillLevel'"
tk_messageBox -icon error -title "High Score Error" -message $msg
return
}
set which $skillLevel
set WV $W.variants
::ttk::frame $WV
::ttk::label $WV.l -text "Skill Level:"
::ttk::menubutton $WV.opt -textvariable ::HighScore::which -menu $WV.menu \
-direction flush
menu $WV.menu -tearoff 0
foreach i $keys {
$WV.menu add radiobutton -label $i -variable ::HighScore::which
}
trace variable ::HighScore::which w ::HighScore::_Tracer
pack $WV.l -side left
pack $WV.opt -side left ;#-fill both -expand 1
::HighScore::MakeIcon
::ttk::label $W.icon -image ::highscore::icon
label $W.title -text "$appName High Scores" -bd 2 -relief sunken \
-font {Helvetica 12 bold}
frame $W.buttons -bd 2 -relief ridge
::ttk::button $W.buttons.quit -text "Close" -command ::HighScore::_TearDown
::ttk::frame $W.table
label $W.congrats1 -text "Congratulations!" -font {Helvetica 12 bold}
label $W.congrats2 -text "You score has made the top ten."
pack $W.buttons -side bottom -fill x -pady {.1i 0}
pack $W.icon -side left -anchor n -pady .1i -padx .1i
pack $W.title -side top -fill x -pady .1i -padx {0 .1i}
if {$highlight > -1} {
pack $W.congrats1 -side top -fill x
pack $W.congrats2 -side top -fill x -padx {0 .1i}
}
if {[llength $keys] > 1} {
pack $W.variants -side top -fill x -pady .1i -padx {0 .1i}
}
pack $W.buttons.quit -side bottom -expand 1 -pady .1i
pack $W.table -side top -fill both -expand 1 -padx {0 .1i}
set which $which ;# Fire the trace
set tag "tag_${which}_$highlight"
$W.table.tree tag config $tag -background cyan
return $W
}
##+##########################################################################
#
# ::HighScore::GetHighScoreFileName -- Returns the highscore filename
# appname -- used to construct the filename
# Windows: => $env(APPDATA)/$appName.hs
# Unix: => ~/.$appName_hs
#
proc ::HighScore::GetHighScoreFileName {appName} {
global env
set baseName [string tolower [string map {" " ""} $appName]]
if {$::tcl_platform(platform) eq "windows"} {
append baseName ".hs"
} else {
append baseName "_hs"
set baseName ".$baseName"
}
set fname [file join ~ $baseName]
if {[info exists env(APPDATA)]} {
set fname [file join $env(APPDATA) $baseName]
}
return $fname
}
##+##########################################################################
#
# ::HighScore::Add2HighScore -- Adds entry to high score--if good enough
# appName -- for locating correct highscore data file
# skillLevel -- which high score table to add to
# name -- name value for table
# score -- score value for table
# level -- level value for table
# date -- usually just [clock seconds]
#
# returns: position in the top 10 (base 1)
#
proc ::HighScore::Add2HighScore {appName skillLevel name score level date} {
variable HIGH
::HighScore::_ReadHighScores $appName
set item [list $name $score $level $date]
set data {}
if {[dict exists $HIGH $skillLevel]} {
set data [dict get $HIGH $skillLevel]
}
lappend data $item
set data [lrange [lsort -dec -integer -index 2 $data] 0 9]
set data [lsort -dec -integer -index 1 $data]
set n [lsearch $data $item]
if {$n > -1} {
dict set HIGH $skillLevel $data
::HighScore::_SaveHighScore $appName
}
return [incr n] ;# Top 10 position (base 1)
}
##+##########################################################################
#
# ::HighScore::_CreateTable -- Creates high score table using tile treeview
#
proc ::HighScore::_CreateTable {W} {
if {! [winfo exists $W]} return
set WTREE $W.tree
set data [::HighScore::_MassageData]
if {! [winfo exists $WTREE]} {
::ttk::treeview $WTREE -columns $::HighScore::headers -show headings \
-height 10 -yscroll "$W.vsb set" -xscroll "$W.hsb set" \
-selectmode none
scrollbar $W.vsb -orient vertical -command "$WTREE yview"
scrollbar $W.hsb -orient horizontal -command "$WTREE xview"
grid $WTREE $W.vsb -sticky nsew
grid $W.hsb -sticky nsew
grid column $W 0 -weight 1
grid row $W 0 -weight 1
}
$WTREE delete [$WTREE children {}]
foreach col $::HighScore::headers width $::HighScore::headerWidths {
set name [string totitle $col]
$WTREE heading $col -text $name
$WTREE column $col -anchor c -width $width
}
$WTREE column Score -anchor e
set lnum 0
foreach datum $data {
set tag "tag_${::HighScore::which}_[incr lnum]"
$WTREE insert {} end -values $datum -tag $tag
}
}
##+##########################################################################
#
# ::HighScore::_TearDown -- Cleans up traces from our dialog
#
proc ::HighScore::_TearDown {} {
foreach t [trace info variable ::HighScore::which] {
eval trace remove variable ::HighScore::which $t
}
destroy $::HighScore::W
}
##+##########################################################################
#
# ::HighScore::MakeIcon -- Makes our icon for our dialog
#
proc ::HighScore::MakeIcon {} {
if {"::highscore::icon" in [image names]} return
image create photo ::highscore::icon -format gif -data {
R0lGODlhZABgALMAAAsDBbOYIKimhPzOBQQC/G5SI/j6d5ubYvz9ZWpkYvz+zEsyIdW1Gcy+RJNz
EcTGlCH5BAEAAAQALAAAAABkAGAAQwT/kMhJq704a7KA/2Aojt52hYWirmzrvvD6HB1pj0+8hicY
h4OgcEgsDhHIpNKQNDQOiWiCiRTeXrzKrcj4LIzg8FFJLieto+GHlZ2QvmgB2yOug81ktWf3EdYA
LQIgbiIqfwBoCS19dmJ4VUMBHjkKIAxCDmsvB1mFLQ8hAUOZhyCijmZGpTeaMaAiEiEtCwc6tnOM
YCJyMYI3C66DFD63Kx0LvLYFQEQjxVgAwLbChK3PLAkjC5eNQQwBDgkODqd6ALXXLtTDssUgcAMf
ZAf09fYHAlRlIEbtOrAmqrHi160gEUkDRwTMkLChw4ceFkhcIIWeAEq4AGLwt+gXOYMg/+t4gtGG
HTFOW4RIWcmypcuVBxogoKKvDBpEzT4kq/TBAglze3zhDHOvqD0B+R7ZvKnCCyZrh0z+ZDonZJGa
j4ZIBGToA7d4e6CViMXxVa4wmYYWzJozmphDPzpxhLEKmVi1BQ+hS8cTAEY+PQVyzYjiojuCIkHs
5dt3cEYtxAKNUHRtVZGEjP8FlpoZRAE/AwsEmInHgKXL1g5v9slqMbMg8pSSebIqBLybJJAqXMgb
MsTfN3oLZw28uHGHvBNS3Jm5ufOuJX2nlnG8uo0FaSPfBdBjOmA6VsMXyQNWu7roBOYqqC2EQZQA
X+18e0m/JZObAxDOjSpdW87b4o0h2/9SsHngQD9hNbUaWWnghlh43xhFD1YEplWKOSzwJ9gHnxWY
YA0gHRAfEQOeQVVjuLGwzIIpDVBDRyMGOCCGCoLn4V1STWLWUC+q6EE5VpUYSYLZePCVed9xl14I
ybyWHwou2hhkKkOsOEJ8XpAkl3k7AmhEF1KGoRSCABwYhnrUwTLSLMV5SaKJRegXVpEhUPaMRmg+
11iMRmQXTTo7eteYkgwmCJg0mVkmRp7QOaPCXx2NVahjkl3Ry4NfMnoLCMx9J52dCi4AqXOYHoKo
nppJOqkto75AZ4uRFLCVDa0ytk6hmQUqBgO1JdQWAKBec2uhnaY6VJ0U1mSAAPckYSX/XlF+sJix
hBInwgGtHmIOGRSWaNpZDuog1IIbFffrcQt0GEavNgyXAbteMSCvvGB8I6t1w7qrb3es7OvvvxsE
9y6+1S3gLsEIJ0xuueimm4BhqKIa6MITlFJAsRFf88AMz76hmqoVlPLPw7W68IAACXSsMJKRgiwY
XehGk24BBYxjcwA44/wNn7poit6SHwSbZIBEC0GFh4LWSC6jTgbYLXlBkEYeCUKvh16eHRcd9RIz
1CfF0Ug7Spi1lNpg5gBep612FAcYgBV+3ngBLAs7ks2V3G7pt2sA9LRET85ClIgH3Kg5NiwrhfMc
nuBQlxdRW4/1945WF2o9AONKAPWg/zXRkXC2DYoPIS/OCUhYVFJj3qjtiYNKLmVk4BZhej3xPU2l
40qnaMytNjz1Jx/qai2474N5BRqlKIHcOxp/FWl54EoZQCOKHp6qQN05Osl5mOLZDmd53x1PqdLZ
28Z6X0QPf+LmhkY+6d3GFwhp7AbNOD37AGC8JexnwSvj4JCz2llYNiglralpA7CZHkJXh9vdxAGr
0912DDgXBJKpILbjQjSgda648GBNSnOLEVTmpjc50EFGIoKfxseCcfUEhCGECAMJNIrffOyFmoKX
Z6hnFT9ZTwXZqJqCtmMwoCUtEHei36IIaItxbSdHGWtZ8Mh0RLrZIAYaMiKlevQcEf8skYkFtM00
VqMeJnXGgoVjIWEoYsXftQyKLVAZCUqGKTDISY0fa9U6NLUCOY7xA2fT3CSaA0be6SSK2zkXHqNo
yIhUyjMlayKm/IRID1ZLizGgE8Ze4MI6NoSRLAJjMV4lAonULJDd+EYVP9af5pSihERggBzf8SOg
kGppq0xkEWZ5HQcc4FlpjOQTWwkogtigAN5DgtuS4Jk0LrJlLsNkEnMRmybMrh6oYyb9+BhDDKxC
mM8qRzWRYI9kksFKVHwmKU3AimBpzwOY49YdU6hIN+7uZ/zymAJIua0mNCABOmSFl4AzHOBMEYLa
mEi6xgEfejVihQkB2PuWpzUGIBQZIhL9l20aElCMZjSjK7tOET9K0pKadCERAAA7}
}
##+##########################################################################
#
# ::HighScore::_MassageData -- Puts data into pretty format for display
#
proc ::HighScore::_MassageData {} {
set data {}
foreach datum [dict get $::HighScore::HIGH $::HighScore::which] {
if {$datum eq ""} break
lassign $datum who score lvl when
lset datum 1 [::HighScore::_Comma $score]
lset datum 3 [clock format $when -format "%b %d, %Y"]
lappend data $datum
}
return $data
}
##+##########################################################################
#
# ::HighScore::_Tracer -- Handles trace on which skill level to display
#
proc ::HighScore::_Tracer {var1 var2 op} {
::HighScore::_CreateTable $::HighScore::W.table
}
proc ::HighScore::_Comma {num} {
while {[regsub {^([-+]?[0-9]+)([0-9][0-9][0-9])} $num {\1,\2} num]} {}
return $num
}
##+##########################################################################
#
# ::HighScore::_ReadHighScores -- Reads our high score config file
# appName -- for locating correct highscore data file
#
proc ::HighScore::_ReadHighScores {appName} {
variable HIGH
variable skillLevels
unset -nocomplain HIGH
set HIGH {}
foreach lvl $skillLevels { dict set HIGH $lvl {}}
set fname [::HighScore::GetHighScoreFileName $appName]
if {! [file readable $fname]} { return "No File" }
catch {interp delete myInterp} ;# Easier debugging
interp create -safe myInterp
myInterp invokehidden source $fname
set HIGH [myInterp eval set HIGH]
interp delete myInterp
return ""
}
##+##########################################################################
#
# ::HighScore::_SaveHighScore -- Saves our high score config file
# appName -- for locating correct highscore data file
#
proc ::HighScore::_SaveHighScore {appName} {
variable HIGH
set fname [::HighScore::GetHighScoreFileName $appName]
set n [catch {set fout [open $fname w]} emsg]
if {$n} {
set msg "ERROR: cannot save high scores\n$fname:\n$emsg"
tk_messageBox -icon error -title "High Score Error" -message $msg
return
}
puts $fout "set HIGH {"
dict for {key value} $HIGH {
puts $fout " [list $key] [list $value]"
}
puts $fout "}"
close $fout
}
################################################################
ReadConfig config
if {$G(p,full)} {
FullSize
} else {
HalfSize
}
Init
DoDisplay
NewGame
return