# Tic Tac Toe in Haskell

After reviewing many Tic-Tac-Toe implementations, I decided to write my own. Here it is:

## Logic.hs

module Logic
( Symbol(..)
, Space
, Board
, Position
, GameResult(..)
, GameState
, placeSymbolAt
, isFree
, gameResult
, initialState
, makeTurn
) where

import Data.Maybe (isNothing, isJust)
import Data.List (find, transpose)

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


## Main.hs

module Main where

import System.IO (hFlush, stdout)
import Control.Exception (catch)
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: ")$

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!"


Run with:

runhaskell Main.hs

• How can I make the code more idiomatic or otherwise improve it?
• How's my indentation?
• What do you think of the naming?