TicTacToe.hs

import System.IO
import System.Console.ANSI
import Control.Monad.Loops
import Data.Maybe
import Data.Foldable (all)

data Mark = X | O deriving (Eq, Show)
data Status = InProgress | Won | Drawn

type Cell = Maybe Mark
type Board =
    ( Cell, Cell, Cell
    , Cell, Cell, Cell
    , Cell, Cell, Cell
    )
type Game = (Board, Mark)

main :: IO Game
main =
    getCursorPosition
        >>= \cursor ->
            let cursor' = fromMaybe (0, 1) cursor
            in displayGame cursor' initialGame
                 >> iterateUntilM (gameOver . gameStatus . fst) (step cursor') initialGame

getInput :: IO Char
getInput =
    hSetEcho stdin False >> hSetBuffering stdin NoBuffering >> getChar

step :: (Int,Int) -> Game -> IO Game
step cursor game =
    getInput >>= displayGame cursor . playTurn game . parsePosition

displayGame :: (Int,Int) -> Game -> IO Game
displayGame (y, x) game =
    setCursorPosition y (x - 1) >> putStr (printGame game) >> return game

initialGame :: Game
initialGame =
    ((Nothing,Nothing,Nothing,Nothing,Nothing,Nothing,Nothing,Nothing,Nothing),X)

parsePosition :: Char -> Maybe Int
parsePosition '1' = Just 1
parsePosition '2' = Just 2
parsePosition '3' = Just 3
parsePosition '4' = Just 4
parsePosition '5' = Just 5
parsePosition '6' = Just 6
parsePosition '7' = Just 7
parsePosition '8' = Just 8
parsePosition '9' = Just 9
parsePosition _ = Nothing

nextMark :: Mark -> Mark
nextMark X = O
nextMark O = X

printStatus :: Mark -> Status -> String
printStatus mark Won = show (nextMark mark) ++ " won!"
printStatus _ Drawn = "Its a draw!"
printStatus mark InProgress = show mark ++ "'s turn."

printGame :: Game -> String
printGame (board, mark) =
       "Press one of the keys listed below to play at that position:\n\n"
    ++ printBoard board ++ "\n\n"
    ++ printStatus mark (gameStatus board) ++ "   \n"

printBoard :: Board -> String
printBoard (a,b,c,d,e,f,g,h,i) =
       " " ++ printCell "1" a ++ " | " ++ printCell "2" b ++ " | " ++ printCell "3" c ++ " \n"
    ++ "---+---+---\n"
    ++ " " ++ printCell "4" d ++ " | " ++ printCell "5" e ++ " | " ++ printCell "6" f ++ " \n"
    ++ "---+---+---\n"
    ++ " " ++ printCell "7" g ++ " | " ++ printCell "8" h ++ " | " ++ printCell "9" i

printCell :: String -> Cell -> String
printCell s =
  maybe s show

updateAtPosition :: (Cell -> Maybe Cell) -> Board -> Int -> Maybe Board
updateAtPosition update (a,b,c,d,e,f,g,h,i) 1 = (\up -> (up,b,c,d,e,f,g,h,i)) <$> update a
updateAtPosition update (a,b,c,d,e,f,g,h,i) 2 = (\up -> (a,up,c,d,e,f,g,h,i)) <$> update b
updateAtPosition update (a,b,c,d,e,f,g,h,i) 3 = (\up -> (a,b,up,d,e,f,g,h,i)) <$> update c
updateAtPosition update (a,b,c,d,e,f,g,h,i) 4 = (\up -> (a,b,c,up,e,f,g,h,i)) <$> update d
updateAtPosition update (a,b,c,d,e,f,g,h,i) 5 = (\up -> (a,b,c,d,up,f,g,h,i)) <$> update e
updateAtPosition update (a,b,c,d,e,f,g,h,i) 6 = (\up -> (a,b,c,d,e,up,g,h,i)) <$> update f
updateAtPosition update (a,b,c,d,e,f,g,h,i) 7 = (\up -> (a,b,c,d,e,f,up,h,i)) <$> update g
updateAtPosition update (a,b,c,d,e,f,g,h,i) 8 = (\up -> (a,b,c,d,e,f,g,up,i)) <$> update h
updateAtPosition update (a,b,c,d,e,f,g,h,i) 9 = (\up -> (a,b,c,d,e,f,g,h,up)) <$> update i
updateAtPosition update board _ = Nothing

playTurn :: Game -> Maybe Int -> Game
playTurn (board, mark) =
    maybe
        (board, mark)
        (\position ->
             maybe
                 (board, mark)
                 (\updatedBoard -> (_, nextMark mark))
                 (updateAtPosition
                      (fmap Just . maybe (Just mark) (const Nothing))
                      board
                      position))

gameOver :: Status -> Bool
gameOver InProgress = False
gameOver Won = True
gameOver Drawn = True

gameStatus :: Board -> Status
gameStatus (a,b,c,d,e,f,g,h,i) =
  if (a == b && b == c && isJust a)
     || (d == e && e == f && isJust d)
     || (g == h && h == i && isJust g)
     || (a == d && d == g && isJust a)
     || (b == e && e == h && isJust b)
     || (c == f && f == i && isJust c)
     || (a == e && e == i && isJust a)
     || (c == e && e == g && isJust c)
  then Won
  else if all isJust [a,b,c,d,e,f,g,h,i] then Drawn
  else InProgress