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