#
# TkAtaxx -- a tcl/tk implementation of the Ataxx arcade game.
# The computer uses a multi-level game tree search routine with
# alpha-beta pruning.
# by Keith P. Vetter
#
# Revision history:
# KPV 1/6/95 - Initial revision
# KPV 8/22/95 - Ported to tk 4.0
# KPV Feb 19, 2003 - cleaned up and ported to 8.4
package require Tk
##+##########################################################################
#
# Init -- sets up some global variables
#
proc Init {{cs 50}} {
global state newb index
set state(msg) "Welcome to TkAtaxx"
set state(cs) $cs ;# Size of a cell
set state(bs) [expr {round($cs * .9)}] ;# Size of a blob
set state(brd) -1 ;# Last board used
set state(c,1) Red ;# Colors for each player
set state(c,2) Green
set state(1) 0 ;# Human
set state(2) 1 ;# Computer
set state(level,max) 4
set state(level,0) Random
set state(level,1) Greedy
set state(level,2) Brainy
set state(level,3) Genius
set state(level,4) Einstein
set state(level,5) Einstein5 ;# Just be safe
set state(level,6) Einstein6
set state(level,7) Einstein7
set state(level) 1 ;# Current search level
# Various boards to play on
set newb(0) {{2,0} {4,0} {2,1} {4,1} {0,2} {6,2} {0,3}
{3,3} {6,3} {0,4} {6,4} {2,5} {4,5} {2,6} {4,6}}
set newb(1) {{3,0} {3,1} {3,2} {0,3} {1,3} {2,3}
{4,3} {5,3} {6,3} {3,4} {3,5} {3,6}}
set newb(2) {{3,0} {1,2} {2,2} {4,2} {5,2} {0,3} {1,3}
{5,3} {6,3} {1,4} {2,4} {4,4} {5,4} {3,6}}
set newb(3) {{1,0} {5,0} {0,1} {6,1} {3,3} {0,5} {6,5} {1,6} {5,6}}
set newb(4) {{2,0} {4,0} {2,1} {4,1} {0,3} {6,3} {2,5} {4,5} {2,6} {4,6}}
set newb(5) {{3,0} {3,1} {0,3} {1,3} {5,3} {6,3} {3,5} {3,6}}
set newb(6) {{3,1} {2,2} {4,2} {1,3} {5,3} {2,4} {4,4} {3,5}}
set newb(7) {{2,0} {4,0} {0,2} {6,2} {0,4} {6,4} {2,6} {4,6}}
set newb(8) {{3,0} {2,1} {4,1} {1,2} {5,2} {0,3} {6,3} {1,4}
{5,4} {2,5} {4,5} {3,6}}
set newb(9) {{2,1} {4,1} {1,2} {5,2} {1,4} {5,4} {2,5} {4,5}}
set newb(10) {{2,0} {4,0} {2,2} {4,2} {1,3} {5,3} {2,4} {4,4} {2,6} {4,6}}
set newb(11) {{3,1} {3,2} {1,3} {2,3} {3,3} {4,3} {5,3} {3,4} {3,5}}
set newb(12) {{1,1} {2,1} {3,1} {4,1} {5,1} {1,2}
{5,2} {1,3} {5,3} {1,4} {5,4} {1,5} {2,5} {3,5} {4,5} {5,5}}
set newb(13) {{2,1} {3,1} {4,1} {1,2} {5,2} {1,3}
{5,3} {1,4} {5,4} {2,5} {3,5} {4,5}}
set newb(14) {{2,1} {4,1} {1,2} {2,2} {4,2} {5,2}
{1,4} {2,4} {4,4} {5,4} {2,5} {4,5}}
set newb(15) {{1,1} {5,5} {1,5} {5,1}}
set newb(16) {{1,1} {2,1} {4,1} {5,1} {1,2} {5,2}
{1,4} {5,4} {1,5} {2,5} {4,5} {5,5}}
set newb(17) {{3,2} {2,3} {3,3} {4,3} {3,4}}
set newb(18) {{3,2} {2,3} {4,3} {3,4}}
set newb(19) {{3,1} {3,2} {1,3} {2,3} {4,3} {5,3} {3,4} {3,5}}
set newb(20) {{2,0} {3,0} {4,0} {3,1} {0,2} {6,2}
{0,3} {1,3} {5,3} {6,3} {0,4} {6,4} {3,5} {2,6} {3,6} {4,6}}
set newb(21) {{2,0} {4,0} {3,1} {0,2} {6,2} {1,3}
{5,3} {0,4} {6,4} {3,5} {2,6} {4,6}}
set newb(22) {{3,1} {1,3} {3,3} {5,3} {3,5}}
set newb(23) {{1,1} {3,1} {5,1} {1,3} {3,3} {5,3} {1,5} {3,5} {5,5}}
set newb(24) {}
set newb(25) {{2,2} {4,2} {3,3} {2,4} {4,4}}
set newb(26) {{1,1} {5,1} {2,2} {4,2} {3,3} {2,4} {4,4} {1,5} {5,5}}
set newb(27) {{2,0} {3,0} {4,0} {2,1} {4,1} {0,3}
{6,3} {2,5} {4,5} {2,6} {3,6} {4,6}}
set newb(28) {{1,0} {3,0} {5,0} {0,1} {2,1} {4,1} {6,1}
{1,2} {3,2} {5,2} {0,3} {2,3} {4,3} {6,3} {1,4}
{3,4} {5,4} {0,5} {2,5} {4,5} {6,5} {1,6} {3,6} {5,6}}
set newb(29) {{1,1} {5,1} {2,2} {4,2} {2,4} {4,4} {1,5} {5,5}}
set newb(30) {{3,0} {2,1} {4,1} {0,3} {6,3} {2,5} {4,5} {3,6}}
set newb(31) {{3,0} {0,3} {6,3} {3,6}}
set newb(32) {{3,1} {1,3} {5,3} {3,5}}
set newb(33) {{2,0} {3,0} {4,0} {0,2} {1,2} {3,2} {5,2}
{6,2} {0,3} {6,3} {0,4} {1,4} {3,4} {5,4} {6,4} {2,6} {3,6} {4,6}}
set newb(34) {{2,1} {4,1} {0,2} {1,2} {3,2} {5,2} {6,2}
{3,3} {0,4} {1,4} {3,4} {5,4} {6,4} {2,5} {4,5}}
set state(b) 35 ;# Number of boards
for {set r 0} {$r < 7} {incr r} { ;# Precompute index values
for {set c 0} {$c < 7} {incr c} {
set index($r,$c) [expr {24 + 11*$r + $c}]
}
}
}
##+##################################################
#
# Display -- Sets up the display
#
proc Display {} {
global state
wm title . "TkAtaxx"
wm minsize . 250 250
pack [frame .fbot] -side bottom -fill both
DrawMenus
set wi [expr {$state(cs) * 7}] ;# Total width
canvas .c -width $wi -height $wi -bd 2 -relief raised
.c xview moveto 0; .c yview moveto 0
bind .c <1> {MouseDown %x %y}
bind .c <Configure> Resize
pack .c -side top -fill both -expand 1
ShowGrid
label .msg -relief ridge -textvariable state(msg) -anchor w
frame .fsc -bd 2 -relief ridge
foreach n {1 2} {
canvas .c_p$n -width 16 -height 16
.c_p$n create oval 2 2 15 15 -fill $state(c,$n)
label .p$n -text "Score: "
label .psc_$n -textvariable state(sc,$n) -width 2
grid .c_p$n .p$n .psc_$n -in .fsc -row [expr {$n - 1}]
}
scale .level -orient h -from 0 -to $state(level,max) -relief ridge \
-showvalue 0 -variable state(level)
trace variable state(level) w TraceLevel
set state(level) $state(level)
pack .msg -side top -fill x -in .fbot
pack .fsc -side left -ipadx 5 -expand yes -fill y -in .fbot
pack .level -side right -expand yes -in .fbot -fill y
bind .level <2> {after 1 {hint -1} ; break}
bind .level <3> {after 1 {hint -2} ; break}
}
#
# DrawMenus -- Displays the menus on the screen
#
proc DrawMenus {} {
global state
menu .m -tearoff 0
. configure -menu .m
.m add cascade -menu .m.game -label "Game" -underline 0
.m add cascade -menu .m.opp -label "Opponent" -underline 0
.m add cascade -menu .m.help -label "Help" -underline 0
menu .m.game -tearoff 0
.m.game add command -label "New Board" -under 0 -command Go
.m.game add command -label "Restart" -under 0 -command [list Go -1]
.m.game add separator
.m.game add command -label "Hint" -under 0 -command hint
.m.game add command -label "Undo" -under 0 -command undo
.m.game add separator
.m.game add command -label "Exit" -under 0 -command exit
menu .m.opp -tearoff 0
.m.opp add check -label "Red - Computer" -under 0 -variable state(1) \
-command Start
.m.opp add check -label "Green - Computer" -under 0 -variable state(2) \
-command Start
.m.opp add separator
for {set lvl 0} {$lvl <= $state(level,max)} {incr lvl} {
.m.opp add radio -label $state(level,$lvl) -variable state(level) \
-value $lvl \
-under [expr {$lvl == 3 ? 2 : 0}] \
}
menu .m.help -tearoff 0
.m.help add command -label Help -under 0 -command Help
.m.help add command -label About -under 0 -command About
}
##+##################################################
#
# TraceLevel -- Handles changes in the scale for the depth of search
#
proc TraceLevel {var1 var2 op} {
.level config -label "Skill: $::state(level,$::state(level))"
}
##+##################################################
#
# RedrawBoard -- redraws all the pips and obstacles on the board
#
proc RedrawBoard {{brd ""}} {
global state bb index
if {$brd != ""} {set bb $brd}
ShowGrid
.c delete blob
set state(sc,0) 0 ;# Reset the scores
set state(sc,1) 0 ;# 0 is blanks, 1 is player 1
set state(sc,2) 0 ;# 2 is player 2
set state(sc,3) 0 ;# 3 is barriers
for {set r 0} {$r < 7} {incr r} {
for {set c 0} {$c < 7} {incr c} {
set cell [lindex $bb $index($r,$c)] ;# What's in the cell
incr state(sc,$cell) ;# Update score info
if {$cell == 3} {
MakeObstacle $r $c
} elseif {$cell > 0} {
MakeBlob $cell $r $c
}
}
}
set bb [lreplace $bb 121 end $state(sc,0) $state(sc,1) $state(sc,2) \
$state(sc,3)]
}
##+##################################################
#
# ShowGrid -- toggles the display of a grid on the board
#
proc ShowGrid {} {
global state
.c delete grid
set wi [expr {$state(cs) * 7}]
.c create rect 0 0 $wi $wi -width 5 -fill {} -tag grid
for {set i 1} {$i < 7} {incr i} {
set xy [expr {$i * $state(cs)}]
.c create line 0 $xy $wi $xy -tag grid
.c create line $xy $wi $xy 0 -tag grid
}
}
proc Resize {} {
set w [winfo width .c]
set h [winfo height .c]
set ::state(cs) [expr {(($w <= $h ? $w : $h) -10) / 7.0}]
set ::state(bs) [expr {round($::state(cs) * .9)}]
RedrawBoard
}
##+##################################################
#
# CellBBox -- returns the bounding box for a given row, col cell
#
proc CellBBox {r c} {
global state
set bs2 [expr {$state(bs) / 2.0}]
set x [expr {round(($c+.5) * $state(cs) - $bs2)}]
set y [expr {round(($r+.5) * $state(cs) - $bs2)}]
set x2 [expr {$x + $state(bs)}]
set y2 [expr {$y + $state(bs)}]
return [list $x $y $x2 $y2]
}
##+##################################################
#
# MakeBlob -- creates a new blob at location Row Col for WHO
#
proc MakeBlob {who r {c -1}} {
global state bb index
if {$c == -1} {
set c [expr {($r % 11) - 2}]
set r [expr {($r / 11) - 2}]
}
set col $state(c,$who)
set xy [CellBBox $r $c]
.c create oval $xy -fill ${col}3 -tag "blob blob${r}${c}"
eval .c create arc $xy -start 45 -extent 180 -fill ${col}1 -outline {{}} \
-tag \"blob blob${r}${c}\"
.c create oval [Shrink $xy 5] -fill ${col}2 -outline {} \
-tag "blob blob${r}${c}"
set p $index($r,$c) ;# Update board info
set bb [lreplace $bb $p $p $who] ;# Put new piece there
}
##+##################################################
#
# Shrink -- shrinks rectangle specified by x,y x2,y2
#
proc Shrink {xy n} {
foreach {x y x2 y2} $xy break
set x [expr {$x + $n}]
set y [expr {$y + $n}]
set x2 [expr {$x2 - $n}]
set y2 [expr {$y2 - $n}]
return [list $x $y $x2 $y2]
}
##+##################################################
#
# GrowBlob -- grows a blob at R,C
#
proc GrowBlob {who r c} {
global state
set xy [CellBBox $r $c]
for {set i [expr {$state(bs) / 2}]} {$i >= 0} {incr i -1} {
set now [clock clicks -milliseconds]
set bbox [Shrink $xy $i]
.c create oval $bbox -tag grow -fill $state(c,$who)
update idletasks
set now [expr {[clock clicks -milliseconds] - $now}]
set delay [expr {20 - $now}]
if {$delay > 0} {
after $delay
}
}
MakeBlob $who $r $c
.c delete grow
}
##+##################################################
#
# Highlight -- highlights cell R, C
#
proc highlight {r c} {
if {$r == -1} {
.c delete high
return
}
.c create rect [CellBBox $r $c] -fill {} -tag "blob high" -width 5
.c lower high
}
##+##################################################
#
# DeleteBlob -- deletes the blob from cell Row Col
#
proc DeleteBlob {r {c -1}} {
global bb index
if {$c == -1} {
set c [expr {($r % 11) - 2}]
set r [expr {($r / 11) - 2}]
}
.c delete blob${r}${c}
set p $index($r,$c) ;# Update board info
set bb [lreplace $bb $p $p 0] ;# Cell now empty
}
##+##################################################
#
# MakeObstacle -- creates an obstacle in cell Row Col
#
proc MakeObstacle {r c} {
global bb state
set xy [CellBBox $r $c]
foreach {x y x2 y2} $xy break
.c create poly $x $y $x $y2 $x2 $y -fill white -tag blob
.c create poly $x2 $y2 $x $y2 $x2 $y -fill gray45 -tag blob
.c create rect [Shrink $xy 2] -fill gray -outline "" -tag blob
set xy [Shrink $xy [expr {$state(cs) / 5}]]
.c create rect $xy -fill $state(c,1) -outline "" -tag "blob center"
}
##+##################################################
#
# CleanBoard -- deletes everything off the board
#
proc CleanBoard {} {
global bb
.c delete blob
set bb "4 4 4 4 4 4 4 4 4 4 4" ;# BB is the board info
append bb " 4 4 4 4 4 4 4 4 4 4 4" ;# ...w/ 2 row/col of sentinels
append bb " 4 4 0 0 0 0 0 0 0 4 4" ;# Actual board part
append bb " 4 4 0 0 0 0 0 0 0 4 4"
append bb " 4 4 0 0 0 0 0 0 0 4 4"
append bb " 4 4 0 0 0 0 0 0 0 4 4"
append bb " 4 4 0 0 0 0 0 0 0 4 4"
append bb " 4 4 0 0 0 0 0 0 0 4 4"
append bb " 4 4 0 0 0 0 0 0 0 4 4"
append bb " 4 4 4 4 4 4 4 4 4 4 4" ;# Bottom row sentinels
append bb " 4 4 4 4 4 4 4 4 4 4 4"
append bb " 45 2 2 0" ;# Cnt: empty, p1, p2, barriers
}
##+##################################################
#
# FillBoard -- fills all blanks board positions with a blob. Called
# when the game is over.
#
proc FillBoard {who} {
global state bb index
for {set r 0} {$r < 7} {incr r} {
for {set c 0} {$c < 7} {incr c} {
set p $index($r,$c)
if {[lindex $bb $p] == 0} {
MakeBlob $who $r $c
incr state(sc,$who)
update idletasks
}
}
}
}
proc Go {{restart 0}} {
set who -1
if {$restart} { set who $::state(brd)}
NewBoard $who
Start
}
##+##################################################
#
# NewBoard -- creates a new board with obstacles of type N
#
proc NewBoard {{who -1}} {
global newb state bb mm index
if {$who == -1} {
set who [expr {int(rand() * $state(b))}]
if {$who == $state(brd)} {
set who [expr {int(rand() * $state(b))}]
}
}
set state(brd) $who
CleanBoard
catch {unset mm}
set xy $index(0,0) ; set bb [lreplace $bb $xy $xy 1]
set xy $index(6,6) ; set bb [lreplace $bb $xy $xy 1]
set xy $index(6,0) ; set bb [lreplace $bb $xy $xy 2]
set xy $index(0,6) ; set bb [lreplace $bb $xy $xy 2]
foreach p $newb($who) { ;# Add the obstacles
set xy $index($p)
set bb [lreplace $bb $xy $xy 3]
}
RedrawBoard
set state(init) $bb
set state(turn) 1
set state(state) 0
set state(n) 0
set state(msg) ""
set state(tc) 0
set state(c) 0
}
##+##################################################
#
# Legal1 -- tests whether cell R,C is legal as a first move for
# player WHO. The cell must be in range, contain a WHO blob and can
# has a place to move.
#
proc Legal1 {r c who} {
global bb index
set xy $index($r,$c)
if {[lindex $bb $xy] != $who} { return 0 }
foreach i {1 2 9 10 11 12 13 20 21 22 23 24} {;# Neighbors 1 & 2 cells away
if {[lindex $bb [expr {$xy + $i}]] == 0} { return 1}
if {[lindex $bb [expr {$xy - $i}]] == 0} { return 1}
}
return 0
}
##+##################################################
#
# Legal2 -- Tests whether cell R,C is legal as a second move.
# Already we know the cell is empty, so we must check that
# its within 2 of the from cell.
#
proc Legal2 {to from} {
foreach {r c} $to break
foreach {fr fc} $from break
set dr [expr {abs($r - $fr)}]
if {$dr > 2} { return 0 }
set dc [expr {abs($c - $fc)}]
if {$dc > 2} { return 0 }
if {$dr == 2 || $dc == 2} { return 2}
return 1
}
##+##################################################
#
# MouseDown -- Called on a mouse down event. Handles moving pieces
# and checking legality.
#
proc MouseDown {x y} {
global state bb index
set r [expr {int($y / $state(cs))}]
set c [expr {int($x / $state(cs))}]
if {$r < 0 || $r > 6 || $c < 0 || $c > 6} return
set where [list $r $c]
set xy $index($r,$c)
set cell [lindex $bb $xy]
if {$cell == $state(turn)} {
highlight -1 -1
if {$state(state) == 1 && $state(from) == $where} {
set state(state) 0
return
}
if [Legal1 $r $c $state(turn)] {
highlight $r $c
set state(state) 1
set state(from) $where
return
}
}
if {$state(state) != 1} return
if {$cell != 0} return
set n [Legal2 $where $state(from)]
if $n {
DoMove $where $state(from) $n
} else {
highlight -1 -1
}
set state(state) 0
}
##+##################################################
#
# DoMove -- does the move from FR,FC to R,C. Updates the blobs, toggles any
# neighbors of the new cell and checks for end-of-game, and can move?
#
proc DoMove {to from type} {
global state bb mm
foreach {r c} $to break
foreach {fr fc} $from break
set mm($state(n)) [list $state(turn) $r $c $fr $fc $type];# Undo info
incr state(n)
set who $state(turn)
set opp [expr {3 - $who}]
highlight -1 -1
if {$type != -1} {
GrowBlob $state(turn) $r $c
set cnt [ToggleCells $r $c $state(turn)]
incr state(sc,$who) $cnt
incr state(sc,$opp) [expr {-1 * $cnt}]
if {$type > 1} { ;# Long jump???
DeleteBlob $fr $fc ;# ...then delete old blob
} else {
incr state(sc,$who)
incr state(sc,0) -1
}
set bb [lreplace $bb 121 123 $state(sc,0) $state(sc,1) $state(sc,2)]
update
}
if {$state(sc,0) == 0 || $state(sc,1) == 0 || $state(sc,2) == 0} {
EndGame
return
}
set mv [CanMove $opp] ;# Can opponent move?
if {$mv == 0} {
set state(msg) "$state(c,$opp) can't move. "
set state(msg) "$state(msg) $state(c,$who)'s turn"
} else {
set state(turn) $opp
.c itemconfig center -fill $state(c,$state(turn))
}
update
if {$state($state(turn))} robot ;# Do the computer move
}
##+##################################################
#
# ToggleCells -- turns all neighbors of R,C of into WHO blobs
#
proc ToggleCells {r c who} {
global bb index
set opp [expr {3 - $who}]
set cnt 0
set xy $index($r,$c)
foreach i {1 -1 10 -10 11 -11 12 -12} { ;# Immediate neighbors
set p [expr {$xy + $i}]
if {[lindex $bb $p] == $opp} {
DeleteBlob $p
MakeBlob $who $p
incr cnt
}
}
return $cnt
}
##+##################################################
#
# CanMove -- determines if WHO has a legal move
#
proc CanMove {who} {
global state bb index
for {set r 0} {$r < 7} {incr r} {
for {set c 0} {$c < 7} {incr c} {
set xy $index($r,$c)
if {[lindex $bb $xy] != $who} continue
if [Legal1 $r $c $who] {
return 1
}
}
}
return 0
}
##+##################################################
#
# EndGame -- handles end-of-game stuff
#
proc EndGame {} {
global state
if {$state(sc,0) != 0} {
FillBoard [expr {($state(sc,1) > $state(sc,2)) ? 1 : 2}]
}
if {$state(sc,1) > $state(sc,2)} { ;# Player 1 won
set state(msg) "Game over: $state(c,1) won"
} elseif {$state(sc,2) > $state(sc,1)} { ;# Player 2 own
set state(msg) "Game over: $state(c,2) won"
} else {
set state(msg) "Game over: it's a tie"
}
}
##+##################################################
#
# Index -- given row, col returns the corresponding index into the board
#
proc rindex {i} {
return [list [expr {($i / 11) - 2}] [expr {($i % 11) - 2}]]
}
##+##################################################
#
# Undo -- undo last move. Works by replaying all but the last moves.
#
proc undo {} {
global state mm bb
if {$state(n) == 0} {
set state(msg) "Nothing to undo"
return
}
set state(msg) "Undoing last move"
set brd $state(init) ;# Starting position
set n [expr {$state(n) - 1}] ;# Number of moves to undo
set w [lindex $mm($n) 0] ;# Who made last turn
if {$state($w)} { ;# Last move by computer
incr n -1 ;# So undo both moves
set w [expr {3 - $w}] ;# Whose turn it is
}
for {set i 0} {$i < $n} {incr i} { ;# Re-do each move
set brd [move2 $brd $mm($i)]
}
set state(n) $n
set bb $brd
RedrawBoard
set state(state) 0
highlight -1 -1
set state(turn) $w
.c itemconfig center -fill $state(c,$state(turn))
}
##+##################################################
#
# Robot -- moves the pieces for the robot player.
# Does a game-tree search for the best move.
#
proc robot {{level -1}} {
global state bb
set who $state(turn)
if {$level == -1} { set level $state(level) }
if {$level == 0} { ;# Random skill level
set m [lindex [AllMoves $who $bb] 0]
} else {
set state(c) 0
set state(msg) "Thinking ($state(level,$level))"
busy 1
set t [time {set mv [veb $who $bb $level 10000]}];# Get best move
set state(msg) ""
set tt [expr {[lindex $t 0] / 1000000.0}]
set state(msg) "Rating: [lindex $mv 0] ($state(c) calls in $tt seconds)"
incr state(tc) $state(c)
busy 0
set m [lindex $mv 1]
}
foreach {from to type} $m break
DoMove [rindex $to] [rindex $from] $type
}
proc busy {onoff} {
if {$onoff} {set how watch} {set how {}}
foreach w [winfo children .] {
$w config -cursor $how
}
update idletasks
}
##+##################################################
#
# Hint -- suggest a move
#
proc hint {{level -1}} {
global state bb
if {$level == -1} { ;# Was level specified?
set level $state(level)
if {$level == 0} { ;# Level 0 is not a hint
set level 1
}
}
if {$level == -2} { ;# -2 is smart as possible
set level $state(level,max)
}
if {$level < 0} {
set level [expr {abs($level)}]
}
highlight -1 -1
set state(c) 0
set state(msg) "Thinking ($state(level,$level))"
busy 1
set t [time {set mv [veb $state(turn) $bb $level 10000]}];# Find best move
set state(msg) ""
set tt [expr {[lindex $t 0] / 1000000.0}]
set state(msg) "Rating: [lindex $mv 0] ($state(c) calls in $tt seconds)"
busy 0
set m [lindex $mv 1]
set from [lindex $m 0]
set to [lindex $m 1]
foreach {from to} [lindex $mv 1] break
eval highlight [rindex $from]
eval highlight [rindex $to]
}
##+##################################################
#
# AllMoves -- returns a list of all legal moves for WHO on board BRD.
# Format is (from to type).
#
proc AllMoves {who brd} {
set m ""
for {set i 24} {$i < 97} {incr i} {
set c [lindex $brd $i]
if {$c == 4} { ;# Is it a border cell?
incr i 3
continue
}
if {$c != $who} continue
foreach j {1 10 11 12 -1 -10 -11 -12} { ;# Immediate neighbors
set xy [expr {$i + $j}]
if {[lindex $brd $xy] == 0} {
lappend m [list $i $xy 1]
set brd [lreplace $brd $xy $xy -1];# So we don't go here twice
}
}
foreach j {2 9 13 20 21 22 23 24} { ;# Neighbors 2 away
if {[lindex $brd [expr {$i + $j}]] <= 0} {
lappend m [list $i [expr {$i + $j}] 2]
}
if {[lindex $brd [expr {$i - $j}]] <= 0} {
lappend m [list $i [expr {$i - $j}] 2]
}
}
}
set n [llength $m]
if {$n == 0} {
return {{0 0 -1}}
}
set n [expr {int(rand() * $n)}] ;# Randomize the order
set m [concat [lrange $m $n end] [lrange $m 0 [expr {$n - 1}]]]
return $m
}
##+##################################################
#
# Move -- returns new board with WHO moving FROM to TO on board BRD.
# Does no screen updates.
#
proc move {who brd M} {
foreach {frm to type} $M break
if {$type == -1} { return $brd }
set opp [expr {3 - $who}]
set sw [lindex $brd [expr {121 + $who}]]
set so [lindex $brd [expr {121 + $opp}]]
set brd [lreplace $brd $to $to $who]
if {$type == 2} {
set brd [lreplace $brd $frm $frm 0]
} else {
incr sw
set e [lindex $brd 121]
set brd [lreplace $brd 121 121 [expr {$e - 1}]]
}
foreach i {1 10 11 12 -1 -10 -11 -12} { ;# Immediate neighbors
set xy [expr {$to + $i}]
if {[lindex $brd $xy] == $opp} {
set brd [lreplace $brd $xy $xy $who]
incr sw
incr so -1
}
}
if {$who == 1} {
set brd [lreplace $brd 122 123 $sw $so]
} else {
set brd [lreplace $brd 122 123 $so $sw]
}
return $brd
}
proc move2 {brd MM} {
foreach {who r c fr fc type} $MM break
global index
set b [move $who $brd [list $index($fr,$fc) $index($r,$c) $type]]
return $b
}
##+##################################################
#
# E -- evaluates a position for WHO. Simply the difference in number of men.
#
proc e {who brd} {
set me [lindex $brd [expr {121 + $who}]]
set you [lindex $brd [expr {124 - $who}]]
if {$you == 0} { return 10000 }
if {$me == 0} { return -10000 }
return [expr {$me - $you}]
}
##+##################################################
#
# Veb -- game-tree search with alpha-beta pruning. See _Fundamentals of Data
# Structures_, Horowitz, page 268.
#
# Initial call: veb (who board level infinity)
#
proc veb {who brd l d} {
global state
incr state(c) ;# Stats
if {$l == 0 || [lindex $brd 121] == 0} { ;# Terminal position?
return [e $who $brd] ;# ...just evaluate position
}
set ans -10000 ;# Lower bound on value
set best "" ;# Current best move
incr l -1
set moves [AllMoves $who $brd]
foreach m $moves {
set b [move $who $brd $m]
set e [veb [expr {3 - $who}] $b $l [expr {-1 * $ans}]]
set a [expr {-1 * [lindex $e 0]}]
if {$a > $ans} { ;# Is it a better move?
set ans $a ;# Yep, so use it
set best [list $m]
}
if {$ans >= $d} break ;# BETA rule
}
return [concat $ans $best]
}
##+##################################################
#
# Start -- starts/continues the game if it's the computer's turn
#
proc Start {} {
if {$::state(sc,0) == 0 || $::state(sc,1) == 0} return
if {$::state($::state(turn)) == 1} robot
}
proc About {} {
set msg "TkAtaxx\n\nby Keith Vetter\nFebruary, 2003"
tk_messageBox -title About -message $msg
}
##+##################################################
#
# Help -- displays a help screen
#
proc Help {} {
destroy .help
toplevel .help
wm title .help "TkAtaxx Help"
wm geom .help "+[expr {[winfo x .] + [winfo width .] + 10}]+[winfo y .]"
text .help.t -relief raised -wrap word -width 70 -height 32
.help.t config -padx 10 -pady 10
button .help.dismiss -text Dismiss -command {destroy .help}
pack .help.dismiss -side bottom -pady 10
pack .help.t -side top -expand 1 -fill both
set bold "[font actual [.help.t cget -font]] -weight bold"
.help.t tag configure title -justify center -foreground 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 insert end "TkAtaxx\n" title "by Keith Vetter\n\n" title2
set msg "TkAtaxx is a tcl/tk implementation of the popular "
append msg "arcade video Ataxx. The goal of the game is end up "
append msg "with more pieces of your color than your "
append msg "opponent. The game ends when there are no more "
append msg "places to move. "
.help.t insert end "DESCRIPTION\n" bullet $msg n \n\n
set msg "You can move a piece in two different ways, either "
append msg "sliding or jumping. To slide a piece, click on it "
append msg "with the mouse, then click on an immediately "
append msg "adjacent empty cell. The piece will split and "
append msg "occupy both cells. To jump a piece, click on it "
append msg "with the mouse, then click on an empty cell which "
append msg "is exactly two positions away from the starting piece. The "
append msg "piece will jump to the new position over any "
append msg "intervening obstacles vacating the original "
append msg "position. If there are no possible moves for a "
append msg "player then the move if forfeited. "
append msg "\n\nWhen a piece moves to a new cells, all surrounding "
append msg "cells of the opponent's color will be captured and "
append msg "turn into your color."
.help.t insert end "MOVING\n" bullet $msg n \n\n
set msg "You can adjust how smart the computer opponent "
append msg "is. Random skill picks any move at "
append msg "random. Greedy picks the move which maximizes how "
append msg "many pieces he has at the end of the turn. Brainy "
append msg "searches two moves ahead of the best move. Genius "
append msg "searches three moves ahead for the best move.\n\n"
append msg "More technically, TkAtaxx uses a Min-Max search "
append msg "algorithm with alpha-beta pruning to find the best move. "
append msg "The skill level corresponds to the depth of the search."
.help.t insert end "SKILL LEVEL\n" bullet $msg n
.help.t config -state disabled
}
##+##################################################
Init
Display
NewBoardGetting started
Home • Recent changes • Help • Create new page • Search • Add comments
• Edit