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.
package require Tk
proc Init {} {
array set ::S {sz 40
rows 6
cols 6
turn 1
color,1 Red
color,-1 Blue
anim 60
turn,1 "Red Player's turn"
turn,-1 "Blue Player's turn"
won 0}
}
proc DoDisplay {} {
global S
wm title . "TkOverload"
DoMenus
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 raised
$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 -column $col -sticky news
}
grid rowconfigure . $row -weight 1
grid columnconfigure . $row -weight 1
}
label .msg -relief ridge -textvariable S(msg)
grid .msg -columnspan $S(cols) -sticky ew
}
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 $r $c } ;# Resize
}
proc NewBoard {} {
global B S
for {set row 0} {$row < $S(rows)} {incr row} {
for {set col 0} {$col < $S(cols)} {incr col} {
set B($row,$col) 0
}
}
set B(0,0) 1 ;# Player 1's piece
set B([expr {$S(rows)-1}],[expr {$S(cols)-1}]) -1 ;# Player 2's piece
set S(turn) 1
set S(won) 0 ;# Game not over yet
ShowBoard
}
proc ShowBoard {} {
global S
for {set row 0} {$row < $S(rows)} {incr row} {
for {set col 0} {$col < $S(cols)} {incr col} {
DoCircle $row $col
}
}
set S(msg) $S(turn,$S(turn))
}
proc DoCircle {row col} {
global B S
set w ".c$row,$col"
$w delete all
$w config -relief raised
set size [expr {abs($B($row,$col))}]
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 {$B($row,$col) / $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 {}
}
$w config -relief sunken
}
proc MakeBox {x y r} {
return [list [expr {$x-$r}] [expr {$y-$r}] [expr {$x+$r}] [expr {$y+$r}]]
}
proc AddOne {row col} {
global S B
if {abs([incr B($row,$col) $S(turn)]) == 4} {
DoExplode $row $col
} else {
DoCircle $row $col
}
}
proc DoExplode {row col} {
global S B
set B($row,$col) 0 ;# Exploding cell is empty
DoCircle $row $col ;# Erase it
foreach {dr dc} {-1 0 1 0 0 -1 0 1} {
set r [expr {$row + $dr}]
set c [expr {$col + $dc}]
if {$r < 0 || $r >= $S(rows) || $c < 0 || $c >= $S(cols)} continue
set B($r,$c) [expr {$S(turn) * abs($B($r,$c))}] ;# Take ownership
AddOne $r $c ;# Add another piece
}
}
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
AnimDelay $::S(anim) $start
}
}
proc AnimDelay {total start} {
update idletasks
set remaining [expr {$total - ([clock clicks -milliseconds] - $start)}]
if {$remaining > 0} { after $remaining }
}
proc WinOrLose {} {
global B S
array set cnt {-1 0 1 0}
foreach {arg value} [array get B] {
if {$value < 0} {incr cnt(-1)}
if {$value > 0} {incr cnt(1)}
}
if {$cnt(-1) == 0} {
set S(msg) "$S(color,1) Player won"
} elseif {$cnt(1) == 0} {
set S(msg) "$S(color,-1) Player won"
} else return
set S(won) 1
}
proc ButtonUp {w X Y row col} {
global S B
if {$S(won)} return ;# Game already over
if {$w != [winfo containing $X $Y]} return ;# Mouse moved out of cell
if {$B($row,$col) < 0 && $S(turn) > 0} return ;# Oppenent's cell
if {$B($row,$col) > 0 && $S(turn) < 0} return
AnimateBox $row $col ;# Pretty animation
AddOne $row $col ;# Do the actual move
set S(turn) [expr {-$S(turn)}]
set S(msg) $S(turn,$S(turn))
WinOrLose
}
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 command -label Exit -under 0 -command exit
.m.help add command -label Help -under 0 -command Help
}
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
}
################################################################
################################################################
################################################################
Init
DoDisplay
NewBoard