I implemented tic-tac-toe in Haskell. I'm trying to incorporate suggestions from my last question (which mostly revolved around algorithmic logic) while trying something new - IO logic.
What kind of improvements could I make to this program? Am I being too tricky anywhere? Are there some built-in library functions that I could use to simplify the logic?
Model.hs
module Model (doTurn, getWinner, initialState, isVacant, State(..), Board, Player(..), Winner(..)) where
import Data.List (transpose)
import Safe (atMay)
import Data.Maybe (isJust, isNothing, catMaybes)
import Control.Monad (join)
data Player = X | O deriving (Eq)
data Winner = XWins | OWins | CatScratch
type Board = [[Maybe Player]]
data State = State
{
boardState :: Board,
turnState :: Player
}
opponentOf :: Player -> Player
opponentOf X = O
opponentOf O = X
diagonal :: [[a]] -> [a]
diagonal board =
catMaybes $ zipWith atMay board [0..]
replaceAt :: (a -> a) -> Int -> [a] -> [a]
replaceAt updateFn index array =
case splitAt index array of
(left, val:right) -> left ++ [updateFn val] ++ right
_ -> array
isVacant :: (Int, Int) -> Board -> Bool
isVacant (x, y) board =
isNothing $ join $ (`atMay` x) =<< (`atMay` y) board
placeInBoard :: (Int, Int) -> Maybe Player -> Board -> Board
placeInBoard (x, y) =
(`replaceAt` y) . (`replaceAt` x) . const
isPlayerWinner :: Player -> Board -> Bool
isPlayerWinner player board =
(any . all) (Just player ==) $
board ++
transpose board ++
map diagonal [board, transpose board]
isCatScratch :: Board -> Bool
isCatScratch =
(all . all) isJust
getWinner :: Board -> Maybe Winner
getWinner board
| isPlayerWinner X board = Just XWins
| isPlayerWinner O board = Just OWins
| isCatScratch board = Just CatScratch
| otherwise = Nothing
doTurn :: State -> (Int, Int) -> State
doTurn state coord =
State {
boardState = placeInBoard coord (Just $ turnState state) (boardState state),
turnState = opponentOf (turnState state)
}
initialState :: Player -> State
initialState firstPlayer =
State {
boardState = replicate 3 (replicate 3 Nothing),
turnState = firstPlayer
}
View.hs
module View (renderBoard, currentPlayerText, parseAsCoord, winnerText) where
import Data.List (intercalate, intersperse)
import Data.Char (toUpper)
import Model (Board, Player(X, O), Winner(XWins, OWins, CatScratch))
surround :: a -> [a] -> [a]
surround value array = [value] ++ intersperse value array ++ [value]
renderCell :: Maybe Player -> String
renderCell (Just X) = "X"
renderCell (Just O) = "O"
renderCell Nothing = " "
renderBoard :: Board -> String
renderBoard =
let
header = " A B C "
divider = " -----+-----+-----"
padding = " | | "
renderRow :: Int -> [Maybe Player] -> String
renderRow n = intercalate "" . (++) [show n] . surround " " . intersperse "|" . map renderCell
in
unlines . (++) [header] . surround padding . intersperse divider . zipWith renderRow [1..]
parseAsCoord :: String -> Maybe (Int, Int)
parseAsCoord [number, letter] =
let
maybeX = case toUpper letter of { 'A' -> Just 0; 'B' -> Just 1; 'C' -> Just 2; _ -> Nothing }
maybeY = case number of { '1' -> Just 0; '2' -> Just 1; '3' -> Just 2; _ -> Nothing }
in case (maybeX, maybeY) of
(Just x, Just y) -> Just (x, y)
_ -> Nothing
parseAsCoord _ = Nothing
currentPlayerText :: Player -> String
currentPlayerText X = "It's X's turn"
currentPlayerText O = "It's O's turn"
winnerText :: Winner -> String
winnerText XWins = "X Wins!"
winnerText OWins = "O Wins!"
winnerText CatScratch = "Cat Scratch!"
Main.hs
import System.IO (hFlush, stdout)
import System.Random (randomIO)
import Model (initialState, doTurn, getWinner, isVacant, Player(X, O), State(boardState, turnState))
import View (renderBoard, currentPlayerText, parseAsCoord, winnerText)
prompt :: String -> IO String
prompt msg = do
putStr msg >> hFlush stdout
getLine
promptForVacantCoord :: State -> IO (Int, Int)
promptForVacantCoord state = do
userInput <- prompt "Pick a spot (e.g. 2B): "
case parseAsCoord userInput of
Just coord | isVacant coord (boardState state) -> return coord
_ -> putStrLn "Invalid input" >> promptForVacantCoord state
step :: State -> IO ()
step state = do
putStrLn ""
putStrLn $ renderBoard $ boardState state
case getWinner (boardState state) of
Just winner -> putStrLn (winnerText winner)
Nothing -> do
putStrLn $ currentPlayerText (turnState state)
coord <- promptForVacantCoord state
step $ doTurn state coord
main :: IO ()
main =
let
playerFromBool True = X
playerFromBool False = O
in
step . initialState . playerFromBool =<< randomIO
do
only for IO. I wonder if the whole winner-checking can be done in onedo
without heavy handling of nested lists... (this is not an advice, as I am not sure it is really better). \$\endgroup\$