tictactoe.hs

module Main where
import System.Environment
import Distribution.Simple.Utils (lowercase)
import qualified Data.Map.Strict as Map
import Data.List (intersperse, elem)
import Text.Read (readMaybe)

answer2Bool :: String -> Maybe Bool
answer2Bool "y"   = Just True
answer2Bool "yes" = Just True
answer2Bool "no"  = Just False
answer2Bool "n"   = Just False
answer2Bool _     = Nothing

main :: IO ()
main = do
  putStrLn "Start a game of tic-tac-toe? [y/n]"
  play <- (answer2Bool . lowercase) <$> getLine
  case play of
    Nothing    -> putStrLn "Invalid response." >> main
    Just False -> putStrLn "Exiting..."
    Just True  -> do
                      putStrLn "Starting new game..."
                      playGame
                      putStrLn "The game has ended."
                      main

data PlayerId = One | Two

data BoardPos = BoardPos (Int, Int)
  deriving (Eq, Ord)

data BoardState = BoardState {
  boardMap :: Map.Map BoardPos PlayerId
}

data GameState = GameState {
  boardState :: BoardState,
  whoseMove  :: PlayerId
  }

data Draw = Draw ()

data Winner = Winner (Maybe (Either PlayerId Draw))

otherPlayer :: PlayerId -> PlayerId
otherPlayer One = Two
otherPlayer Two = One

initBoard :: BoardState
initBoard = BoardState Map.empty 

initGame :: GameState
initGame = GameState initBoard One

posChar :: Maybe PlayerId -> Char
posChar (Just One) = 'o'
posChar (Just Two) = 'x'
posChar Nothing    = ' '

int2pos :: Int -> BoardPos
int2pos 1 = BoardPos (1, 1)
int2pos 2 = BoardPos (1, 2)
int2pos 3 = BoardPos (1, 3)
int2pos 4 = BoardPos (2, 1)
int2pos 5 = BoardPos (2, 2)
int2pos 6 = BoardPos (2, 3)
int2pos 7 = BoardPos (3, 1)
int2pos 8 = BoardPos (3, 2)
int2pos 9 = BoardPos (3, 3)

show :: BoardState -> String
show state = let boardLines = map (\i -> (map (posChar . (peek state)) [ BoardPos (i, 1), BoardPos (i, 2), BoardPos (i, 3)])) [1, 2, 3] in
               "|" ++ intersperse '|' (boardLines !! 0) ++ "|" ++ "\n"
            ++ "|" ++ intersperse '|' (boardLines !! 1) ++ "|" ++ "\n"
            ++ "|" ++ intersperse '|' (boardLines !! 2) ++ "|" ++ "\n"

peek :: BoardState -> BoardPos -> Maybe PlayerId
peek bs pos = let board = boardMap bs in
                   case Map.lookup pos board of
                     Just x  -> Just x
                     Nothing -> Nothing
  
move :: GameState -> BoardPos -> Maybe GameState
move gs pos = let player = whoseMove gs in
                let bs = boardState gs in
                   let board = boardMap bs in
                     case peek bs pos of
                       Just x  -> Nothing
                       Nothing -> Just (GameState (BoardState (Map.insert pos player board)) (otherPlayer player))

genSlices :: [[BoardPos]]
genSlices = (fmap . fmap) BoardPos [[(1, 1), (1, 2), (1, 3)],
                                    [(2, 1), (2, 2), (2, 3)],
                                    [(3, 1), (3, 2), (3, 3)],
                                    [(1, 1), (2, 1), (3, 1)],
                                    [(1, 2), (2, 2), (3, 2)],
                                    [(1, 3), (2, 3), (3, 3)],
                                    [(1, 1), (2, 2), (3, 3)],
                                    [(1, 3), (2, 2), (3, 1)]]

getSlice :: BoardState -> [BoardPos] -> [Char]
getSlice bs []         = ""
getSlice bs (pos : ps) = posChar (peek bs pos) : getSlice bs ps

sliceShowBoard :: BoardState -> [[Char]]
sliceShowBoard bs = (getSlice bs) <$> genSlices

checkFull :: BoardState -> Bool
-- checkFull bs = case sequence (map (\i -> peek bs (int2pos i)) [1..9]) of
checkFull bs = case sequence (map ((peek bs) . int2pos) [1..9]) of
                 Just x  -> True
                 Nothing -> False

checkWinner :: BoardState -> Winner
checkWinner bs = let full = checkFull bs in
                   let slices = sliceShowBoard bs in
                     if elem "ooo" slices
                     then Winner (Just (Left One))
                     else if elem "xxx" slices
                          then Winner (Just (Left Two))
                          else if full then
                                 Winner (Just (Right (Draw ())))
                               else
                                   Winner Nothing

playGame :: IO ()
playGame = do
  putStrLn "This is the game."
  let gs = initGame
  gameLoop gs
  return ()

gameLoop :: GameState -> IO GameState
gameLoop gs = do
  let bs = boardState gs
  let winner = checkWinner bs
  case winner of
    Winner (Just what) -> case what of
                            Left who -> do
                              putStrLn ("Player " ++ [posChar (Just who)] ++ " won.")
                              return gs
                            Right (Draw ()) -> do
                              putStrLn ("Game was a draw.")
                              return gs
    Winner Nothing  -> do
      let player = whoseMove gs  
      putStrLn (Main.show bs)
      putStrLn ("Player " ++ [posChar (Just player)] ++ ", your move: [1-9]")
      playerMove <- getLine
      let m_pos = readMaybe playerMove :: Maybe Int
      case m_pos of
        Nothing -> (putStrLn "Couldnt parse move.") >> gameLoop gs
        Just p  -> do
          let pos = (int2pos p)
          let m_gs' = move gs pos
          case m_gs' of
            Nothing  -> putStrLn "Bad move." >> gameLoop gs
            Just gs' -> gameLoop gs'