From 5846a22d8a8731c7f0e8a2d5178253eb9d0ebc65 Mon Sep 17 00:00:00 2001 From: flavis Date: Sat, 29 Feb 2020 12:39:04 +0100 Subject: [PATCH] use minmax for rulebased ai --- app/Main.hs | 39 ++++++++++++++++++++++----- skat.cabal | 3 ++- src/Skat.hs | 19 ++++++++++++-- src/Skat/AI/Rulebased.hs | 57 +++++++++++----------------------------- src/Skat/Card.hs | 2 +- src/Skat/Matches.hs | 4 +-- src/Skat/Operations.hs | 31 +++++++++++++++------- 7 files changed, 93 insertions(+), 62 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index bae15f7..87b485b 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -16,6 +16,7 @@ import Skat.Pile import Skat.AI.Stupid import Skat.AI.Online import Skat.AI.Rulebased +import Skat.AI.Minmax (playCLI) main :: IO () main = testAI 10 @@ -34,17 +35,17 @@ runAI = do trs = filter (isTrump Spades) cs if length trs >= 5 && any ((==32) . getID) cs then do - pts <- fst <$> evalStateT (turn Hand1) env + pts <- fst <$> evalStateT turn env -- if pts > 60 then return 1 else return 0 return pts else runAI env :: SkatEnv -env = SkatEnv piles Nothing Spades playersExamp +env = SkatEnv piles Nothing Spades playersExamp Hand1 where piles = distribute allCards envStupid :: SkatEnv -envStupid = SkatEnv piles Nothing Spades pls2 +envStupid = SkatEnv piles Nothing Spades pls2 Hand1 where piles = distribute allCards playersExamp :: Players @@ -57,15 +58,20 @@ pls2 :: Players pls2 = Players (PL $ Stupid Team Hand1) (PL $ Stupid Team Hand2) - (PL $ Stupid Team Hand3) + (PL $ Stupid Single Hand3) shuffledEnv :: IO SkatEnv shuffledEnv = do cards <- shuffleCards - return $ SkatEnv (distribute cards) Nothing Spades playersExamp + return $ SkatEnv (distribute cards) Nothing Spades playersExamp Hand1 + +shuffledEnv2 :: IO SkatEnv +shuffledEnv2 = do + cards <- shuffleCards + return $ SkatEnv (distribute cards) Nothing Spades pls2 Hand1 env2 :: SkatEnv -env2 = SkatEnv piles Nothing Spades playersExamp +env2 = SkatEnv piles Nothing Spades playersExamp Hand1 where hand1 = [Card Seven Clubs, Card King Clubs, Card Ace Clubs, Card Queen Diamonds] hand2 = [Card Seven Hearts, Card King Hearts, Card Ace Hearts, Card Queen Spades] hand3 = [Card Seven Spades, Card King Spades, Card Ace Spades, Card Queen Clubs] @@ -74,6 +80,23 @@ env2 = SkatEnv piles Nothing Spades playersExamp h3 = map (putAt Hand3) hand3 piles = Piles (h1 ++ h2 ++ h3) [] [] +env3 :: SkatEnv +env3 = SkatEnv piles Nothing Diamonds pls2 Hand3 + where hand1 = [ Card Jack Diamonds, Card Jack Clubs, Card Nine Spades, Card King Spades + , Card Seven Diamonds, Card Nine Diamonds, Card Seven Clubs, Card Eight Clubs + , Card Ten Clubs, Card Eight Hearts ] + hand2 = [ Card Seven Spades, Card Eight Spades, Card Seven Hearts, Card Nine Hearts + , Card Ace Hearts, Card King Diamonds, Card Ace Diamonds, Card Nine Clubs + , Card King Clubs, Card Ace Clubs ] + hand3 = [ Card Jack Hearts, Card Jack Spades, Card Ten Spades, Card Ace Spades, Card Eight Diamonds + , Card Queen Diamonds, Card Ten Diamonds, Card Ten Hearts, Card Queen Hearts, Card King Hearts ] + skat = [ Card Queen Clubs, Card Queen Spades] + h1 = map (putAt Hand1) hand1 + h2 = map (putAt Hand2) hand2 + h3 = map (putAt Hand3) hand3 + skt = map (putAt SkatP) skat + piles = Piles (h1 ++ h2 ++ h3) [] skt + runWebSocketServer :: IO () runWebSocketServer = do WS.runServer "localhost" 4243 application @@ -85,3 +108,7 @@ application pending = do forever $ do msg <- WS.receiveData conn putStrLn $ BS.unpack msg + +playSkat :: IO () +playSkat = do + void $ (flip runStateT) env3 playCLI diff --git a/skat.cabal b/skat.cabal index 078eec5..e514e53 100644 --- a/skat.cabal +++ b/skat.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 0d6eafec0c3ba6bb4c0150a39f4dbab784c7a519ec911d0f0344edd1c5d916da +-- hash: 589f4321e3ce9847f3a53afb14e0fa9eaa1b98b3fc7386eac20f8fae7f7b6bf7 name: skat version: 0.1.0.1 @@ -29,6 +29,7 @@ library exposed-modules: Skat Skat.AI.Human + Skat.AI.Minmax Skat.AI.Online Skat.AI.Rulebased Skat.AI.Server diff --git a/src/Skat.hs b/src/Skat.hs index 526c2ce..42d5dcb 100644 --- a/src/Skat.hs +++ b/src/Skat.hs @@ -16,7 +16,8 @@ import qualified Skat.Player as P data SkatEnv = SkatEnv { piles :: Piles , turnColour :: Maybe Colour , trumpColour :: Colour - , players :: Players } + , players :: Players + , currentHand :: Hand } deriving Show type Skat = StateT SkatEnv IO @@ -45,5 +46,19 @@ modifyPlayers f = modify g setTurnColour :: Maybe Colour -> SkatEnv -> SkatEnv setTurnColour col sk = sk { turnColour = col } -mkSkatEnv :: Piles -> Maybe Colour -> Colour -> Players -> SkatEnv +setCurrentHand :: Hand -> SkatEnv -> SkatEnv +setCurrentHand hand sk = sk { currentHand = hand } + +mkSkatEnv :: Piles -> Maybe Colour -> Colour -> Players -> Hand -> SkatEnv mkSkatEnv = SkatEnv + +allowedCards :: Skat [Card] +allowedCards = do + curHand <- gets currentHand + pls <- gets players + turnCol <- gets turnColour + trumpCol <- gets trumpColour + ps <- gets piles + let p = P.player pls curHand + cards = handCards curHand ps + return $ filter (isAllowed trumpCol turnCol cards) cards diff --git a/src/Skat/AI/Rulebased.hs b/src/Skat/AI/Rulebased.hs index 64bb3a9..11eb319 100644 --- a/src/Skat/AI/Rulebased.hs +++ b/src/Skat/AI/Rulebased.hs @@ -24,6 +24,8 @@ import Skat.Card import Skat.Utils import Skat (Skat, modifyp, mkSkatEnv) import Skat.Operations +import qualified Skat.AI.Minmax as Minmax +import qualified Skat.AI.Stupid as Stupid (Stupid(..)) data AIEnv = AIEnv { getTeam :: Team , getHand :: Hand @@ -229,34 +231,12 @@ onPlayed c = do Nothing -> return () choose :: MonadPlayer m => AI m Card -choose = do - handCards <- gets myHand - table <- gets table - case length table of - 0 -> if length handCards >= 7 - then chooseLead - else chooseStatistic - n -> chooseStatistic +choose = chooseStatistic chooseStatistic :: MonadPlayer m => AI m Card chooseStatistic = do h <- gets getHand handCards <- gets myHand - let depth = case length handCards of - 0 -> 0 - 1 -> 1 - -- simulate whole game - 2 -> 2 - 3 -> 3 - -- simulate only partially - 4 -> 3 - 5 -> 3 - 6 -> 2 - 7 -> 1 - 8 -> 1 - 9 -> 1 - 10 -> 1 - modify $ setDepth depth guess__ <- gets guess self <- get maySkat <- showSkat self @@ -274,9 +254,7 @@ chooseStatistic = do reducedDis = simplify Hand3 realDis reducedDisNo = length reducedDis piless = map (\(d, n) -> (toPiles table d, n)) reducedDis - limit = if depth == 1 && length table == 2 - then 1 - else min 10000 $ realDisNo `div` 2 + limit = min 10000 $ realDisNo `div` 2 liftIO $ putStrLn $ "players hand" ++ show handCards liftIO $ putStrLn $ "possible distrs without simp " ++ show realDisNo liftIO $ putStrLn $ "possible distrs " ++ show reducedDisNo @@ -310,29 +288,26 @@ chooseOpen = do let myCards = handCards hand piles liftIO $ putStrLn $ show hand ++ " chooses from " ++ show myCards possible <- filterM (P.isAllowed myCards) myCards - case length myCards of + case length possible of 0 -> do liftIO $ print hand liftIO $ print piles error "no cards left to choose from" - 1 -> return $ head myCards + 1 -> return $ head possible _ -> chooseSimulating chooseSimulating :: (MonadState AIEnv m, MonadPlayerOpen m) => m Card chooseSimulating = do piles <- showPiles - hand <- gets getHand - let myCards = handCards hand piles - possible <- filterM (P.isAllowed myCards) myCards - case possible of - [card] -> return card - cs -> do - results <- mapM simulate cs - let both = zip results cs - best = maximumBy (comparing fst) both - liftIO $ putStrLn $ "results " ++ show both - return $ snd best + turnCol <- turnColour + trumpCol <- trumpColour + myHand <- gets getHand + let ps = Players (PL $ Stupid.Stupid Team Hand1) + (PL $ Stupid.Stupid Team Hand2) + (PL $ Stupid.Stupid Single Hand3) + env = mkSkatEnv piles turnCol trumpCol ps myHand + liftIO $ evalStateT (Minmax.choose :: Skat Card) env simulate :: (MonadState AIEnv m, MonadPlayerOpen m) => Card -> m Int @@ -351,11 +326,11 @@ simulate card = do (PL $ mkAIEnv Team Hand1 newDepth) (PL $ mkAIEnv Team Hand2 newDepth) (PL $ mkAIEnv Single Hand3 newDepth) - env = mkSkatEnv piles turnCol trumpCol ps + env = mkSkatEnv piles turnCol trumpCol ps (next myHand) -- simulate the game after playing the given card (sgl, tm) <- liftIO $ evalStateT (do modifyp $ playCard card - turnGeneric playOpen depth (next myHand)) env + turnGeneric playOpen depth) env let v = if myTeam == Single then (sgl, tm) else (tm, sgl) -- put the value into context for when not the whole game is -- simulated diff --git a/src/Skat/Card.hs b/src/Skat/Card.hs index e0ee59c..aff8c67 100644 --- a/src/Skat/Card.hs +++ b/src/Skat/Card.hs @@ -39,7 +39,7 @@ data Colour = Diamonds deriving (Eq, Ord, Show, Enum, Read) data Card = Card Type Colour - deriving (Eq, Show, Ord) + deriving (Eq, Show, Ord, Read) instance ToJSON Card where toJSON (Card t c) = diff --git a/src/Skat/Matches.hs b/src/Skat/Matches.hs index ea3a1d9..08112de 100644 --- a/src/Skat/Matches.hs +++ b/src/Skat/Matches.hs @@ -40,5 +40,5 @@ singleVsBots comm = do (PL $ OnlineEnv Team Hand1 comm) (PL $ Stupid Team Hand2) (PL $ mkAIEnv Single Hand3 10) - env = SkatEnv cardDistr Nothing Spades ps - liftIO $ evalStateT (publishGameStart Hand3 >> turn Hand1 >>= publishGameResults) env + env = SkatEnv cardDistr Nothing Spades ps Hand1 + liftIO $ evalStateT (publishGameStart Hand3 >> turn >>= publishGameResults) env diff --git a/src/Skat/Operations.hs b/src/Skat/Operations.hs index d2fbb12..9f79062 100644 --- a/src/Skat/Operations.hs +++ b/src/Skat/Operations.hs @@ -1,6 +1,6 @@ module Skat.Operations ( turn, turnGeneric, play, playOpen, publishGameResults, - publishGameStart + publishGameStart, play_, sortRender ) where import Control.Monad.State @@ -23,32 +23,45 @@ compareRender (Card t1 c1) (Card t2 c2) = case compare c1 c2 of sortRender :: [Card] -> [Card] sortRender = sortBy compareRender +play_ :: Card -> Skat () +play_ card = do + hand <- gets currentHand + trCol <- gets trumpColour + modifyp $ playCard card + table <- getp tableCards + case length table of + 1 -> do modify (setCurrentHand $ next hand) + modify $ setTurnColour (Just $ effectiveColour trCol $ head table) + 3 -> evaluateTable >>= modify . setCurrentHand + _ -> modify (setCurrentHand $ next hand) + turnGeneric :: (PL -> Skat Card) -> Int - -> Hand -> Skat (Int, Int) -turnGeneric playFunc depth n = do +turnGeneric playFunc depth = do + n <- gets currentHand table <- getp tableCards ps <- gets players let p = player ps n hand <- getp $ handCards n trCol <- gets trumpColour case length table of - 0 -> playFunc p >> turnGeneric playFunc depth (next n) + 0 -> playFunc p >> modify (setCurrentHand $ next n) >> turnGeneric playFunc depth 1 -> do modify $ setTurnColour (Just $ effectiveColour trCol $ head table) playFunc p - turnGeneric playFunc depth (next n) - 2 -> playFunc p >> turnGeneric playFunc depth (next n) + modify (setCurrentHand $ next n) + turnGeneric playFunc depth + 2 -> playFunc p >> modify (setCurrentHand $ next n) >> turnGeneric playFunc depth 3 -> do w <- evaluateTable if depth <= 1 || length hand == 0 then countGame - else turnGeneric playFunc (depth - 1) w + else modify (setCurrentHand w) >> turnGeneric playFunc (depth - 1) -turn :: Hand -> Skat (Int, Int) -turn n = turnGeneric play 10 n +turn :: Skat (Int, Int) +turn = turnGeneric play 10 evaluateTable :: Skat Hand evaluateTable = do