----
[WikiDbImage tkataxx.jpg]

[Keith Vetter] 2003-02-19 -- this is an implementation of the popular Ataxx arcade game. You can play against the computer, against another player or have the computer play against itself. 
It uses a multi-level game tree search with alpha-beta pruning. By controlling how deep it searches you can control how smart the computer is. (I grabbed the game engine from here when I wrote [TkOverload].)

This is program I've had lying around for a while. I originally wrote this in 1995 and you can still find copies of that version floating around on the web.

There's another program on the web called tkAtaxx [http://www.cs.byu.edu/~williams/ataxx/tkataxx.html] that was 
written later in 1995. That one, however, requires compiling C code and only works on Unix boxes.

----
======
 #################################################################
 #
 # 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
 NewBoard
======
----
[Category Games] | [Tcl/Tk games] | [Category Application]