Generalized to play on a n x n board

TicTacToe.hs

@@ -5,20 +5,24 @@
 
   A solution to rubyquiz 11 (http://rubyquiz.com/quiz11.html).
 
+  Usage: ./TicTacToe board_size training_time
+
   Copyright 2012 Abhinav Sarkar <abhinav@abhinavsarkar.net>
 -}
 
-{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE BangPatterns, RecordWildCards #-}
 
 module Main where
 
+import qualified Data.Map as M
+import Control.Monad.State (State, get, put, runState, evalState)
 import Data.List (sort, nub, maximumBy)
 import Data.List.Split (chunk)
 import Data.Ord (comparing)
-import System.Random (Random, StdGen, randomR, newStdGen, split)
+import System.Environment (getArgs)
 import System.IO (hSetBuffering, stdin, stdout, BufferMode(..))
-import Control.Monad.State (State, get, put, runState, evalState)
+import System.Random (Random, StdGen, randomR, newStdGen, split)
-import qualified Data.Map as M
+import Text.Printf (printf)
 
 -- Randomness setup
 
@@ -45,9 +49,9 @@ data Move = Nought | Cross deriving (Eq, Ord)
 
 data CellState = Filled Move | Empty deriving (Eq, Ord)
 
-data Cell = Cell {cellPos :: Int, cellState :: CellState} deriving (Eq, Ord)
+data Cell = Cell { cellPos :: Int, cellState :: CellState } deriving (Eq, Ord)
 
-type Board = [Cell]
+data Board = Board { boardSize :: Int, boardCells :: [Cell] } deriving (Eq, Ord)
 
 type Run = [Board]
 
@@ -73,50 +77,62 @@ otherResult Draw = Draw
 otherResult Loss = Win
 otherResult Win = Loss
 
-emptyBoard :: Board
+emptyBoard :: Int -> Board
-emptyBoard = map (flip Cell Empty) [0..8]
+emptyBoard boardSize =
+  Board boardSize $ map (flip Cell Empty) [0..(boardSize * boardSize - 1)]
 
 printBoard :: Board -> IO ()
-printBoard board = putStrLn "" >> (mapM_ print . chunk 3 $ board)
+printBoard Board{..} = putStrLn "" >> (mapM_ print . chunk boardSize $ boardCells)
 
 makeMove :: Int -> Move -> Board -> Board
-makeMove pos move board =
+makeMove pos move board@Board{..} =
-  let (l, r) = splitAt pos board
+  let (l, r) = splitAt pos boardCells
-  in l ++ [Cell pos (Filled move)] ++ tail r
+  in board { boardCells = l ++ [Cell pos (Filled move)] ++ tail r }
 
 diags :: Board -> [[Cell]]
-diags board =
+diags Board{..} =
-  [[board !! 0, board !! 4, board !! 8],
+  [map (boardCells !!) . take boardSize . iterate (+ (boardSize + 1)) $ 0,
-   [board !! 2, board !! 4, board !! 6]]
+   map (boardCells !!) . take boardSize . iterate (+ (boardSize - 1)) $ (boardSize - 1)]
 
 nextBoards :: Move -> Board -> [(Int, Board)]
-nextBoards move board =
+nextBoards move board@Board{..} =
   map ((\p -> (p, makeMove p move board)) . cellPos)
-  $ filter (\c -> cellState c == Empty) board
+  $ filter (\c -> cellState c == Empty) boardCells
 
 isWin :: Move -> Board -> Bool
 isWin move board =
-  or [any isStrike $ chunk 3 $ map cellState board,
+  or [any isStrike . chunk size . map cellState . boardCells $ board,
-      any isStrike $ chunk 3 $ map cellState $ rotateBoard board,
+      any isStrike . chunk size . map cellState . boardCells . rotateBoard $ board,
-      any isStrike $ map (map cellState) $ diags board]
+      any isStrike . map (map cellState) . diags $ board]
   where
-    isStrike = (== replicate 3 (Filled move))
+    size = boardSize board
+    isStrike = (== replicate size (Filled move))
 
 result :: Move -> Board -> Result
 result move board
-  | isWin move board                 = Win
+  | isWin move board                                  = Win
-  | isWin (otherMove move) board     = Loss
+  | isWin (otherMove move) board                      = Loss
-  | Empty `elem` map cellState board = Unfinished
+  | Empty `elem` (map cellState . boardCells $ board) = Unfinished
-  | otherwise                        = Draw
+  | otherwise                                         = Draw
 
 translateBoard :: [Int] -> Board -> Board
-translateBoard idxs board =
+translateBoard idxs board@Board{..} =
-  map (\(i, ri) -> Cell i $ cellState $ board !! ri) $ zip [0..8] idxs
+  board { boardCells =
+    map (\(i, ri) -> Cell i . cellState $ boardCells !! ri)
+    $ zip [0..(boardSize * boardSize - 1)] idxs }
 
 rotateBoard, xMirrorBoard, yMirrorBoard :: Board -> Board
-rotateBoard  = translateBoard [6,3,0,7,4,1,8,5,2]
+rotateBoard board@Board{..} =
-xMirrorBoard = translateBoard [2,1,0,5,4,3,8,7,6]
+  translateBoard
-yMirrorBoard = translateBoard [6,7,8,3,4,5,0,1,2]
+    (let xs = reverse . chunk boardSize $ [0..(boardSize *  boardSize - 1)]
+      in concatMap (\i -> map (!! i ) xs) [0..(boardSize - 1)])
+    board
+xMirrorBoard board@Board{..} =
+  translateBoard
+    (concatMap reverse . chunk boardSize $ [0..(boardSize * boardSize - 1)]) board
+yMirrorBoard board@Board{..} =
+  translateBoard
+    (concat . reverse . chunk boardSize $ [0..(boardSize * boardSize - 1)]) board
 
 rotateBoardN :: Board -> Int -> Board
 rotateBoardN board n = foldl (\b _ -> rotateBoard b) board [1..n]
@@ -129,27 +145,26 @@ class Player a where
   improvePlayer :: a -> Result -> Run -> a
 
 -- play a match between two players
-playMatch :: (Player p1, Player p2) => p1 -> p2 -> (Result, Run, p1, p2)
+playMatch :: (Player p1, Player p2) => p1 -> p2 -> Board -> (Result, Run, p1, p2)
-playMatch player1 player2 = playMatch_ player1 player2 emptyBoard
+playMatch player1 player2 board =
-
-playMatch_ :: (Player p1, Player p2) => p1 -> p2 -> Board -> (Result, Run, p1, p2)
-playMatch_ player1 player2 board =
   case result (playerMove player1) board of
     Unfinished -> let
       (player1', board') = play player1 board
       in case result (playerMove player1) board' of
         Unfinished -> let
-          (res', run, player2', player1'') = playMatch_ player2 player1' board'
+          (res', run, player2', player1'') = playMatch player2 player1' board'
           in (otherResult res', board' : run, player1'', player2')
         res -> (res, [], player1', player2)
     res -> (res, [], player1, player2)
 
 -- play multiple matches between two players
-playMatches :: (Player p1, Player p2) => Int -> p1 -> p2 -> ([(Result, Run)],p1, p2)
+playMatches :: (Player p1, Player p2) => Int -> Int -> p1 -> p2
-playMatches times player1 player2 =
+               -> ([(Result, Run)],p1, p2)
+playMatches boardSize times player1 player2 =
   foldl (\(matches, p1, p2) _ ->
     let
-      (res, run, p1', p2') = playMatch p1 p2
+      startBoard = emptyBoard boardSize
+      (res, run, p1', p2') = playMatch p1 p2 startBoard
       p1'' = improvePlayer p1' res run
       p2'' = improvePlayer p2' (otherResult res) run
     in  ((res, run) : matches, p1'', p2''))
@@ -180,7 +195,7 @@ eqvBoards :: Board -> [Board]
 eqvBoards board = nub . sort $
   board : map (rotateBoardN board) [1..3] ++ [xMirrorBoard board, yMirrorBoard board]
 
-data LearningPlayer = LearningPlayer Move Memory StdGen deriving (Show)
+data LearningPlayer = LearningPlayer Move Memory StdGen
 
 -- play using the strategy learned till now
 learningPlay :: LearningPlayer -> Board -> (LearningPlayer, Board)
@@ -230,30 +245,32 @@ instance Player LearningPlayer where
     LearningPlayer move (learnFromRun res run mem) gen
 
 -- play two LearningPlayers against each other to learn strategy
-learnedPlayer :: Move -> StdGen -> LearningPlayer
+learnedPlayer :: Int -> Int -> Move -> StdGen -> LearningPlayer
-learnedPlayer move gen = let
+learnedPlayer boardSize times move gen = let
   (gen1, gen2) = split gen
   p1 = LearningPlayer move M.empty gen1
   p2 = LearningPlayer (otherMove move) M.empty gen2
-  (_, p1', p2') = playMatches 1000 p1 p2
+  (_, p1', p2') = playMatches boardSize times p1 p2
   in p1'
 
 -- Play against human
 
 -- play a player against a human. human enters moves from prompt.
 playHuman :: Player p => p -> Board -> IO ()
-playHuman player board = do
+playHuman player board@Board{..} = do
   printBoard board
+  let boardArea = boardSize * boardSize
   case result (playerMove player) board of
     Unfinished -> do
-      putStr "Move? "
+      putStr $ printf "Move %s? [1-%s] "
+                      (show . otherMove . playerMove $ player) (show boardArea)
       pos <- fmap (decr . read) getLine
-      if pos < 0 || pos > 8
+      if pos < 0 || pos > (boardArea - 1)
       then do
         putStrLn "Invalid Move"
         playHuman player board
       else
-        case cellState (board !! pos) of
+        case cellState (boardCells !! pos) of
           Filled _ -> do
             putStrLn "Invalid Move"
             playHuman player board
@@ -271,19 +288,21 @@ playHuman player board = do
 
 main :: IO ()
 main = do
+  (boardSize : times : _) <- fmap (map read) getArgs
   hSetBuffering stdin LineBuffering
   hSetBuffering stdout NoBuffering
   gen <- newStdGen
   putStrLn "Learning ..."
-  let !player = learnedPlayer Cross gen
+  let !player = learnedPlayer boardSize times Cross gen
   putStrLn "Learned"
   putStrLn "Tossing for first move"
   let t = evalState toss gen
+  let startBoard = emptyBoard boardSize
   if t
   then do
     putStrLn "You win toss"
-    playHuman player emptyBoard
+    playHuman player startBoard
   else do
     putStrLn "You lose toss"
-    let (player', board) = play player emptyBoard
+    let (player', board) = play player startBoard
     playHuman player' board