Improved the play

TicTacToe.hs

@@ -7,10 +7,8 @@ import Data.List.Split (chunk)
 import Data.Ord (comparing)
 import System.Random (Random, StdGen, randomR, newStdGen, split)
 import System.IO (hSetBuffering, stdin, stdout, BufferMode(..))
-import Control.Monad.State (State, get, put, runState)
+import Control.Monad.State (State, get, put, runState, evalState)
 import qualified Data.Map as M
--- import Debug.Trace (trace)
--- import System.Environment (getArgs)
 
 -- Randomness setup
 
@@ -28,6 +26,9 @@ randomChoose list = do
   i <- getRandomR (0, length list - 1)
   return $ list !! i
 
+toss :: RandomState Bool
+toss = randomChoose [True, False]
+
 -- Board setup
 
 data Move = Nought | Cross deriving (Eq, Ord)
@@ -78,9 +79,9 @@ diags board =
   [[board !! 0, board !! 4, board !! 8],
    [board !! 2, board !! 4, board !! 6]]
 
-nextBoards :: Move -> Board -> [Board]
+nextBoards :: Move -> Board -> [(Int, Board)]
 nextBoards move board =
-  map ((\p -> makeMove p move board) . cellPos)
+  map ((\p -> (p, makeMove p move board)) . cellPos)
   $ filter (\c -> cellState c == Empty) board
 
 isWin :: Move -> Board -> Bool
@@ -117,6 +118,7 @@ class Player a where
   play :: a -> Board -> (a, Board)
   improvePlayer :: a -> Result -> Run -> a
 
+-- play a match between two players
 playMatch :: (Player p1, Player p2) => p1 -> p2 -> (Result, Run, p1, p2)
 playMatch player1 player2 = playMatch_ player1 player2 emptyBoard
 
@@ -126,12 +128,13 @@ playMatch_ player1 player2 board =
     Unfinished -> let
       (player1', board') = play player1 board
       in case result (playerMove player1) board' of
-          Unfinished -> let
+        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')
+          in (otherResult res', board' : run, player1'', player2')
-          res -> (res, [], 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 times player1 player2 =
   foldl (\(matches, p1, p2) _ ->
@@ -144,8 +147,9 @@ playMatches times player1 player2 =
 
 -- RandomPlayer setup
 
+-- play randomly. choose a random move
 randomPlay :: Move -> Board -> RandomState Board
-randomPlay move board = randomChoose (nextBoards move board)
+randomPlay move board = randomChoose (map snd $ nextBoards move board)
 
 data RandomPlayer = RandomPlayer Move StdGen deriving (Show)
 
@@ -161,36 +165,43 @@ instance Player RandomPlayer where
 
 type Memory = M.Map Board (Int, Int, Int)
 
+-- boards equivalent to this board
 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)
 
+-- play using the strategy learned till now
 learningPlay :: LearningPlayer -> Board -> (LearningPlayer, Board)
-learningPlay (LearningPlayer move mem gen) board =
+learningPlay (LearningPlayer move mem gen) board = let
-  let
+  next = map snd $ nextBoards move board
-    scores = map (\b -> (b, boardScore b mem)) $ nextBoards move board
+  in case filter (isWin move) next of
-    (board', (w, _, d)) = maximumBy (comparing (rankScore . snd)) scores
+    (winBoard:_) -> (LearningPlayer move mem gen, winBoard)
-  in -- trace (show move ++ " Max: " ++ show (w, d) ++ " " ++ show board') $
+    [] -> let
-    if w /= 0
+      otherNext = nextBoards (otherMove move) board
-    then -- trace (show move ++ " M: " ++ show board') $
+      in case filter (isWin (otherMove move) . snd) otherNext of
-      (LearningPlayer move mem gen, board')
+        ((pos,_):_) -> (LearningPlayer move mem gen, makeMove pos move board)
-    else let
+        [] -> let
-      ((rBoard, _), gen') = runState (randomChoose scores) gen
+          scores = map (\b -> (b, boardScore b mem)) $ next
-    in -- trace (show move ++ " R: " ++ show rBoard) $
+          (board', (w, _, d)) = maximumBy (comparing (calcScore . snd)) scores
-      (LearningPlayer move mem gen', rBoard)
+          in if w /= 0
+             then (LearningPlayer move mem gen, board')
+             else let
+               ((rBoard, _), gen') = runState (randomChoose scores) gen
+             in (LearningPlayer move mem gen', rBoard)
   where
     boardScore board' mem =
       foldl (\score b' -> sumScores score $ M.findWithDefault (0, 0, 0) b' mem)
             (0, 0, 0) (eqvBoards board')
     sumScores (w, l, d) (w', l', d') = (w + w', l + l', d + d')
 
-rankScore :: (Int, Int, Int) -> Double
+calcScore :: (Int, Int, Int) -> Double
-rankScore (w, l, d) = fromIntegral w + fromIntegral d * 0.5 - fromIntegral l
+calcScore (w, l, d) = fromIntegral w + fromIntegral d * 0.5 - fromIntegral l
 
-learn :: Result -> Run -> Memory -> Memory
+-- learn strategy from the run
-learn res run mem = let
+learnFromRun :: Result -> Run -> Memory -> Memory
+learnFromRun res run mem = let
   score = incrementScore res (0, 0, 0)
   mem' = foldl (\m b -> M.insertWith (\_ -> incrementScore res) b score m)
                mem run
@@ -206,26 +217,27 @@ instance Player LearningPlayer where
   playerMove (LearningPlayer move _ _) = move
   play = learningPlay
   improvePlayer (LearningPlayer move mem gen) res run =
-    LearningPlayer move (learn res run mem) gen
+    LearningPlayer move (learnFromRun res run mem) gen
 
+-- play two LearningPlayers against each other to learn strategy
 learnedPlayer :: Move -> StdGen -> LearningPlayer
 learnedPlayer 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
-  -- mapM_ (putStrLn . show) $ reverse matches
   in p1'
 
 -- Play against human
 
-playHuman :: Player t => t -> Board -> IO ()
+-- play a player against a human. human enters moves from prompt.
+playHuman :: Player p => p -> Board -> IO ()
 playHuman player board = do
   printBoard board
   case result (playerMove player) board of
     Unfinished -> do
       putStr "Move? "
-      pos <- fmap read getLine
+      pos <- fmap (decr . read) getLine
       if pos < 0 || pos > 8
       then do
         putStrLn "Invalid Move"
@@ -245,6 +257,7 @@ playHuman player board = do
                 printBoard board'
                 putStrLn ("Your " ++ show (otherResult res))
     res -> putStrLn ("Your " ++ show (otherResult res))
+  where decr x = x - 1
 
 main :: IO ()
 main = do
@@ -254,4 +267,13 @@ main = do
   putStrLn "Learning ..."
   let !player = learnedPlayer Cross gen
   putStrLn "Learned"
-  playHuman player emptyBoard
+  putStrLn "Tossing for first move"
+  let t = evalState toss gen
+  if t
+  then do
+    putStrLn "You win toss"
+    playHuman player emptyBoard
+  else do
+    putStrLn "You lose toss"
+    let (player', board) = play player emptyBoard
+    playHuman player' board