diff --git a/Operations.hs b/Operations.hs deleted file mode 100644 index 6f76006..0000000 --- a/Operations.hs +++ /dev/null @@ -1,88 +0,0 @@ -module Operations where - -import Control.Monad.State -import System.Random (newStdGen, randoms) -import Data.List -import Data.Ord - -import Card -import Skat -import Pile -import Player (chooseCard, Players(..), Player(..), PL(..), - updatePlayer, playersToList, player) -import Utils (shuffle) - -compareRender :: Card -> Card -> Ordering -compareRender (Card t1 c1) (Card t2 c2) = case compare c1 c2 of - EQ -> compare t1 t2 - v -> v - -sortRender :: [Card] -> [Card] -sortRender = sortBy compareRender - -turnGeneric :: (PL -> Skat Card) - -> Int - -> Hand - -> Skat (Int, Int) -turnGeneric playFunc depth n = do - 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) - 1 -> do - modify $ setTurnColour - (Just $ effectiveColour trCol $ head table) - playFunc p - turnGeneric playFunc depth (next n) - 2 -> playFunc p >> turnGeneric playFunc depth (next n) - 3 -> do - w <- evaluateTable - if depth <= 1 || length hand == 0 - then countGame - else turnGeneric playFunc (depth - 1) w - -turn :: Hand -> Skat (Int, Int) -turn n = turnGeneric play 10 n - -evaluateTable :: Skat Hand -evaluateTable = do - trumpCol <- gets trumpColour - turnCol <- gets turnColour - table <- getp tableCards - ps <- gets players - let winningCard = highestCard trumpCol turnCol table - Just winnerHand <- getp $ originOfCard winningCard - let winner = player ps winnerHand - modifyp $ cleanTable (team winner) - modify $ setTurnColour Nothing - return $ hand winner - -countGame :: Skat (Int, Int) -countGame = getp count - -play :: (Show p, Player p) => p -> Skat Card -play p = do - liftIO $ putStrLn "playing" - table <- getp tableCardsS - turnCol <- gets turnColour - trump <- gets trumpColour - hand <- getp $ handCards (hand p) - fallen <- getp played - (card, p') <- chooseCard p table fallen hand - modifyPlayers $ updatePlayer p' - modifyp $ playCard card - ps <- fmap playersToList $ gets players - table' <- getp tableCardsS - ps' <- mapM (\p -> onCardPlayed p (head table')) ps - mapM_ (modifyPlayers . updatePlayer) ps' - return card - -playOpen :: (Show p, Player p) => p -> Skat Card -playOpen p = do - --liftIO $ putStrLn $ show (hand p) ++ " playing open" - card <- chooseCardOpen p - modifyp $ playCard card - return card diff --git a/app/Main.hs b/app/Main.hs index 5fa52f5..bae15f7 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -35,7 +35,8 @@ runAI = do if length trs >= 5 && any ((==32) . getID) cs then do pts <- fst <$> evalStateT (turn Hand1) env - if pts > 60 then return 1 else return 0 + -- if pts > 60 then return 1 else return 0 + return pts else runAI env :: SkatEnv diff --git a/skat.cabal b/skat.cabal index 8456557..078eec5 100644 --- a/skat.cabal +++ b/skat.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: fd93323d8ea488caa20459179e7d1d829224ee7976b53721e476514efba64baa +-- hash: 0d6eafec0c3ba6bb4c0150a39f4dbab784c7a519ec911d0f0344edd1c5d916da name: skat version: 0.1.0.1 @@ -34,6 +34,7 @@ library Skat.AI.Server Skat.AI.Stupid Skat.Card + Skat.Matches Skat.Operations Skat.Pile Skat.Player diff --git a/src/Skat/AI/Online.hs b/src/Skat/AI/Online.hs index 63f1ca1..8fb52a3 100644 --- a/src/Skat/AI/Online.hs +++ b/src/Skat/AI/Online.hs @@ -33,6 +33,7 @@ instance Player OnlineEnv where chooseCard p table _ hand = runReaderT (choose table hand) p >>= \c -> return (c, p) onCardPlayed p c = runReaderT (cardPlayed c) p >> return p onGameResults p res = runReaderT (onResults res) p + onGameStart p singlePlayer = runReaderT (onStart singlePlayer) p type Online m = ReaderT OnlineEnv m @@ -65,23 +66,30 @@ cardPlayed card = query (BS.unpack $ encode $ CardPlayedQuery card) onResults :: MonadIO m => (Int, Int) -> Online m () onResults (sgl, tm) = query (BS.unpack $ encode $ GameResultsQuery sgl tm) -data ChooseQuery = ChooseQuery [Card] [CardS Played] -data CardPlayedQuery = CardPlayedQuery (CardS Played) -data GameResultsQuery = GameResultsQuery Int Int -data ChosenResponse = ChosenResponse Card - -instance ToJSON ChooseQuery where +onStart :: MonadPlayer m => Hand -> Online m () +onStart singlePlayer = do + trCol <- trumpColour + ownHand <- asks getHand + query (BS.unpack $ encode $ GameStartQuery trCol ownHand singlePlayer) + +data Query = ChooseQuery [Card] [CardS Played] + | CardPlayedQuery (CardS Played) + | GameResultsQuery Int Int + | GameStartQuery Colour Hand Hand + +data Response = ChosenResponse Card + +instance ToJSON Query where toJSON (ChooseQuery hand table) = object ["query" .= ("choose_card" :: String), "hand" .= hand, "table" .= table] - -instance ToJSON CardPlayedQuery where toJSON (CardPlayedQuery card) = object ["query" .= ("card_played" :: String), "card" .= card] - -instance ToJSON GameResultsQuery where toJSON (GameResultsQuery sgl tm) = object ["query" .= ("results" :: String), "single" .= sgl, "team" .= tm] + toJSON (GameStartQuery trumps handNo sglPlayer) = + object ["query" .= ("start_game" :: String), "trumps" .= show trumps, + "hand" .= toInt handNo, "single" .= toInt sglPlayer] -instance FromJSON ChosenResponse where +instance FromJSON Response where parseJSON = withObject "ChosenResponse" $ \v -> ChosenResponse <$> v .: "card" diff --git a/src/Skat/Matches.hs b/src/Skat/Matches.hs new file mode 100644 index 0000000..da30693 --- /dev/null +++ b/src/Skat/Matches.hs @@ -0,0 +1,25 @@ +module Skat.Matches ( + singleVsBots +) where + +import Control.Monad.State + +import Skat +import Skat.Operations +import Skat.Player +import Skat.Pile +import Skat.Card + +import Skat.AI.Rulebased +import Skat.AI.Online +import Skat.AI.Stupid + +singleVsBots :: (Team -> Hand -> OnlineEnv) -> IO () +singleVsBots mkPlayer = do + cards <- liftIO $ shuffleCards + let ps = Players + (PL $ mkPlayer Team Hand1) + (PL $ Stupid Team Hand2) + (PL $ mkAIEnv Single Hand3 10) + env = SkatEnv (distribute cards) Nothing Spades ps + liftIO $ evalStateT (turn Hand1 >>= publishGameResults) env diff --git a/src/Skat/Operations.hs b/src/Skat/Operations.hs index 68e53a2..5b1e1e4 100644 --- a/src/Skat/Operations.hs +++ b/src/Skat/Operations.hs @@ -1,4 +1,6 @@ -module Skat.Operations where +module Skat.Operations ( + turn, turnGeneric, play, playOpen, publishGameResults +) where import Control.Monad.State import System.Random (newStdGen, randoms) @@ -86,3 +88,8 @@ playOpen p = do card <- chooseCardOpen p modifyp $ playCard card return card + +publishGameResults :: (Int, Int) -> Skat () +publishGameResults res = do + pls <- gets players + mapM_ (\p -> onGameResults p res) (playersToList pls) diff --git a/src/Skat/Pile.hs b/src/Skat/Pile.hs index 9635580..5c51869 100644 --- a/src/Skat/Pile.hs +++ b/src/Skat/Pile.hs @@ -28,6 +28,11 @@ instance ToJSON p => ToJSON (CardS p) where data Hand = Hand1 | Hand2 | Hand3 deriving (Show, Eq, Ord) +toInt :: Hand -> Int +toInt Hand1 = 1 +toInt Hand2 = 2 +toInt Hand3 = 3 + next :: Hand -> Hand next Hand1 = Hand2 next Hand2 = Hand3 diff --git a/src/Skat/Player.hs b/src/Skat/Player.hs index 17a09c6..9f5c466 100644 --- a/src/Skat/Player.hs +++ b/src/Skat/Player.hs @@ -43,6 +43,11 @@ class Player p where -> (Int, Int) -> m () onGameResults _ _ = return () + onGameStart :: MonadPlayer m + => p + -> Hand + -> m () + onGameStart _ _ = return () data PL = forall p. (Show p, Player p) => PL p @@ -60,6 +65,7 @@ instance Player PL where return $ PL v chooseCardOpen (PL p) = chooseCardOpen p onGameResults (PL p) res = onGameResults p res + onGameStart (PL p) singlePlayer = onGameStart p singlePlayer data Players = Players PL PL PL deriving Show