[Keith Vetter] 2008-04-25: This is a version of the old UNIX Robots game [http://en.wikipedia.org/wiki/Robots_%28computer_game%29]. I wrote a version of this game a long, long time ago, then, when I saw again yesterday when I installed Linux and Gnome, I decided write it again. So here it is, 1 KLOC later. One feature I added in this version is that if you hold the ''shift'' key down while pressing an arrow, it will move forever in that direction while it is safe to do so. At some point I'll add Gnome's fast robot feature. The images I use are fairly large (34x34), so on small displays it uses a smaller board which are harder. Alternatively, there's an option to use smaller images--they're harder to see but you get the bigger board size. ---- [FF] 2008-04-26 Cool! Can't stop playing this. Thanks for bringing this game to us!;) ---- [KPV] 2008-04-29: Uploaded a new version called [Tk Robots2] ---- [uniquename] 2013aug01 This expenditure of coding energy deserves a couple of images to show the output of this script --- game area and scrollable help window. [vetter_TkRobots_gameBoard_screenshot_925x625.jpg] [vetter_TkRobots_helpWindow_screenshot_513x711.jpg] ---- [Jeff Smith] 2021-08- : Below is an online demo using [CloudTk]. This demo runs "Tk Robots" in an Alpine Linux Docker Container. It is a 27.4MB image which is made up of Alpine Linux + tclkit + Tk-Robots.kit + libx11 + libxft + fontconfig + ttf-linux-libertine. It is run under a user account in the Container. The Container is restrictive with permissions for "Other" removed for "execute" and "read" for certain directories. <> <> ---- ====== ##+########################################################################## # # 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 { } set x11 { } array set K $win32 if {[tk windowingsystem] eq "x11"} { array set K $x11 } bind .c $K() [list MoveMan -1 0 0] bind .c $K() [list MoveMan -1 0 1] bind .c $K() [list MoveMan 1 0 0] bind .c $K() [list MoveMan 1 0 1] bind .c $K() [list MoveMan 0 -1 0] bind .c $K() [list MoveMan 0 -1 1] bind .c $K() [list MoveMan 0 1 0] bind .c $K() [list MoveMan 0 1 1] bind .c $K() [list MoveMan -1 1 0] bind .c $K() [list MoveMan -1 1 1] bind .c $K() [list MoveMan -1 -1 0] bind .c $K() [list MoveMan -1 -1 1] bind .c $K() [list MoveMan 1 1 0] bind .c $K() [list MoveMan 1 1 1] bind .c $K() [list MoveMan 1 -1 0] bind .c $K() [list MoveMan 1 -1 1] bind .c $K() [list MoveMan 0 0 0] bind .c $K() [list MoveMan 0 0 1] bind .c $K() [list SpecialMove wait] bind .c $K() [list SpecialMove transport] bind .c $K() [list SpecialMove safetransport] bind .c NewGame bind all {console show} return proc foo {args} { foreach {a b} $args { puts "$a: '$b'"} } bind .c [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 foreach {r c} [lindex [Shuffle $empty] 0] break foreach {r0 c0} $B(man) break 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"} { foreach {dr dc} $G(auto) break } elseif {$G(state) ne "go"} return set G(auto) [list $dr $dc] foreach {r0 c0} $B(man) break 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 foreach {r c} $xy break if {$r < 2} { incr r set anchor n } else { incr r -1 set anchor s } foreach {x y} [Cell2Canvas $r $c] break 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 foreach {x0 . x1 .} [.c bbox $tag] break 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} { foreach {r c} [lindex $empty $i] break 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) { foreach {r c} $robot break set B($r,$c) "" } foreach {r0 c0} $B(man) break set dead 0 set new {} foreach robot $B(robots) { foreach {r c} $robot break 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 foreach {r0 c0} $B(man) break 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 ====== <> Games | Application | Graphics