#!/usr/bin/tclsh
 
 # An implementation of the Isolation board game by Jason Tang
 # ([email protected]).
 #
 # 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)