skat/src/Skat/AI/TicTacToe.hs

{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}

module Skat.AI.TicTacToe where

import Control.Monad.State
import Control.Exception (assert)
import Control.Monad.Fail
import Data.Ord
import Text.Read (readMaybe)
import Data.List (maximumBy, sortBy)
import Debug.Trace
import Text.Printf
import Data.Maybe
import qualified System.Random as Rand

import Skat.AI.Base
import Skat.AI.MonteCarlo
import Skat.Utils
-- TIC TAC TOE implementation

data TicTacToe = Tic | Tac | Toe
                 deriving (Eq, Ord)

instance Show TicTacToe where
    show Tic = "O"
    show Tac = "X"
    show Toe = "_"

data WinLossTie = Loss | Tie | Win
                  deriving (Eq, Show, Ord)

instance Value WinLossTie where
    invert Win = Loss
    invert Loss = Win
    invert Tie = Tie
    win = Win
    loss = Loss
    tie = Tie

data GameState = GameState { getBoard :: [TicTacToe]
                           , getCurrent :: Bool }
             deriving Show

instance HasGameState Int Bool WinLossTie GameState where
    execute turn state = execState (play turn) state
    moves state = evalState turns state
    monteevaluate s = let b = getBoard s 
                          w = fromMaybe Toe $ ticWinner b
                      in case w of
                            Tac -> Win
                            Tic -> Loss
                            Toe -> Tie
    current s = evalState currentPlayer s

instance Player Bool where
    maxing = id

instance Monad m => MonadGame Int [] WinLossTie Bool (StateT GameState m) where
    currentPlayer = gets getCurrent
    turns = do
        o <- over
        if o then return [] else do
            board <- gets getBoard
            let fields = zip [0..] board
            return $ map fst $ filter ((==Toe) . snd) fields
    play turn = do
        env <- get
        let value = if getCurrent env then Tic else Tac
            board' = updateAt turn (getBoard env) value
            current' = not $ getCurrent env
        put $ GameState board' current'
    simulate turn action = do
        backup <- get
        play turn
        res <- action
        put backup
        return $! res
    evaluate = do
        board <- gets getBoard
        current <- currentPlayer
        let mayWinner = ticWinner board
        case mayWinner of
            Just Tic -> return $ if current then Win else Loss
            Just Tac -> return $ if current then Loss else Win
            Just Toe -> return Tie
            Nothing -> return Tie
    over = do
        board <- gets getBoard
        case ticWinner board of
            Just _ -> return True
            _      -> return False

ticWinner :: [TicTacToe] -> Maybe TicTacToe
ticWinner board
    | ticWon    = Just Tic
    | tacWon    = Just Tac
    | over      = Just Toe
    | otherwise = Nothing
  where ticWon = hasWon $ map (==Tic) board
        tacWon = hasWon $ map (==Tac) board
        hasWon (True:_:_:True:_:_:True:_:_:[]) = True
        hasWon (True:_:_:_:True:_:_:_:True:[]) = True
        hasWon (_:True:_:_:True:_:_:True:_:[]) = True
        hasWon (_:_:True:_:_:True:_:_:True:[]) = True
        hasWon (_:_:True:_:True:_:True:_:_:[]) = True
        hasWon (True:True:True:_:_:_:_:_:_:[]) = True
        hasWon (_:_:_:True:True:True:_:_:_:[]) = True
        hasWon (_:_:_:_:_:_:True:True:True:[]) = True
        hasWon _                               = False
        over = (length $ filter (==Toe) board) == 0

-- some consts

emptyBoard :: [TicTacToe]
emptyBoard = [Toe, Toe, Toe, Toe, Toe, Toe, Toe, Toe, Toe]

otherBoard2 :: [TicTacToe]
otherBoard2 = [Tic, Tac, Toe, Tac, Tac, Tic, Tic, Toe, Toe]

otherBoard3 :: [TicTacToe]
otherBoard3 = [Tic, Toe, Toe, Tac, Tic, Toe, Toe, Tac, Toe]

tree2 = emptytree (initGameState { getBoard = otherBoard2
                                 , getCurrent = True })

tree3 = emptytree (initGameState { getBoard = otherBoard3
                                 , getCurrent = False })

initGameState :: GameState
initGameState = GameState { getBoard = emptyBoard
                          , getCurrent = False }

tictree :: Tree Int GameState
tictree = emptytree initGameState

instance Draw GameState where
    draw s = let b = getBoard s
        in printf "%s %s %s\n%s %s %s\n%s %s %s"
            (show $ b !! 0)
            (show $ b !! 1)
            (show $ b !! 2)
            (show $ b !! 3)
            (show $ b !! 4)
            (show $ b !! 5)
            (show $ b !! 6)
            (show $ b !! 7)
            (show $ b !! 8)

otherBoard :: [TicTacToe]
otherBoard = [Tic, Tac, Tac, Tic, Tac, Tic, Toe, Tic, Toe]

print9x9 :: (Int -> IO ()) -> IO ()
print9x9 pr = pr 0 >> pr 1 >> pr 2 >> putStrLn ""
    >> pr 3 >> pr 4 >> pr 5 >> putStrLn ""
    >> pr 6 >> pr 7 >> pr 8 >> putStrLn ""

printBoard :: [TicTacToe] -> IO ()
printBoard board = print9x9 pr >> putStrLn ""
    where pr n = putStr (show $ board !! n) >> putStr " "

printOptions :: [Int] -> IO ()
printOptions opts = print9x9 pr
    where pr n
            | n `elem` opts = putStr (show n) >> putStr " "
            | otherwise     = putStr "  "

instance MonadIO m => PlayableGame Int [] WinLossTie Bool (StateT GameState m) where
    showBoard = do
        board <- gets getBoard
        liftIO $ printBoard board
    showTurns = turns >>= liftIO . printOptions
    winner = do
        board <- gets getBoard
        let win = ticWinner board
        case win of
            Just Toe -> return Nothing
            Just Tic -> return $ Just True
            Just Tac -> return $ Just False
            Nothing -> return Nothing
    askTurn = readMaybe <$> liftIO getLine
    showTurn _ = return ()

playTicTacToe :: Int -> IO ()
playTicTacToe n = void $ (flip runStateT) (GameState emptyBoard False) (playCLI n)

playoften :: Int -> IO ()
playoften n = mapM_ playTicTacToe [1..n]

{-
newtype TicMCTS a = TicMCTS (StateT GameState (State Rand.StdGen) a)
                    deriving (Functor, Applicative, Monad, MonadState GameState)

instance Choose Int TicMCTS where
    choose = do
        s <- get
-}
playCLI :: Int -> StateT GameState IO ()
playCLI n = do
    gameOver <- over
    if gameOver
        then announceWinner
        else do
            current <- currentPlayer
            --let current = False
            if not current then do
                s <- get
                let tree = Leaf s False (0, 0)
                    t = bestmove $ runmonte n (foldM (\tree _ -> montecarlo tree) tree [1..5000])
                put t
            else do
                showBoard
                t <- readTurn
                play t
            showBoard
            {-
            liftIO $ getLine
            -}
            playCLI n
   where
      readTurn :: (MonadFail m, Read t, PlayableGame t l v p m) => m t
      readTurn = do
        options <- turns
        showTurns
        liftIO $ putStr "> "
        mayTurn <- askTurn
        case mayTurn of
            Just val -> if val `elem` options then return val else readTurn
            Nothing -> readTurn
      announceWinner = do
        showBoard
        win <- winner
        liftIO $ putStrLn $ show win ++ " wins the game!"