uniquename 2013aug01Here is an image that shows the options on the 'Game' drop-down menu --- as well as an image of the Help window.
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