[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

----
[Category Games] - [Tcl/Tk games]