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.
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