Alen Ribic - builder, tech entrepreneur, math & physics major

Haskell: an attempt at tic-tac-toe

by Alen Ribic on July 8, 2012

Here is a quick tic-tac-toe game I wrote in Haskell this weekend and I’m pretty pleased with my first attempt.

Two key things stuck out for me during the development process:

The ability to interactively test the functional expressions in GHCi and,
the clear separation between the pure functions and the IO monadic actions.

I started off firstly defining the data structures to represent the game elements such as the board, move and position.

data Move        = O | X 
                 deriving (Eq, Show, Enum, Ord)
type Position    = (Char, Int)
data BoardMove   = BoardMove 
                   { bMove :: Maybe Move, bPos :: Position } 
                 deriving (Eq, Show)
type Board       = [BoardMove]
type InvalidMove = String

Next, the main function will initiate the gameloop with a new empty board.

main = do
  putStrLn "Starting new game..."
  putStrLn "Type 'quit' to exit game"
  let newBoard = empty bsize
      in do (putStrLn . (\s->"\n"++s++"\n") . printBoard) newBoard
            gameloop Nothing newBoard

The empty function initializes the new game board based on the input size.

bsize = 3
coord = (['A'..], [1..])

empty :: Int -> Board
empty size = do
    x <- take size (fst coord)
    y <- take size (snd coord)
    return $ BoardMove Nothing (x,y)

This is the part I really love about the List implementation of the Monad class. Note how the Board (BoardMove list synonym) is produced monadically by taking the tuple pairs from the coordinates and producing a Cartesian product.

The beautiful thing is how the lazy evaluation plays a role [1] here in giving us just the number of coordinates we need based on the board size.

Next, we have a few functions for: making a move on the board, checking if there is a winner or if the game is a draw.

The move function is responsible for playing the next move on the board, resulting in either an invalid move or a board with the newly added move.

move :: BoardMove -> Board -> Either InvalidMove Board
move (BoardMove _ (c,r)) [] = 
  Left $ "Could not make the move to given position " ++ [c] ++ (show r)
move bm@(BoardMove nmov npos) (x:xs) 
  | findMove x = Right $ bm:xs
  | otherwise  = 
    case move bm xs of
      Right r -> Right $ x:r
      err     -> err
  where findMove (BoardMove m p) = 
          p == npos && isNothing m && nmov /= Nothing

The win and draw functions are simply predicate functions for determining if there is a winner or if the game resulted in a draw.

win :: BoardMove -> Board -> Bool
win (BoardMove Nothing _) _ = False
win (BoardMove m (c,r)) b = row || col || diag' cb || diag' (reverse cb)
  where row = length 
              (filter (\(BoardMove m2 (_,r2)) -> 
                        m2 == m && r2 == r) b) == bsize
        col = length
              (filter (\(BoardMove m2 (c2,_)) -> 
                        m2 == m && c2 == c) b) == bsize
        diag' xss = all (\(BoardMove m2 _) -> 
                          m2 == m) $ diag xss
        cb = chop bsize b

draw :: BoardMove -> Board -> Bool
draw bm b = not (any (isNothing . bMove) b)
         && not (win bm b)

Finally, we have the gameloop that ties all the game bits together including the user IO actions.

gameloop prevMove board = do
  let currPlayer = maybe X (\(BoardMove mv _) -> 
                               case mv of
                                 Just X -> O
                                 Just O -> X) prevMove
  putStr $ "Player '" ++ (show currPlayer) ++ "': "
  hFlush stdout
  playerMove <- getLine
  case (playerMove, (map toUpper playerMove) `elem` allCoord) of
    ("quit", _) ->
        putStrLn "Goodbye!"
    (_, False)  -> do
        putStrLn $ "Possible options: " ++ intercalate ", " allCoord
        gameloop prevMove board
    otherwise   -> do
        let pos = (toUpper $ playerMove !! 0, 
                   read [(playerMove !! 1)] :: Int)
            currMove = BoardMove (Just currPlayer) pos
            currBoard = move currMove board
        either putStrLn (putStrLn . (\s->"\n"++s++"\n") . printBoard) currBoard
    case currBoard of
          Right r  -> if win currMove r
                        then do putStrLn $ "Player '"
                                           ++ (show currPlayer) ++"' wins!"
                                main
                        else if draw currMove r
                                then do putStrLn $ "It's a draw!"
                                        main
                                else gameloop (Just currMove) r
          Left err -> gameloop prevMove board
  where allCoord = [[x] ++ show y | x <- take bsize (fst coord), 
                                    y <- take bsize (snd coord)]

For questions and feedback, you can drop me an email or a tweet.

Full source: GitHub link.

[1] Why Functional Programming Matters - http://www.cse.chalmers.se/~rjmh/Papers/whyfp.html