Isolation is a simple board game. The object is to "isolate" the opponent such that he cannot make any legal moves. Here is a screenshot: A B C D E F G H 1 * - - - - O * * 2 * * * * - - * * 3 - * * * - * - * 4 - - * * * - - - 5 - X * * * * * - 6 * * * * * * * * X, move a square> I challenge someone to write for me a nifty Tk interface. The code design is based on [RS]'s [TkAlign4]. The AI is a variant of my alpha-beta search from [iConnect4]. Blah blah blah copylefted GPL blah. Source code below. For your convenience you can also download it from http://tcl.jtang.org/isolation/isolation.tcl ---- #!/usr/bin/tclsh # An implementation of the Isolation board game by Jason Tang # (tang@jtang.org). # # Rules of the game: # # Two players ("X" and "O") each pick a starting square on an 8x6 # board. They then take alternating turns moving their piece any # number of squares in a straight line, horizontally, vertically, or # diagonally. When their piece leaves a square that originating # square is marked as "captured". A move may not jump over any # captured squares nor over the opponent's piece. The object of the # game is to isolate the opponent such that on his turn he is unable # to move anywhere. ###################################################################### # Model # creates and returns a new isolation board proc initBoard {} { set row {0 0 0 0 0 0 0 0} for {set i 0} {$i < 6} {incr i} { lappend board $row } return $board } # Given the board and two tuples, starting and destination square in # {r c} form, attempts to move the piece to the destination. If the # move is legal (i.e., in a straight line and not over any captured # squares) then returns the new board and a status of 0. Otherwise # return the original board and a status of -1. proc makeMove {board pos newPos} { foreach {or oc} $pos {} foreach {nr nc} $newPos {} set dy [expr {$or - $nr}] set dx [expr {$oc - $nc}] if {($dy == 0 && $dx != 0) || ($dx == 0 && $dy != 0) || (abs($dx) == abs($dy))} { # ensure that no intervening squares are filled set y $or set x $oc set ex [expr {$dx > 0 ? -1 : $dx < 0 ? 1 : 0}] set ey [expr {$dy > 0 ? -1 : $dy < 0 ? 1 : 0}] while {$dx != 0 || $dy != 0} { incr x $ex incr y $ey if {[lindex2 $board $y $x] == 1} { return [list $board -1] } incr dx $ex incr dy $ey } set board [lsetBoard $board $nr $nc 1] return [list $board 0] } else { return [list $board -1] } } # Given a board and a {r c} tuple returns 1 if the player cannot move # (i.e., dead), or 0 if still alive. proc isDead {board pos} { foreach {r c} $pos {} return [isDead2 $board $r $c] } # Given a board, a row, and a column, returns 1 if the player cannot # move (i.e., dead), or 0 if still alive. proc isDead2 {board r c} { foreach {dx dy} {1 0 -1 0 0 1 0 -1 1 1 -1 -1 1 -1 -1 1} { set x [expr {$c + $dx}] set y [expr {$r + $dy}] if {$x >= 0 && $x < 8 && $y >= 0 && $y < 6 && [lindex2 $board $y $x] == 0} { return 0 } } return 1 } ###################################################################### # View # Pretty-prints the board with super-spiffy column and row header. proc showBoard {board p1 p2} { puts " A B C D E F G H" puts "" set rowNum 0 foreach row $board { puts -nonewline [expr {$rowNum + 1}] set colNum 0 foreach col $row { puts -nonewline " " set coord [list $rowNum $colNum] if {$p1 == $coord} { puts -nonewline "X" } elseif {$p2 == $coord} { puts -nonewline "O" } else { switch -- $col { 0 { puts -nonewline "-" } 1 { puts -nonewline "*" } default { puts stderr "Illegal board"; exit -1 } } } incr colNum } puts "" incr rowNum } } ###################################################################### # Controller # Fetches a starting legal square from a player (human or AI). proc initSquare {board p1 p2 player} { if {$player == 1} { return [getSquare $board "X, pick a starting square> " $p1 $p2] # return [getInitAI $board] } else { # return [getSquare $board "O, pick a starting square> " $p1 $p2] return [getInitAI $board] } } # Fetches a move from a player -- does not actually check if move is # legal, only that the square specified is on the board and is not # already occupied. proc getMove {board p1 p2 player} { if {$player == 1} { set square [getSquare $board "X, move a square> " $p1 $p2] # return [getMoveAI $board $player $p1 $p2] } else { # set square [getSquare $board "O, move a square> " $p1 $p2] return [getMoveAI $board $player $p2 $p1] } return $square } # Prompts the user for a square. proc getSquare {board prompt p1 p2} { set legalSquare 0 showBoard $board $p1 $p2 puts "" while {!$legalSquare} { puts -nonewline $prompt flush stdout set line [gets stdin] if {$line == "?"} { showBoard $board $p1 $p2 puts "" } else { set col [string index $line 0] set row [string index $line 1] set legalSquare 1 switch -- $col { "a" - "A" { set col 0 } "b" - "B" { set col 1 } "c" - "C" { set col 2 } "d" - "D" { set col 3 } "e" - "E" { set col 4 } "f" - "F" { set col 5 } "g" - "G" { set col 6 } "h" - "H" { set col 7 } default { puts "Illegal column specified" set legalSquare 0 } } if {$row == "" || ![string is digit $row] || $row < 1 || $row > 6} { puts "Illegal row specified" set legalSquare 0 } else { incr row -1 } if $legalSquare { set square [list $row $col] if {[lindex2 $board $row $col] != 0} { puts "Specified location already taken" set legalSquare 0 } } } } return $square } ###################################################################### # AI stuff # The static board evaluator. Returns an integer where bigger number # is better for the owner at location {row col}. proc getScore {board row col} { set sum 0 foreach {dx dy} {-1 0 1 0 0 -1 0 1 1 -1 -1 1 -1 -1 1 1} { set y [expr {$row + $dy}] set x [expr {$col + $dx}] set score 1 while {$x >= 0 && $x <= 8 && $y >= 0 && $y <= 6} { if {[lindex2 $board $y $x] == 0} { set score [expr {$score << 1}] } else { break } incr x $dx incr y $dy } incr sum $score } if {$sum == 8} { return -10000 } return $sum } # Randomly pick a starting square proc getInitAI {board} { while {1} { set x [expr {int (rand () * 8)}] set y [expr {int (rand () * 6)}] if {[lindex2 $board $y $x] == 0} { return [list $y $x] } } } # Returns a tuple of where to move given the current board state and # which player to examine. proc getMoveAI {board player myrc opprc} { # MAXDEPTH: number of plies to search set MAXDEPTH 3 puts "Computer is thinking hard (using depth $MAXDEPTH)..." # keep track of the best moves found thus far set scores {} # and keep track of the number of expanded nodes set ::numNodesExpanded 0 foreach {row col} $myrc {} foreach {row2 col2} $opprc {} set opp [expr {-1 * $player}] # only try positions not already taken foreach {dx dy} {-1 0 1 0 0 -1 0 1 1 -1 -1 1 -1 -1 1 1} { set y [expr {$row + $dy}] set x [expr {$col + $dx}] while {$x >= 0 && $x <= 8 && $y >= 0 && $y <= 6} { if {[lindex2 $board $y $x] == 0} { set dupBoard [lsetBoard $board $y $x 1] set result [getMoveAB $dupBoard $row2 $col2 $y $x $player $opp -100001 100001 $MAXDEPTH] lappend scores [list $result $y $x] } else { break } incr x $dx incr y $dy } } # now pick the best score; in case of tie randomly choose one set bestMoves [list [lindex $scores 0]] set bestScore [lindex2 $scores 0 0] foreach currentTuple [lrange $scores 1 end] { set currentScore [lindex $currentTuple 0] if {$currentScore > $bestScore} { set bestMoves [list $currentTuple] set bestScore $currentScore } elseif {$currentScore == $bestScore} { lappend bestMoves $currentTuple } } set choiceTuple [lindex $bestMoves [expr {int (rand () * [llength $bestMoves])}]] puts "After searching $::numNodesExpanded nodes, best score was $bestScore" return [list [lindex $choiceTuple 1] [lindex $choiceTuple 2]] } # Perform a somewhat modified alpha-beta search on the board -- # modified in that the algorithm will short-circuit whenever it # detects an ending condition. proc getMoveAB {board r c r2 c2 me current alpha beta depth} { # because this node was expanded increment the counter incr ::numNodesExpanded # check if search is at a terminal state if {$depth <= 0} { set myscore [getScore $board $r $c] if {$me != $current} { set myscore [expr {-1 * $myscore}] } return $myscore } if {[isDead2 $board $r $c]} { if {$me == $current} { set myscore -10000 } else { set myscore 10000 } return $myscore } # else continue recursing by making another move incr depth -1 set newCurrent [expr {-1 * $current}] if {$me == $current} { # examining a max node -- do alpha pruning foreach {dx dy} {-1 0 1 0 0 -1 0 1 1 -1 -1 1 -1 -1 1 1} { set y [expr {$r + $dy}] set x [expr {$c + $dx}] while {$x >= 0 && $x <= 8 && $y >= 0 && $y <= 6} { if {[lindex2 $board $y $x] == 0} { set dupBoard [lsetBoard $board $y $x 1] set score [getMoveAB $dupBoard $r2 $c2 $y $x $me $newCurrent $alpha $beta $depth] if {$score > $alpha} { set alpha $score } if {$alpha >= $beta} { return $alpha } } else { break } incr x $dx incr y $dy } } return $alpha } else { # examining a min node -- do beta pruning foreach {dx dy} {-1 0 1 0 0 -1 0 1 1 -1 -1 1 -1 -1 1 1} { set y [expr {$r + $dy}] set x [expr {$c + $dx}] while {$x >= 0 && $x <= 8 && $y >= 0 && $y <= 6} { if {[lindex2 $board $y $x] == 0} { set dupBoard [lsetBoard $board $y $x 1] set score [getMoveAB $dupBoard $r2 $c2 $y $x $me $newCurrent $alpha $beta $depth] if {$score < $beta} { set beta $score } if {$beta <= $alpha} { return $beta } } else { break } incr x $dx incr y $dy } } return $beta } } ###################################################################### # Functions needed for tcl8.3 compatibility proc lindex2 {list ind1 ind2} { return [lindex [lindex $list $ind1] $ind2] } proc lsetBoard {board row column newValue} { set oldRow [lindex $board $row] set newRow [lrange $oldRow 0 [expr {$column - 1}]] lappend newRow $newValue set newRow [concat $newRow [lrange $oldRow [expr {$column + 1}] end]] set newBoard [lrange $board 0 [expr {$row - 1}]] lappend newBoard $newRow set newBoard [concat $newBoard [lrange $board [expr {$row + 1}] end]] return $newBoard } ###################################################################### # main script set board [initBoard] set p(1) {} set p(-1) {} # Get initial positions set p(1) [initSquare $board $p(1) $p(-1) 1] set board [lsetBoard $board [lindex $p(1) 0] [lindex $p(1) 1] 1] set p(-1) [initSquare $board $p(1) $p(-1) -1] set board [lsetBoard $board [lindex $p(-1) 0] [lindex $p(-1) 1] 1] # Start game. set gameOver 0 set player 1 while {1} { if {[isDead $board $p($player)]} { break } set square [getMove $board $p(1) $p(-1) $player] foreach {board result} [makeMove $board $p($player) $square] {} if {$result == -1} { puts "Illegal move." } else { set p($player) $square set player [expr {-1 * $player}] } } if {$player == 1} { puts "O is the winner!" } else { puts "X is the winner!" } showBoard $board $p(1) $p(-1) ---- [Category Games] | [Artificial Intelligence with Tcl]