5
\$\begingroup\$

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)
import Control.Monad (join, foldM, (>=>))

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 Control.Monad(guard)
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: ") $
  tryReadPosition board

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?
\$\endgroup\$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Browse other questions tagged or ask your own question.