OpticalTicTacToe.hs

{-# LANGUAGE RankNTypes #-}

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

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)
type Position = Traversal' Board Cell

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

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

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

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 -> Position
parsePosition '1' = _1
parsePosition '2' = _2
parsePosition '3' = _3
parsePosition '4' = _4
parsePosition '5' = _5
parsePosition '6' = _6
parsePosition '7' = _7
parsePosition '8' = _8
parsePosition '9' = _9
parsePosition _ = ignored

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

playTurn :: Game -> Position -> Game
playTurn (board, mark) position =
    maybe
        (board, mark)
        (flip (,) $ nextMark mark)
        (board ^? position >> maybe (Just $ Just mark) (const Nothing) `position` board)

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