Tic Tac Toe

tictactoe.hs

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}

-- | Tic Tac Toe
module Main where

import           Control.Monad.IO.Class                   ( MonadIO
                                                          , liftIO
                                                          )
import           Control.Monad.State.Strict               ( StateT
                                                          , MonadState
                                                          , runStateT
                                                          , get
                                                          , gets
                                                          , put
                                                          )
import           Data.Maybe                               ( fromMaybe )
import           Data.Vector                              ( Vector(..)
                                                          , (!)
                                                          , (//)
                                                          )
import qualified Data.Vector                   as V
import           Text.Read                                ( readMaybe )

data Player = Circle | Cross | None deriving Eq

instance Show Player where
  show Circle = "O"
  show Cross  = "X"
  show None   = "."

newtype Row = Row { unRow :: Vector Player }

instance Show Row where
  show (Row w) = unwords $ show <$> V.toList w

newtype Board = Board { unBoard :: Vector Row }

instance Show Board where
  show (Board v) = unlines $ show <$> V.toList v

newtype App a =
  App { unApp :: StateT Board IO a }
  deriving
    ( Functor
    , Applicative
    , Monad
    , MonadIO
    , MonadState Board
    )

runApp :: Board -> App a -> IO (a, Board)
runApp b = flip runStateT b . unApp

mkBoard :: Int -> Board
mkBoard s = Board $ V.replicate s $ Row $ V.replicate s None

getPlayer :: Board -> Int -> Int -> Maybe Player
getPlayer (Board v) r c = if r < s && c < s
  then let (Row w) = v ! r in Just $ w ! c
  else Nothing
  where s = V.length v

countPlays :: Board -> Int
countPlays (Board v) = V.sum $ V.length . V.filter (/= None) . unRow <$> v

whoseTurn :: Board -> Player
whoseTurn b | odd x     = Circle
            | otherwise = Cross
  where x = countPlays b

transposeBoard :: Board -> Board
transposeBoard b@(Board v) = Board $ transposeRow <$> V.fromList [0 .. s - 1]
 where
  s = V.length v
  transposeCell r c = fromMaybe None $ getPlayer b c r
  transposeRow r = Row $ transposeCell r <$> V.fromList [0 .. s - 1]

playerWon :: Player -> Board -> Bool
playerWon p b =
  horizontalWin p b || diagonalWin p b || horizontalWin p b' || diagonalWin p b'
  where b' = transposeBoard b

horizontalWin :: Player -> Board -> Bool
horizontalWin p (Board v) = V.any (\(Row row) -> V.all (== p) row) v

diagonalWin :: Player -> Board -> Bool
diagonalWin p board@(Board v) =
  all (== Just p) $ (\x -> getPlayer board x x) <$> [0 .. size - 1]
  where size = V.length v

isTied :: Board -> Bool
isTied (Board v) = V.all (\(Row row) -> V.all (/= None) row) v

readBoundedInt :: MonadIO m => String -> Int -> Int -> m Int
readBoundedInt label min max = do
  liftIO $ putStr label
  l <- liftIO getLine
  case readMaybe l of
    Just i -> if i >= min && i <= max
      then return i
      else do
        liftIO $ putStrLn $ "Min " <> show min <> ", max " <> show max <> "."
        readBoundedInt label min max
    Nothing -> readBoundedInt label min max

readSize :: MonadIO m => m Int
readSize = readBoundedInt "Board size: " 2 5

putPlay :: MonadState Board m => Int -> Int -> Player -> m ()
putPlay r c p = do
  (Board v) <- get
  let (Row w) = v ! r
      w'      = Row $ w // [(c, p)]
  put $ Board $ v // [(r, w')]

readPos :: (MonadIO m, MonadState Board m) => m (Int, Int)
readPos = do
  size <- gets $ V.length . unBoard
  r    <- readBoundedInt "Row: " 1 size
  c    <- readBoundedInt "Column: " 1 size
  return (r - 1, c - 1)

play :: (MonadIO m, MonadState Board m) => Player -> m ()
play p = do
  board  <- get
  (r, c) <- readPos
  case getPlayer board r c of
    Just None -> putPlay r c p
    _         -> do
      liftIO $ putStrLn "Cell must be empty."
      play p

printBoard :: (MonadIO m, MonadState Board m) => m ()
printBoard = get >>= liftIO . print

turn :: (MonadIO m, MonadState Board m) => m (Maybe Player)
turn = do
  p <- gets whoseTurn
  printBoard
  liftIO $ putStrLn $ "Player " <> show p
  play p
  won <- gets $ playerWon p
  if won
    then return $ Just p
    else do
      tied <- gets isTied
      return $ if tied then Just p else Nothing

loop :: App Player
loop = turn >>= \case
  Just p  -> printBoard >> return p
  Nothing -> loop

main :: IO ()
main = do
  size        <- readSize
  (result, _) <- runApp (mkBoard size) loop
  putStrLn $ case result of
    None -> "It's a tie!"
    p    -> show p <> " won."