diff --git a/TicTacToe.hs b/TicTacToe.hs index 62f4d6f..0db6295 100644 --- a/TicTacToe.hs +++ b/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 - (res', run, player2', player1'') = playMatch_ player2 player1' board' - in (otherResult res', board' : run, player1'', player2') - res -> (res, [], player1', player2) + Unfinished -> let + (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 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 = - let - scores = map (\b -> (b, boardScore b mem)) $ nextBoards move board - (board', (w, _, d)) = maximumBy (comparing (rankScore . snd)) scores - in -- trace (show move ++ " Max: " ++ show (w, d) ++ " " ++ show board') $ - if w /= 0 - then -- trace (show move ++ " M: " ++ show board') $ - (LearningPlayer move mem gen, board') - else let - ((rBoard, _), gen') = runState (randomChoose scores) gen - in -- trace (show move ++ " R: " ++ show rBoard) $ - (LearningPlayer move mem gen', rBoard) +learningPlay (LearningPlayer move mem gen) board = let + next = map snd $ nextBoards move board + in case filter (isWin move) next of + (winBoard:_) -> (LearningPlayer move mem gen, winBoard) + [] -> let + otherNext = nextBoards (otherMove move) board + in case filter (isWin (otherMove move) . snd) otherNext of + ((pos,_):_) -> (LearningPlayer move mem gen, makeMove pos move board) + [] -> let + scores = map (\b -> (b, boardScore b mem)) $ next + (board', (w, _, d)) = maximumBy (comparing (calcScore . snd)) scores + 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 -rankScore (w, l, d) = fromIntegral w + fromIntegral d * 0.5 - fromIntegral l +calcScore :: (Int, Int, Int) -> Double +calcScore (w, l, d) = fromIntegral w + fromIntegral d * 0.5 - fromIntegral l -learn :: Result -> Run -> Memory -> Memory -learn res run mem = let +-- learn strategy from the run +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 \ No newline at end of file + 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