You cannot select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
312 lines
10 KiB
Haskell
312 lines
10 KiB
Haskell
{-
|
|
A learning tic-tac-toe player in Haskell. It learns the game
|
|
by playing against itself repeatedly.
|
|
It can play against humans too!
|
|
|
|
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, RecordWildCards #-}
|
|
|
|
module TicTacToe (Move(..), CellState(..), Cell(..), Board(..), Run, Result(..),
|
|
Player(..), playMatch, playMatches, RandomPlayer(..),
|
|
LearningPlayer, learnedPlayer, playHuman, 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 (chunksOf)
|
|
import Data.Ord (comparing)
|
|
import System.Environment (getArgs)
|
|
import System.IO (hSetBuffering, stdin, stdout, BufferMode(..))
|
|
import System.Random (Random, StdGen, randomR, newStdGen, split)
|
|
import Text.Printf (printf)
|
|
|
|
-- Randomness setup
|
|
|
|
type RandomState = State StdGen
|
|
|
|
getRandomR :: Random a => (a, a) -> RandomState a
|
|
getRandomR limits = do
|
|
gen <- get
|
|
let (val, gen') = randomR limits gen
|
|
put gen'
|
|
return val
|
|
|
|
randomChoose :: [a] -> RandomState a
|
|
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)
|
|
|
|
data CellState = Filled Move | Empty deriving (Eq, Ord)
|
|
|
|
data Cell = Cell { cellPos :: Int, cellState :: CellState } deriving (Eq, Ord)
|
|
|
|
data Board = Board { boardSize :: Int, boardCells :: [Cell] } deriving (Eq, Ord)
|
|
|
|
type Run = [Board]
|
|
|
|
data Result = Win | Loss | Draw | Unfinished deriving (Eq, Show)
|
|
|
|
instance Show Move where
|
|
show Nought = "O"
|
|
show Cross = "X"
|
|
|
|
instance Show CellState where
|
|
show (Filled move) = show move
|
|
show Empty = "~"
|
|
|
|
instance Show Cell where
|
|
show c = show $ cellState c
|
|
|
|
otherMove :: Move -> Move
|
|
otherMove Nought = Cross
|
|
otherMove Cross = Nought
|
|
|
|
otherResult :: Result -> Result
|
|
otherResult Draw = Draw
|
|
otherResult Loss = Win
|
|
otherResult Win = Loss
|
|
|
|
emptyBoard :: Int -> Board
|
|
emptyBoard boardSize =
|
|
Board boardSize $ map (flip Cell Empty) [0..(boardSize * boardSize - 1)]
|
|
|
|
printBoard :: Board -> IO ()
|
|
printBoard Board{..} = putStrLn "" >> (mapM_ print . chunksOf boardSize $ boardCells)
|
|
|
|
makeMove :: Int -> Move -> Board -> Board
|
|
makeMove pos move board@Board{..} =
|
|
let (l, r) = splitAt pos boardCells
|
|
in board { boardCells = l ++ [Cell pos (Filled move)] ++ tail r }
|
|
|
|
diags :: Board -> [[Cell]]
|
|
diags Board{..} =
|
|
[map (boardCells !!) . take boardSize . iterate (+ (boardSize + 1)) $ 0,
|
|
map (boardCells !!) . take boardSize . iterate (+ (boardSize - 1)) $ (boardSize - 1)]
|
|
|
|
nextBoards :: Move -> Board -> [(Int, Board)]
|
|
nextBoards move board@Board{..} =
|
|
map ((\p -> (p, makeMove p move board)) . cellPos)
|
|
$ filter (\c -> cellState c == Empty) boardCells
|
|
|
|
isWin :: Move -> Board -> Bool
|
|
isWin move board =
|
|
or [any isStrike . chunksOf size . map cellState . boardCells $ board,
|
|
any isStrike . chunksOf size . map cellState . boardCells . rotateBoard $ board,
|
|
any isStrike . map (map cellState) . diags $ board]
|
|
where
|
|
size = boardSize board
|
|
isStrike = (== replicate size (Filled move))
|
|
|
|
result :: Move -> Board -> Result
|
|
result move board
|
|
| isWin move board = Win
|
|
| isWin (otherMove move) board = Loss
|
|
| Empty `elem` (map cellState . boardCells $ board) = Unfinished
|
|
| otherwise = Draw
|
|
|
|
translateBoard :: [Int] -> Board -> Board
|
|
translateBoard idxs board@Board{..} =
|
|
board { boardCells =
|
|
map (\(i, ri) -> Cell i . cellState $ boardCells !! ri)
|
|
$ zip [0..(boardSize * boardSize - 1)] idxs }
|
|
|
|
rotateBoard, xMirrorBoard, yMirrorBoard :: Board -> Board
|
|
rotateBoard board@Board{..} =
|
|
translateBoard
|
|
(let xs = reverse . chunksOf boardSize $ [0..(boardSize * boardSize - 1)]
|
|
in concatMap (\i -> map (!! i ) xs) [0..(boardSize - 1)])
|
|
board
|
|
xMirrorBoard board@Board{..} =
|
|
translateBoard
|
|
(concatMap reverse . chunksOf boardSize $ [0..(boardSize * boardSize - 1)]) board
|
|
yMirrorBoard board@Board{..} =
|
|
translateBoard
|
|
(concat . reverse . chunksOf boardSize $ [0..(boardSize * boardSize - 1)]) board
|
|
|
|
rotateBoardN :: Board -> Int -> Board
|
|
rotateBoardN board n = foldl (\b _ -> rotateBoard b) board [1..n]
|
|
|
|
-- Player setup
|
|
|
|
class Player a where
|
|
playerMove :: a -> Move
|
|
play :: a -> Board -> (a, Board)
|
|
improvePlayer :: a -> Result -> Run -> a
|
|
|
|
-- play a match between two players
|
|
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'
|
|
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 -> Int -> p1 -> p2
|
|
-> ([(Result, Run)],p1, p2)
|
|
playMatches boardSize times player1 player2 =
|
|
foldl (\(matches, p1, p2) _ ->
|
|
let
|
|
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''))
|
|
([], player1, player2) [1..times]
|
|
|
|
-- RandomPlayer setup
|
|
|
|
-- play randomly. choose a random move
|
|
randomPlay :: Move -> Board -> RandomState Board
|
|
randomPlay move board = randomChoose (map snd $ nextBoards move board)
|
|
|
|
data RandomPlayer = RandomPlayer Move StdGen deriving (Show)
|
|
|
|
instance Player RandomPlayer where
|
|
playerMove (RandomPlayer move _) = move
|
|
play (RandomPlayer move gen) board =
|
|
let
|
|
(board', gen') = runState (randomPlay move board) gen
|
|
in (RandomPlayer move gen', board')
|
|
improvePlayer player _ _ = player
|
|
|
|
-- LearningPlayer setup
|
|
|
|
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
|
|
|
|
-- play using the strategy learned till now
|
|
learningPlay :: LearningPlayer -> Board -> (LearningPlayer, Board)
|
|
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')
|
|
|
|
calcScore :: (Int, Int, Int) -> Double
|
|
calcScore (w, l, d) = fromIntegral w + fromIntegral d * 0.5 - fromIntegral l
|
|
|
|
-- 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
|
|
in mem'
|
|
where
|
|
incrementScore res (w, l, d) =
|
|
case res of
|
|
Win -> (w + 1, l, d)
|
|
Loss -> (w, l + 1, d)
|
|
Draw -> (w, l, d + 1)
|
|
|
|
instance Player LearningPlayer where
|
|
playerMove (LearningPlayer move _ _) = move
|
|
play = learningPlay
|
|
improvePlayer (LearningPlayer move mem gen) res run =
|
|
LearningPlayer move (learnFromRun res run mem) gen
|
|
|
|
-- play two LearningPlayers against each other to learn strategy
|
|
learnedPlayer :: Int -> Int -> Move -> StdGen -> LearningPlayer
|
|
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 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@Board{..} = do
|
|
printBoard board
|
|
let boardArea = boardSize * boardSize
|
|
case result (playerMove player) board of
|
|
Unfinished -> do
|
|
putStr $ printf "Move %s? [1-%s] "
|
|
(show . otherMove . playerMove $ player) (show boardArea)
|
|
pos <- fmap (decr . read) getLine
|
|
if pos < 0 || pos > (boardArea - 1)
|
|
then do
|
|
putStrLn "Invalid Move"
|
|
playHuman player board
|
|
else
|
|
case cellState (boardCells !! pos) of
|
|
Filled _ -> do
|
|
putStrLn "Invalid Move"
|
|
playHuman player board
|
|
Empty -> let
|
|
board' = makeMove pos Nought board
|
|
in case result (playerMove player) board' of
|
|
Unfinished -> let
|
|
(player', board'') = play player board'
|
|
in playHuman player' board''
|
|
res -> do
|
|
printBoard board'
|
|
putStrLn ("Your " ++ show (otherResult res))
|
|
res -> putStrLn ("Your " ++ show (otherResult res))
|
|
where decr x = x - 1
|
|
|
|
main :: IO ()
|
|
main = do
|
|
(boardSize : times : _) <- fmap (map read) getArgs
|
|
hSetBuffering stdin LineBuffering
|
|
hSetBuffering stdout NoBuffering
|
|
gen <- newStdGen
|
|
putStrLn "Learning ..."
|
|
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 startBoard
|
|
else do
|
|
putStrLn "You lose toss"
|
|
let (player', board) = play player startBoard
|
|
playHuman player' board
|