Tic Tac Toe (Haskell)

Question

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

• Roman Susi: One observation is that you are using Maybe a lot, but do only for IO. I wonder if the whole winner-checking can be done in one do without heavy handling of nested lists... (this is not an advice, as I am not sure it is really better).

Answer 1

Once again your code is very good, most of what I've got is just dotting ıs and crossing ɭ s so I'll probably end up showing off cool stuff more than providing critical feedback.

I'd define Winner as Winner Player | CatScratch, you've already got a perfectly good X and O already.

I'd also graduate up to using a full-fledged Array for the boards, they're super tiny and not appreciably less efficient than lists, especially for a 3x3 grid. And the affordances a nice API gives you... hoo, good stuff.

type Coordinate = (Int, Int)
type Board = Array Coordinate (Maybe Player)
emptyBoard :: Board
emptyBoard = listArray ((0, 0), (2, 2)) $ repeat Nothing
placeInBoard :: Coordinate -> Player -> Board -> Board
placeInBoard coord player board = board // [(coord, player)]

You can add any error checking you'd like also, maybe you'd have the function return an Either TicTacTerror Board with a custom error type that tells you whether it's a data TicTacTerror = CoordinateOutOfBounds | CoordinateOccupied. Or you could, y'know, use a String. That's cool too I guess, even if I don't get to make a pun... In general I think it's better to try an operation and then fail gracefully, rather than to validate and then attempt the operation. That's more commonly something said about parsing in Haskell, but it's also important for e.g., concurrent contexts. It's a good habit.

The terse row, column and diagonal checking is a loss, but you can approximate it without overly much effort.

rows :: (Ix i, Ix j) => Array (i, j) e -> [[e]]
rows = map (snd . unzip) . groupBy ((==) `on` (\((x, _y), _e) -> x)) . assocs
transpose :: (Ix i, Ix j) => Array (i, j) e -> Array (j, i) e
transpose arr = ixmap (bimap swap swap $ bounds arr) swap arr
columns :: (Ix i, Ix j) => Array (i, j) e -> [[e]]
columns = rows . transpose
diagonal :: (Ix i, Ix j) => Array (i, j) e -> [e]
diagonal arr = [arr ! ix | ix <- zip (range (i0, iN)) (range (j0, jN))]
 where ((i0, j0), (iN, jN)) = bounds arr
mirror :: (Ix i, Ix j, Enum i, Enum j) => Array (i, j) e -> Array (i, j) e
mirror arr = ixmap (bounds arr) dirtyReflection arr
 where
 ((i0, _), (iN, _)) = bounds arr
 dirtyReflection (i, j) = (fromJust $ lookup i table, j)
 where table = zip (range (i0, iN)) (reverse $ range (i0, iN))
ticTacToes :: Board -> [[Maybe Player]]
ticTacToes board = rows board ++ columns board ++ [diagonal board, diagonal $ mirror board]

Here's the first version I hacked together, in case it might be illustrative of my process. (Hidden because one doesn't air one's dirty laundry in public.)

toeLines :: Board -> [[Maybe Player]]
toeLines board = rows board ++ columns board ++ [diagonal board, diagonal $ mirror board]
 where
 bnds@((x0, _y0), (_xN, yN)) = bounds board
 rows = map (map snd) . groupBy ((==) on (fst . fst)) . assocs
 transpose a = ixmap (bounds a) swap a
 diagonal a = [a ! (i, i) | i <- [x0 .. yN]]
 reverseDiagonal a = [a ! (i, j) | (i, j) <- indices a, i + j == x0 + yN]

Now you can golf down the win-checking a bit. The change to the Winner datatype I made earlier comes into play, you're going to have to add some deriving clauses (and imports, for that matter) that I've just glossed over. If you can't find where something comes from, try Hoogle.

allSame :: Eq a => [a] -> Bool
allSame [] = False
allSame (x:xs) = all (x ==) xs
assessLine :: [Maybe Player] -> Maybe Player
assessLine line | Nothing `notElem` line && allSame line = join $ listToMaybe line
 | otherwise = Nothing
getWinner :: Board -> Maybe Winner
getWinner board = Winner <$> listToMaybe (mapMaybe assessLine (ticTacToes board))
 <|> if all isJust (elems board) then Just CatScratch else Nothing

And the original version—

getWinner :: Board -> Maybe Winner
getWinner board =
 let mWinner = Winner <$> find (\row@(x:_) -> all (== x) row && isJust x) (toeLines board)
 mCatScratch = if all isJust (elems board) then Just CatScratch else Nothing
 in mWinner <|> mCatScratch

This is a slight algorithmic improvement, but mostly it gets back to the "don’t validate a thing, do a thing" line I was on before.

The rest of the changes to your model code should be straightforward.

For your view code, after you've adapted it to the Array model it's best to just abandon gluing Strings together entirely and grab a pretty printer library, like "boxes". If you've never seen a pretty printing combinator library before, the general idea is to build a view for each kind of element you're displaying, then specify how you glue them together into larger elements, and eventually you have a function that takes your data structure and replaces all of the constructors with printing functions. I'm sure an example will help to make it clear.

player :: Maybe Player -> Box
player (Just X) = char 'X'
player (Just O) = char 'O'
player Nothing = char ' '
cell :: Maybe Player -> Box
cell = align center1 center1 3 3 . player
row :: [Maybe Player] -> Box
row players = punctuateH center1 vertBar $ map cell players
 where vertBar = vcat top $ replicate 3 (char '|')
board :: Board -> Box
board arr = punctuateV center1 horizBar $ map row (rows arr)
 where horizBar = hcat left $ replicate 9 (char '-')

Play around with it in the REPL and you'll see what's going on pretty quickly. There are tons of pretty printer libraries, pick your favorite.

As for your main module, it looks pretty good. You might want to explore building a TUI with "brick" as a next step. It has an even more expressive layout system, and a lot of fun challenges to cut your teeth on.

Some other random observances—

• Section operators like (++) inline, there's no need to prefix them. E.g. ([value] ++) is equivalent to (++) [value] and less indirect.
• You can make Player an instance of Random or the new Uniform to hide the indirection of going through another type.