From 173bd0df2e8326cc0693e1d527e30cd8c44d566c Mon Sep 17 00:00:00 2001 From: flavis Date: Sat, 29 Feb 2020 12:38:07 +0100 Subject: [PATCH] minmax implementation --- src/Skat/AI/Minmax.hs | 299 ++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 299 insertions(+) create mode 100644 src/Skat/AI/Minmax.hs diff --git a/src/Skat/AI/Minmax.hs b/src/Skat/AI/Minmax.hs new file mode 100644 index 0000000..f656a0b --- /dev/null +++ b/src/Skat/AI/Minmax.hs @@ -0,0 +1,299 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE TupleSections #-} + +module Skat.AI.Minmax ( + choose, playCLI +) where + +import Control.Monad.State +import Control.Monad.Fail +import Data.Ord +import Text.Read (readMaybe) +import Data.List (minimumBy, maximumBy) +import Debug.Trace + +import qualified Skat as S +import qualified Skat.Card as S +import qualified Skat.Operations as S +import qualified Skat.Pile as S +import qualified Skat.Player as S +import qualified Skat.Render as S + +debug :: Bool +debug = False + +class (Ord v, Eq v) => Value v where + invert :: v -> v + win :: v + loss :: v + +class Player p where + maxing :: p -> Bool + +class (Monad m, Value v, Player p, Eq t) => MonadGame t v p m | m -> t, m -> p, m -> v where + currentPlayer :: m p + turns :: m [t] + play :: t -> m () + simulate :: t -> m a -> m a + evaluate :: m v + over :: m Bool + +class (MonadIO m, Show t, Show v, Show p, MonadGame t v p m) => PlayableGame t v p m | m -> t, m -> p, m -> v where + showTurns :: m () + showBoard :: m () + askTurn :: m (Maybe t) + showTurn :: t -> m () + winner :: m (Maybe p) + +-- Skat implementation + +instance Player S.PL where + maxing p = S.team p == S.Team + +instance Value Int where + invert = negate + win = 120 + loss = -120 + +instance MonadGame S.Card Int S.PL S.Skat where + currentPlayer = do + hand <- gets S.currentHand + pls <- gets S.players + return $ S.player pls hand + turns = S.allowedCards + play = S.play_ + simulate card action = do + backup <- get + play card + res <- action + put backup + return res + over = ((==0) . length) <$> S.allowedCards + evaluate = do + player <- currentPlayer + piles <- gets S.piles + let (sgl, tm) = S.count piles + return $ (if maxing player then tm - sgl else sgl - tm) + +-- 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 + +data GameState = GameState { getBoard :: [TicTacToe] + , getCurrent :: Bool } + deriving Show + +instance Player Bool where + maxing = id + +instance Monad m => MonadGame Int WinLossTie Bool (StateT GameState m) where + currentPlayer = gets getCurrent + turns = 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 + +updateAt :: Int -> [a] -> a -> [a] +updateAt n xs y = map f $ zip [0..] xs + where f (i, x) = if i == n then y else x + +minmax :: (MonadIO m, Show v, Show t, Show p, Value v, Eq t, Player p, MonadGame t v p m) + => Int + -> t + -> v + -> v + -> m (t, v) +minmax depth turn alpha beta = (flip evalStateT) (alpha, beta) $ do + gameOver <- lift over + -- if last step or game is over then evaluate situation + if depth == 0 || gameOver then do + val <- lift evaluate + when debug $ liftIO $ putStrLn $ "evaluation: " ++ show val + return (turn, val) + else do + when debug $ liftIO $ putStrLn $ "depth " ++ show depth + -- generate a list of possible turns + currentlyMaxing <- maxing <$> lift currentPlayer + availableTurns <- lift turns + (alpha, beta) <- get + -- try every turn, StateT wraps current best turn and current max value + (flip execStateT) (undefined, alpha) $ forM_ availableTurns $ \turn -> do + currentMax <- gets snd + when debug $ liftIO $ putStrLn $ "simulating " ++ show turn ++ " with max " ++ show currentMax + ++ " and beta " ++ show beta + --when (currentMax >= beta && debug) $ liftIO $ putStrLn "beta cutoff" + -- beta cutoff + unless (currentMax >= beta) $ do + --unless False $ do + value <- lift $ lift $ simulate turn $ step currentlyMaxing beta currentMax + when debug $ liftIO $ putStrLn $ "value " ++ show value + when (value > currentMax) (put (turn, value)) + where step currentlyMaxing beta currentMax = do + nextMaxing <- maxing <$> currentPlayer + if nextMaxing /= currentlyMaxing + then (invert . snd) <$> minmax (depth-1) turn (invert beta) (invert currentMax) + else snd <$> minmax (depth-1) turn currentMax beta + +choose :: (MonadIO m, Show v, Show t, Show p, Value v, Eq t, Player p, MonadGame t v p m) => m t +choose = fst <$> minmax 10 undefined loss win + +emptyBoard :: [TicTacToe] +emptyBoard = [Toe, Toe, Toe, Toe, Toe, Toe, Toe, Toe, Toe] + +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 () + +instance PlayableGame S.Card Int S.PL S.Skat where + showBoard = do + liftIO $ putStrLn "" + table <- S.getp S.tableCards + liftIO $ putStr "Table: " + liftIO $ print table + showTurns = do + cards <- turns + player <- currentPlayer + liftIO $ print player + liftIO $ S.render (S.sortRender cards) + winner = do + piles <- gets S.piles + pls <- gets S.players + let res = S.count piles :: (Int, Int) + winnerTeam = trace (show res) $ if fst res > snd res then S.Single else S.Team + winners = filter ((==winnerTeam) . S.team) (S.playersToList pls) + return $ Just $ head winners + askTurn = do + cards <- turns + let sorted = S.sortRender cards + input <- liftIO getLine + case readMaybe input of + Just n -> if n >= 0 && n < length sorted then return $ Just (sorted !! n) + else return Nothing + Nothing -> return Nothing + showTurn card = do + player <- currentPlayer + liftIO $ putStrLn $ show player ++ " plays " ++ show card + +playCLI :: (MonadFail m, Read t, PlayableGame t v p m) => m () +playCLI = do + gameOver <- over + if gameOver + then announceWinner + else do + showBoard + current <- currentPlayer + turn <- if not (maxing current) then readTurn else choose + showTurn turn + play turn + playCLI + where + 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!" + +playTicTacToe :: IO () +playTicTacToe = void $ (flip runStateT) (GameState emptyBoard True) playCLI