use minmax for rulebased ai

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

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

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

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

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
+choose = chooseStatistic
-    handCards <- gets myHand
-    table <- gets table
-    case length table of
-        0 -> if length handCards >= 7
-            then chooseLead
-            else chooseStatistic
-        n -> 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
+        limit = min 10000 $ realDisNo `div` 2
-            then 1
-            else 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
+    turnCol <- turnColour
-    let myCards = handCards hand piles
+    trumpCol <- trumpColour
-    possible <- filterM (P.isAllowed myCards) myCards
+    myHand <- gets getHand
-    case possible of
+    let ps = Players (PL $ Stupid.Stupid Team Hand1)
-        [card] -> return card
+                     (PL $ Stupid.Stupid Team Hand2)
-        cs -> do
+                     (PL $ Stupid.Stupid Single Hand3)
-            results <- mapM simulate cs
+        env = mkSkatEnv piles turnCol trumpCol ps myHand
-            let both = zip results cs
+    liftIO $ evalStateT (Minmax.choose :: Skat Card) env
-                best = maximumBy (comparing fst) both
-            liftIO $ putStrLn $ "results " ++ show both
-            return $ snd best
 
 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

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) =

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
+        env = SkatEnv cardDistr Nothing Spades ps Hand1
-    liftIO $ evalStateT (publishGameStart Hand3 >> turn Hand1 >>= publishGameResults) env
+    liftIO $ evalStateT (publishGameStart Hand3 >> turn >>= publishGameResults) env

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)
+            modify (setCurrentHand $ next n)
-        2 -> playFunc p >> turnGeneric playFunc depth (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 :: Skat (Int, Int)
-turn n = turnGeneric play 10 n
+turn = turnGeneric play 10
 
 evaluateTable :: Skat Hand
 evaluateTable = do