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

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.