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

[vetter_TkOverload_gameBoard_screenshot_243x342.jpg]

[vetter_TkOverload_helpWindow_screenshot_531x476.jpg]

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


<<categories>> Games | Tcl/Tk games | Application