After reviewing many Tic-Tac-Toe implementations, I decided to write my own. Here it is:
module Logic ( Symbol(..) , Space , Board , Position , GameResult(..) , GameState , placeSymbolAt , isFree , gameResult , initialState , makeTurn ) where import Data.Maybe (isNothing, isJust) import Data.List (find, transpose) import Control.Monad (join, foldM, (>=>)) data Symbol = X | O deriving (Show, Eq) type Space = Maybe Symbol type Board = [[Space]] -- 3x3 type Position = (Int, Int) -- row,column data GameResult = Won Symbol | Tie deriving (Show) -- modify a list by applying a function on the nth element mapAt :: Int -> (a -> a) -> [a] -> [a] mapAt pos f list = zipWith compute [0..] list where compute i x | i == pos = f x | otherwise = x -- set nth element of a list setAt :: Int -> a -> [a] -> [a] setAt pos x = mapAt pos (const x) placeSymbolAt :: Position -> Symbol -> Board -> Board placeSymbolAt (y,x) sym = mapAt y (setAt x (Just sym)) at :: Position -> Board -> Space at (y,x) board = board !! y !! x isFree :: Position -> Board -> Bool isFree pos = isNothing . at pos isFull :: Board -> Bool isFull = all (all isJust) sequences :: Board -> [[Space]] sequences board = rows ++ column ++ [mainDiagonal, secondaryDiagonal] where rows = board column = transpose board mainDiagonal = [at (x,x) board | x <- [0..2]] secondaryDiagonal = [at (x,2-x) board | x <- [0..2]] -- if sequence spaces are all Just sym, then Just sym. Otherwise, Nothing. winnerOfSequence :: [Space] -> Maybe Symbol winnerOfSequence = symbols >=> single where symbols = sequence :: [Space] -> Maybe [Symbol] single = foldM1 merge :: [Symbol] -> Maybe Symbol foldM1 f (x:xs) = foldM f x xs merge x y | x == y = Just x | otherwise = Nothing winner :: Board -> Maybe Symbol winner = findJust . map winnerOfSequence . sequences where findJust = join . find isJust :: [Maybe Symbol] -> Maybe Symbol gameResult :: Board -> Maybe GameResult gameResult board = case (winner board, isFull board) of (Just x, _) -> Just $ Won x (Nothing, True) -> Just Tie (Nothing, False) -> Nothing type GameState = (Symbol, Board) -- current player, board initialState :: GameState initialState = (X, emptyBoard) where emptyBoard = replicate 3 $ replicate 3 Nothing makeTurn :: Position -> GameState -> GameState makeTurn pos (player, board) = (next player, placeSymbolAt pos player board) where next X = O next O = X
module Main where import System.IO (hFlush, stdout) import Control.Exception (catch) import Control.Monad(guard) import Logic -- the spaces are numbered 1-9 in the interface spaceNumber :: Position -> Int spaceNumber (y,x) = 3*y + x + 1 position :: Int -> Maybe Position position n = do guard $ 1 <= n && n <= 9 return $ (n - 1) `divMod` 3 boardString :: Board -> String boardString board = concat rows where rows = zipWith rowString [0..2] board rowString y row = surround "\n" $ concat $ spaces y row spaces y row = zipWith (spaceString y) [0..2] row spaceString y x space = surround " " $ cellString (y,x) space cellString (y,x) space = case space of Nothing -> show (spaceNumber (y,x)) (Just sym) -> show sym surround xs str = xs ++ str ++ xs -- read position, checking it's valid and available tryReadPosition :: Board -> IO (Maybe Position) tryReadPosition board = (freePosition <$> readLn) `catch` returnNothing where freePosition n = do pos <- position n if isFree pos board then Just pos else Nothing returnNothing = (const $ return Nothing) :: IOError -> IO (Maybe Position) -- repeatedly show prompt and try to get valid input, until successful prompt :: String -> IO (Maybe a) -> IO a prompt message action = do putStr message >> hFlush stdout result <- action case result of (Just x) -> return x Nothing -> prompt message action promptPosition :: GameState -> IO Position promptPosition (player, board) = prompt ("Player " ++ show player ++ "'s turn: ") $ tryReadPosition board doTurn :: GameState -> IO GameState doTurn state = do pos <- promptPosition state return $ makeTurn pos state resultString :: GameResult -> String resultString (Won player) = "Player " ++ show player ++ " is the winner!" resultString Tie = "It's a tie!" playGame :: IO () playGame = playGame' initialState where playGame' state@(player, board) = do putStrLn $ boardString board let result = gameResult board in case result of (Just r) -> putStrLn $ resultString r Nothing -> doTurn state >>= playGame' promptPlayAgain :: IO Bool promptPlayAgain = prompt "Play again (y/n)? " (yesOrNo <$> getLine) where yesOrNo "y" = Just True yesOrNo "n" = Just False yesOrNo _ = Nothing main :: IO () main = do putStrLn "Welcome to Tic Tac Toe" playGame putStrLn "" again <- promptPlayAgain if again then main else putStrLn "Bye!"
- How can I make the code more idiomatic or otherwise improve it?
- How's my indentation?
- What do you think of the naming?