use minmax for rulebased ai

2020-02-29 12:39:04 +01:00
parent 173bd0df2e
commit 5846a22d8a
7 changed files with 93 additions and 62 deletions
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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) =
@@ -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
@@ -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