Tic-tac-toe in Haskell

TicTacToe.hs

module TicTacToe where

import           Control.Monad.State
import           Data.Char
import           Data.List
import qualified Data.Map            as Map
import           Data.Maybe
import qualified System.Process      as Process

-- Cell

data Cell = X | O deriving (Eq, Ord)

-- Coord

data Coord =
    C11
  | C12
  | C13
  | C21
  | C22
  | C23
  | C31
  | C32
  | C33 deriving (Eq, Ord)

nextCoord :: Coord -> Coord
nextCoord C11 = C12
nextCoord C12 = C13
nextCoord C13 = C21
nextCoord C21 = C22
nextCoord C22 = C23
nextCoord C23 = C31
nextCoord C31 = C32
nextCoord C32 = C33
nextCoord C33 = C11

nextCoordToEmpty :: Grid -> Coord -> Coord
nextCoordToEmpty grid coord =
  let
    next = nextCoord coord
  in
  case Map.lookup next grid of
    Just _ ->
      nextCoordToEmpty grid next

    Nothing ->
      next

-- Grid

type Grid = Map.Map Coord Cell

initGrid :: Grid
initGrid = Map.empty

isGridFull :: Grid -> Bool
isGridFull = (==) 9 . Map.size

-- Game state

data Game =
  Game
    { grid   :: Grid
    , cursor :: Coord
    }

initGame :: Game
initGame = Game initGrid C11

winner :: Grid -> Maybe (Maybe Cell)
winner grid =
  case (winnerHelper winningCellCombinations grid, isGridFull grid) of
    (Just mark, _) ->
      Just (Just mark)
    (Nothing, True) ->
      Just Nothing
    _ ->
      Nothing

winnerHelper :: [[Coord]] -> Grid -> Maybe Cell
winnerHelper [] _ = Nothing
winnerHelper (head:tail) grid = maybe (winnerHelper tail grid) id $ extractIfAllIdentical $ fmap (flip Map.lookup $ grid) $ head

winningCellCombinations :: [[Coord]]
winningCellCombinations =
  [ -- rows
    [ C11, C12, C13 ]
  , [ C21, C22, C23 ]
  , [ C31, C32, C33 ]
    -- columns
  , [ C11, C21, C31 ]
  , [ C12, C22, C32 ]
  , [ C13, C23, C33 ]
    -- diagonals
  , [ C11, C22, C33 ]
  , [ C31, C22, C13 ]
  ]

-- Update game

data Msg = Mark | Move

updateGame :: Msg -> Game -> Game
updateGame msg (Game grid cursor) =
  case msg of
    Mark ->
      let
        newGrid = (Map.insert cursor (currentMark grid) grid)
      in
      Game newGrid (nextCoordToEmpty newGrid cursor)
    Move ->
      Game grid (nextCoordToEmpty grid cursor)

currentMark :: Grid -> Cell
currentMark grid =
  case rem (Map.size grid) 2 of
    0 -> X
    _ -> O

winnerText :: Maybe (Maybe Cell) -> String
winnerText cell =
  case cell of
    Just (Just X) -> "X wins"
    Just (Just O) -> "O wins"
    Just Nothing  -> "Tie"
    Nothing       -> "Game is on"

-- View

viewGame :: Game -> String
viewGame (Game grid cursor) =
  foldl (++) ""
  . intersperse "\n"
  . fmap (foldl (++) "" . fmap (viewCell cursor grid))
  $ [
      [ C11, C12, C13 ],
      [ C21, C22, C23 ],
      [ C31, C32, C33 ]
    ]

viewCell :: Coord -> Grid -> Coord -> String
viewCell cursor grid coord =
  case (cursor == coord, Map.lookup coord grid) of
      (True, _)        -> "[*]"
      (False, Just X)  -> "[X]"
      (False, Just O)  -> "[O]"
      (False, Nothing) -> "[ ]"

-- Entry point

main :: IO ()
main =
  mainWithState initGame

mainWithState :: Game -> IO ()
mainWithState game = do
  Process.system "clear"
  winner <- return $ winner (grid game)
  putStrLn $ padText 2 $ foldl (++) "" $ intersperse "\n" $
    [ "Tic Tac Toe"
    , ""
    , winnerText winner
    , ""
    , padText 2 $ viewGame game
    , ""
    , "[space+enter] - draw mark"
    , "[m+enter] - move cursor"
    , "[x+enter] - exit"
    , "[r+enter] - new game"
    ]
  guess <- getChar
  case (winner, guess) of
    (Just _, 'r')  -> mainWithState initGame
    (Nothing, ' ') -> mainWithState (updateGame Mark game)
    (Nothing, 'm') -> mainWithState (updateGame Move game)
    (_, 'x')       -> return ()
    _              -> mainWithState game

-- Helpers

extractIfAllIdentical :: (Eq a) => [a] -> Maybe a
extractIfAllIdentical = extractIfAllIdenticalHelper Nothing

extractIfAllIdenticalHelper :: (Eq a) => Maybe a -> [a] -> Maybe a
extractIfAllIdenticalHelper res [] = res
extractIfAllIdenticalHelper res (head:tail) =
  case res of
    Just val ->
      if val == head then extractIfAllIdenticalHelper res tail else Nothing
    Nothing ->
      extractIfAllIdenticalHelper (Just head) tail

padText :: Int -> String -> String
padText colPad =
  foldl (++) ""
  . intersperse "\n"
  . fmap (\line -> replicate colPad ' ' ++ line)
  . lines