# Tic Tac Toe (Haskell)

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)

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  • 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). Apr 4 '21 at 18:15 ## 1 Answer 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.