TkOverload
Keith Vetter 2002-10-18 - I was surfing the net and came across a shareware game from Astatix called Overload that looked a bit interesting to play. However, that game has a very annoying nag screen. So I decided to write my own version.
See the help screen for full playing rules, but the idea is that each player alternate turns placing pieces on a 6x6 board. Once a square has four pieces in it, it explodes and scatters the pieces north, south, east and west, taking over any opponent pieces. If the scattered pieces causes a square to contain four or more pieces, it too will explode. Such chain reactions are an integral part of the game and make the position very volatile.
Keith Vetter 2002-10-22 - Added a computer opponent. Stole a min-max game tree search algorithm with alpha-beta pruning from a TkAtaxx game I wrote many years ago. The "smartness" of the computer is controlled by the strength of the evaluation function and by how far ahead it searches. In this game the evaluation function is trivial--just the difference in number of pieces--but you can adjust the search depth. But beware, time required grows exponentially with increased depth; on my machine, level 5 is about the useable limit.
One interesting implementation note: originally I had the board as a hash, but it was faster to use a list instead. Also, it was faster to use lreplace and copying the list than to use upvar and lset.
uniquename 2013aug01
Here is an image that shows the options on the 'Game' drop-down menu --- as well as an image of the Help window.
package require Tk
proc Init {} {
array set ::S {
sz 40
rows 4
cols 4
size 0
robot -1
color,1 Red
color,-1 Blue
turn,1 "Red Player's turn"
turn,-1 "Blue Player's turn"
anim 60
turn 1
moves 0
level 3
level,max 8
won 0}
array set ::M {1 0 -1 1 2 2 -2 3}
}
proc DoDisplay {} {
wm title . "TkOverload"
wm minsize . 240 290
DoMenus
frame .fmsg -relief ridge -bd 2
label .msg -bd 0 -textvariable S(msg) -padx 5
label .msg3 -bd 0 -textvariable S(msg3) -padx 5
label .msg2 -relief ridge -textvariable S(msg2)
scale .level -orient horiz -from 1 -to $::S(level,max) -relief ridge \
-command DoLevel -showvalue 0 -variable S(level)
button .new -text "New Game" -command NewBoard
button .hint -text Hint -command Hint
frame .ftop
frame .ftop2
grid .ftop - -sticky news -row 0
grid .fmsg - -sticky ew -row 1
grid .msg2 - -sticky ew -row 2
grid .level .new -row 3
grid ^ .hint -sticky ew -row 4 -padx 5
grid configure .new -sticky ew -padx 5
grid rowconfigure . 0 -weight 1
grid columnconfigure . {0 1} -weight 1
pack .msg -in .fmsg -side left -fill x -expand 1
pack .msg3 -in .fmsg -side right
DisplayBoard
}
proc DisplayBoard {} {
global S
foreach w [grid slaves .ftop2] { destroy $w }
catch {destroy .ftop2}
frame .ftop2
pack .ftop2 -in .ftop -expand 1 -fill both
for {set row 0} {$row < $S(rows)} {incr row} {
for {set col 0} {$col < $S(cols)} {incr col} {
set w ".c$row,$col"
canvas $w -width $S(sz) -height $S(sz) -bd 2 -relief sunken
$w config -highlightthickness 0
bind $w <ButtonRelease-1> [list ButtonUp %W %X %Y $row $col]
bind $w <Configure> {ReCenter %W %h %w}
grid $w -row $row -in .ftop2 -column $col -sticky news
}
grid rowconfigure .ftop2 $row -weight 1
grid columnconfigure .ftop2 $row -weight 1
}
}
proc DoMenus {} {
. configure -menu [menu .m -tearoff 0]
.m add cascade -menu [menu .m.game -tearoff 0] -label "Game" -underline 0
.m add cascade -menu [menu .m.help -tearoff 0] -label "Help" -underline 0
.m.game add command -label "New Game" -under 0 -command NewBoard
.m.game add separator
.m.game add checkbutton -label "Computer Opponent" -under 0 \
-command GoRobot -variable S(robot) -onvalue -1 -offvalue 0
.m.game add command -label Hint -under 0 -command Hint
.m.game add separator
.m.game add checkbutton -label "Beginner" -under 0 -command Resize \
-variable S(size) -onvalue 0 -offvalue 1
.m.game add checkbutton -label "Expert" -under 0 -command Resize \
-variable S(size) -onvalue 1 -offvalue 0
.m.game add separator
.m.game add command -label Exit -under 0 -command exit
.m.help add command -label Help -under 0 -command Help
}
proc ReCenter {W h w} { ;# Called by configure event
set h [expr {$h / 2.0}]
set w [expr {$w / 2.0}]
$W config -scrollregion [list -$w -$h $w $h];# Recenter everything
if {[regexp {^.c(\d+),(\d+)$} $W -> r c]} { DoCircle $::B $r $c } ;# Resize
}
proc IDX {r c} {expr {$::S(cols)*$r+$c+4}}
proc GET {b r c} {lindex $b [expr {$::S(cols) * $r + $c + 4}]}
proc GETM {b x} {lindex $b $::M($x)}
proc SET {b r c v} {set i [expr {$::S(cols)*$r+$c+4}];lreplace $b $i $i $v}
proc SETM {b x v} {lreplace $b $::M($x) $::M($x) $v}
proc INCR {b r c {d 1}} {
set i [expr {$::S(cols)*$r+$c+4}]
lreplace $b $i $i [expr {[lindex $b $i] + $d}]
}
proc INCRM {b x {d 1}} {
lreplace $b $::M($x) $::M($x) [expr {[lindex $b $::M($x)] + $d}]
}
proc INFO {msg {who ""}} {
set ::S(msg$who) $msg
update idletasks
}
proc DoLevel {lvl} { .level config -label "Skill: $::S(level)" }
proc Resize {} {
global S
set S(rows) [set S(cols) [expr {$S(size) == 0 ? 4 : 6}]]
DisplayBoard ;# Redo the board
NewBoard
}
proc DoMove {row col} { ;# Move piece to row,col
global S B
Unhint ;# Turn off any hint
AnimateBox $row $col ;# Make it look a bit sexy
set B [AddOne $B $S(turn) $row $col 1] ;# Add the piece
WinOrLose $B ;# Is the game over???
NewTurn ;# Make it next player's turn
}
proc ButtonUp {w X Y row col} { ;# Called on mouse click
global S B
if {$S(won)} return ;# Game already over
if {$w != [winfo containing $X $Y]} return ;# Mouse moved out of cell
set val [GET $B $row $col]
set turn $S(turn)
if {$val < 0 && $turn > 0} return ;# Opponent's cell
if {$val > 0 && $turn < 0} return
DoMove $row $col
}
proc NewBoard {} {
global B S
set cnt [expr {$S(rows) * $S(cols) - 2}] ;# How many empty cells
set B "1 1 1 1 " ;# Metadata
append B "1 [string repeat "0 " $cnt]-1" ;# ...actual board
set S(turn) 1 ;# Player 1 goes first
set S(won) 0 ;# Game not over yet
set S(moves) 0 ;# How many turns
ShowBoard
}
proc ShowBoard {} {
global S B
for {set row 0} {$row < $S(rows)} {incr row} {
for {set col 0} {$col < $S(cols)} {incr col} {
DoCircle $B $row $col
}
}
INFO "Welcome to TkOverload"
INFO "" 2
INFO "" 3
}
proc DoCircle {brd row col} { ;# Draws the circles for a cell
global S
set w ".c$row,$col"
$w delete all
set val [GET $brd $row $col]
set size [expr {abs($val)}]
if {$size == 0} return
set width [winfo width $w]
set height [winfo height $w]
set min [expr {$width < $height ? $width : $height}]
set r [expr {$min / 6}] ;# Radius of circle
set r4 [expr {($min / 4) - 2}] ;# Position of circle
set fill $S(color,[expr {$val / $size}])
if {$size == 1} {
$w create oval -$r -$r $r $r -fill $fill -outline {}
} elseif {$size == 2} {
$w create oval [MakeBox -$r4 0 $r] -fill $fill -outline {}
$w create oval [MakeBox $r4 0 $r] -fill $fill -outline {}
} else {
$w create oval [MakeBox -$r4 $r $r] -fill $fill -outline {}
$w create oval [MakeBox $r4 $r $r] -fill $fill -outline {}
$w create oval [MakeBox 0 -$r $r] -fill $fill -outline {}
}
}
proc MakeBox {x y r} {
return [list [expr {$x-$r}] [expr {$y-$r}] [expr {$x+$r}] [expr {$y+$r}]]
}
proc AddOne {brd who row col show} {
global S
set val [GET $brd $row $col]
if {$val == 0} {
set brd [INCRM $brd $who] ;# Count cells occupied
}
if {$val == 3 || $val == -3} { ;# Will it explode
set brd [DoExplode $brd $who $row $col $show]
} else {
set brd [INCR $brd $row $col $who] ;# One more piece in cell
set brd [INCRM $brd [expr {2*$who}] 1] ;# One more total pieces
if {$show} {
DoCircle $brd $row $col
}
}
return $brd
}
proc DoExplode {brd who row col show} {
global S
set who2 [expr {2*$who}]
set brd [SET $brd $row $col 0] ;# Exploded cell is empty
set brd [INCRM $brd $who -1] ;# One less cell occupied
set brd [INCRM $brd $who2 -3] ;# Fewer total pieces
if {$show} {DoCircle $brd $row $col} ;# Erase it
foreach {dr dc} {-1 0 1 0 0 -1 0 1} { ;# Scatter in 4 directions
set r [expr {$row + $dr}]
set c [expr {$col + $dc}]
if {$r < 0 || $r >= $S(rows) || $c < 0 || $c >= $S(cols)} continue
set val [GET $brd $r $c] ;# Current cell value
set aval [expr {abs($val)}]
if {$who * $val < 0} { ;# Take ownership
set brd [INCRM $brd $who 1] ;# One more cell owned
set brd [INCRM $brd [expr {-$who}] -1] ;# One fewer cell owned
set brd [INCRM $brd $who2 $aval] ;# More total pieces
set brd [INCRM $brd [expr {-$who2}] [expr {-$aval}]]
set brd [SET $brd $r $c [expr {$who * $aval}]] ;# Update board
}
set brd [AddOne $brd $who $r $c $show] ;# Add another piece
}
return $brd
}
proc AnimateBox {row col} {
set w ".c$row,$col"
$w config -relief sunken
set width [winfo width $w] ; set height [winfo height $w]
set min [expr {($width < $height ? $width : $height)/2}]
for {set r 2} {$r < $min} {incr r 2} {
set start [clock clicks -milliseconds]
$w create rect -$r -$r $r $r -tag box
update idletasks
set remaining [expr {$::S(anim)-([clock clicks -milliseconds]-$start)}]
if {$remaining > 0} { after $remaining }
}
}
proc WinOrLose {brd} {
if {[GETM $brd 1] == 0} {
INFO "$::S(color,-1) Player won"
} elseif {[GETM $brd -1] == 0} {
INFO "$::S(color,1) Player won"
} else return
set ::S(won) 1
}
proc NewTurn {} {
global B S
if {$S(won)} return ;# Game already over
incr S(moves) ;# One more total moves
set S(turn) [expr {-$S(turn)}] ;# Other player's turn
if {$S(turn) == $S(robot)} {INFO "Computer's turn"} {INFO $S(turn,$S(turn))}
INFO "moves: $S(moves)" 3
GoRobot ;# Do possible robot move
}
proc Help {} {
catch {destroy .help}
toplevel .help
wm title .help "TkOverload Help"
wm geom .help "+[expr {[winfo x .] + [winfo width .] + 10}]+[winfo y .]"
text .help.t -relief raised -wrap word -width 70 -height 23 \
-padx 10 -pady 10 -cursor {} -yscrollcommand {.help.sb set}
scrollbar .help.sb -orient vertical -command {.help.t yview}
button .help.dismiss -text Dismiss -command {destroy .help}
pack .help.dismiss -side bottom -pady 10
pack .help.sb -side right -fill y
pack .help.t -side top -expand 1 -fill both
set bold "[font actual [.help.t cget -font]] -weight bold"
set italic "[font actual [.help.t cget -font]] -slant italic"
.help.t tag config title -justify center -foregr red -font "Times 20 bold"
.help.t tag configure title2 -justify center -font "Times 12 bold"
.help.t tag configure bullet -font $bold
.help.t tag configure n -lmargin1 15 -lmargin2 15
.help.t tag configure ital -font $italic
.help.t insert end "TkOverload\n" title
.help.t insert end "by Keith Vetter\n\n" title2
set m "TkOverload is a logic game for two people based on the game by "
append m "Overload by Astatix (see http://www.astatix.com/overload.php). "
append m "That games is shareware with a really annoying nag screen, so I "
append m "decided to write my own version. "
append m "The object is to capture all your opponents pieces.\n\n"
.help.t insert end "Overview\n" bullet $m n
set m "Each player alternate turns by clicking on either an empty cell or "
append m "a cell already containing his pieces. Each click increases the "
append m "number of pieces in the cell. When the number of pieces "
append m "reaches four, the cell "
.help.t insert end "How to Play\n" bullet $m n explodes.\n\n ital
set m "When the number of pieces in the cell reaches four, it explodes, "
append m "scattering the four pieces north, south, east and west. "
append m "Those four cells immediately change ownership to the current "
append m "player, and, if the addition of the piece causes a "
append m "cell to have four pieces, it too will explode. "
append m "Such chain reactions are a major part of the game, "
append m "and can cause the momentum in the game to change quickly."
.help.t insert end "Exploding Cells\n" bullet $m n
.help.t config -state disabled
}
################################################################
#
# Computer player code
#
# Game-tree min-max search with alpha-beta pruning. See _Fundamentals of
# Data Structures_, Horowitz, page 268.
#
proc veb {who brd lvl d} {
incr ::S(veb)
if {$lvl == 0 || [GETM $brd 1] == 0 || [GETM $brd -1] == 0} { ;# Terminal?
return [e $who $brd] ;# ...just evaluate position
}
set ans -100000 ;# Lower bound on value
set best "" ;# Current best move
set l $lvl
incr lvl -1 ;# Go down a level
set moves [AllMoves $who $brd] ;# Get all legal moves
foreach m $moves { ;# Try each possible move
foreach {row col} $m break
set brd2 [AddOne $brd $who $row $col 0] ;# Do the move
set e [veb [expr {-$who}] $brd2 $lvl [expr {-1 * $ans}]]
foreach {a bm} $e break
set a [expr {-$a}]
if {$a >= $ans} { ;# Is it a better move?
set ans $a ;# Yep, so use it
set best [concat $bm [list $m]]
}
if {$ans >= $d} break ;# BETA rule
}
return [list $ans $best]
}
proc e {who brd} { ;# Evaluate a board
if {[GETM $brd [expr {-$who}]] == 0} { return 10000 }
if {[GETM $brd $who] == 0} { return -10000 }
set me2 [GETM $brd [expr {2*$who}]]
set you2 [GETM $brd [expr {-2*$who}]]
return [expr {$me2 - $you2}]
}
proc Robot {lvl} { ;# Figure out the best move
global S B
if {$S(won)} return ;# Game already over
INFO "thinking (depth $lvl)..." 2
set S(veb) 0 ;# Count number of calls
set t [time {set mv [veb $S(turn) $B $lvl 10000]}]
foreach {val S(best)} $mv break
foreach {row col} [lindex $S(best) end] break
set tt [expr {[lindex $t 0] / 1000000.0}]
if {$tt > .001} {set tt [expr {round($tt * 1000) / 1000.0}]}
set m [expr {1000 * $tt / $S(veb)}]
INFO "Rating: $val ($S(veb) in $tt seconds)" 2
return [list $row $col]
}
proc AllMoves {who brd} { ;# Get all possible moves
global S
set moves {}
for {set row 0} {$row < $S(rows)} {incr row} {
for {set col 0} {$col < $S(cols)} {incr col} {
set v [GET $brd $row $col]
if {$v == 0} {
lappend moves [list $row $col]
} elseif {$v / abs($v) == $who} {
lappend moves [list $row $col]
}
}
}
# Randomly rearrange order of the move list
set n [expr {int(rand() * [llength $moves])}]
set moves [concat [lrange $moves $n end] [lrange $moves 0 [expr {$n - 1}]]]
return $moves
}
proc Hint {{lvl 4}} {
Unhint
if {$::S(won)} return ;# Game already over
foreach {row col} [Robot $lvl] break
set w ".c$row,$col"
set ::S(hint) [list $w [$w cget -bg]]
$w configure -bg green
after 10000 Unhint
return $::S(best)
}
proc Unhint {} { ;# Turn off hint highlighting
global S
foreach a [after info] {after cancel $a}
if {! [info exists S(hint)]} return
foreach {w bg} $S(hint) break
$w configure -bg $bg
}
proc GoRobot {} { ;# Do the robot turn
global S
if {$S(turn) == $S(robot)} {
eval DoMove [Robot $S(level)]
}
}
################################################################
################################################################
################################################################
Init
DoDisplay
NewBoard