From 1ccce66d4a414d51789867daa119014c776c2049 Mon Sep 17 00:00:00 2001 From: flavis Date: Sat, 28 Mar 2020 22:30:06 +0100 Subject: [PATCH] implement online player bidding --- src/Skat/AI/Online.hs | 101 ++++++++++++++++++++++++++++++++++++---- src/Skat/AI/Stupid.hs | 15 ++++++ src/Skat/Bidding.hs | 33 +++++++++++++ src/Skat/Matches.hs | 22 ++++++++- src/Skat/Preperation.hs | 23 +++++---- 5 files changed, 175 insertions(+), 19 deletions(-) diff --git a/src/Skat/AI/Online.hs b/src/Skat/AI/Online.hs index 775018c..3408c4b 100644 --- a/src/Skat/AI/Online.hs +++ b/src/Skat/AI/Online.hs @@ -15,6 +15,8 @@ import qualified Skat.Player.Utils as P import Skat.Pile import Skat.Card import Skat.Render +import Skat.Preperation +import Skat.Bidding class Communicator a where send :: a -> String -> IO () @@ -32,16 +34,61 @@ data OnlineEnv c = OnlineEnv { getTeam :: Team , getHand :: Hand , connection :: c } +data PrepOnline c = PrepOnline { prepHand :: Hand + , prepConnection :: c + , prepCards :: [Card] } + instance Show (OnlineEnv c) where show _ = "An online env" +instance Show (PrepOnline c) where + show _ = "An online prep env" + instance Communicator c => Player (OnlineEnv c) where team = getTeam hand = getHand 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 + onGameStart p singlePlayer = runReaderT (onStartOnline singlePlayer) p + +instance Communicator c => Bidder (PrepOnline c) where + hand = prepHand + askBid p against bid = do + liftIO $ send (prepConnection p) (BS.unpack $ encode $ BidQuery against bid) + r <- liftIO $ receive (prepConnection p) + case decode (BS.pack r) of + Just (BidResponse newBid) -> do + if newBid > bid then return $ Just newBid else return Nothing + Nothing -> askBid p against bid + askResponse p bidder bid = do + liftIO $ send (prepConnection p) (BS.unpack $ encode $ BidResponseQuery bidder bid) + r <- liftIO $ receive (prepConnection p) + case decode (BS.pack r) of + Just (YesNo value) -> return value + Nothing -> askResponse p bidder bid + askGame p bid = do + liftIO $ send (prepConnection p) (BS.unpack $ encode $ AskGameQuery bid) + r <- liftIO $ receive (prepConnection p) + case decode (BS.pack r) of + Just (GameResponse game) -> return game + Nothing -> askGame p bid + askHand p bid = do + liftIO $ send (prepConnection p) (BS.unpack $ encode $ AskHandQuery) + r <- liftIO $ receive (prepConnection p) + case decode (BS.pack r) of + Just (YesNo value) -> return value + Nothing -> askHand p bid + askSkat p bid cards = do + liftIO $ send (prepConnection p) (BS.unpack $ encode $ AskSkatQuery cards bid) + r <- liftIO $ receive (prepConnection p) + case decode (BS.pack r) of + Just (ChosenCards cards) -> return cards + Nothing -> askSkat p bid cards + toPlayer p tm = PL $ OnlineEnv tm (prepHand p) (prepConnection p) + onStart p = do + let cards = prepCards p + liftIO $ send (prepConnection p) (BS.unpack $ encode $ CardsQuery cards) type Online a m = ReaderT (OnlineEnv a) m @@ -75,18 +122,30 @@ cardPlayed card = query (BS.unpack $ encode $ CardPlayedQuery card) onResults :: (Communicator c, MonadIO m) => (Int, Int) -> Online c m () onResults (sgl, tm) = query (BS.unpack $ encode $ GameResultsQuery sgl tm) -onStart :: (Communicator c, MonadPlayer m) => Hand -> Online c m () -onStart singlePlayer = do +onStartOnline :: (Communicator c, MonadPlayer m) => Hand -> Online c m () +onStartOnline singlePlayer = do trCol <- trumpColour ownHand <- asks getHand query (BS.unpack $ encode $ GameStartQuery trCol ownHand singlePlayer) + +-- | QUERIES AND RESPONSES data Query = ChooseQuery [Card] [CardS Played] | CardPlayedQuery (CardS Played) | GameResultsQuery Int Int | GameStartQuery Colour Hand Hand - -data Response = ChosenResponse Card + | BidQuery Hand Bid + | BidResponseQuery Hand Bid + | AskGameQuery Bid + | AskHandQuery + | AskSkatQuery [Card] Bid + | CardsQuery [Card] + +newtype ChosenResponse = ChosenResponse Card +newtype BidResponse = BidResponse Int +newtype YesNo = YesNo Bool +newtype GameResponse = GameResponse Game +newtype ChosenCards = ChosenCards [Card] instance ToJSON Query where toJSON (ChooseQuery hand table) = @@ -97,8 +156,34 @@ instance ToJSON Query where 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 Response where + "hand" .= toInt handNo, "single" .= toInt sglPlayer ] + toJSON (BidQuery hand bid) = + object ["query" .= ("bid" :: String), "whom" .= show hand ] + toJSON (BidResponseQuery hand bid) = + object ["query" .= ("bid_response" :: String), "from" .= show hand ] + toJSON (AskHandQuery) = + object ["query" .= ("play_hand" :: String)] + toJSON (AskSkatQuery cards bid) = + object ["query" .= ("skat" :: String), "cards" .= cards, "bid" .= bid ] + toJSON (CardsQuery cards) = + object ["query" .= ("cards" :: String), "cards" .= cards ] + +instance FromJSON ChosenResponse where parseJSON = withObject "ChosenResponse" $ \v -> ChosenResponse <$> v .: "card" + +instance FromJSON BidResponse where + parseJSON = withObject "BidResponse" $ \v -> BidResponse + <$> v .: "bid" + +instance FromJSON YesNo where + parseJSON = withObject "BidYesNo" $ \v -> YesNo + <$> v .: "yesno" + +instance FromJSON GameResponse where + parseJSON = withObject "GameResponse" $ \v -> GameResponse + <$> v .: "game" + +instance FromJSON ChosenCards where + parseJSON = withObject "ChosenCards" $ \v -> ChosenCards + <$> v .: "cards" diff --git a/src/Skat/AI/Stupid.hs b/src/Skat/AI/Stupid.hs index f5b947a..33a4508 100644 --- a/src/Skat/AI/Stupid.hs +++ b/src/Skat/AI/Stupid.hs @@ -3,6 +3,7 @@ module Skat.AI.Stupid where import Skat.Player import Skat.Pile import Skat.Card +import Skat.Preperation data Stupid = Stupid { getTeam :: Team , getHand :: Hand } @@ -16,3 +17,17 @@ instance Player Stupid where turnCol <- turnColour let possible = filter (isAllowed trumpCol turnCol hand) hand return (toCard $ head possible, p) + +newtype NoBidder = NoBidder Hand + deriving Show + +-- | no bidding from that player +instance Bidder NoBidder where + hand (NoBidder h) = h + askBid _ _ _ = return Nothing + askResponse _ _ _ = return False + askGame _ _ = undefined -- never called + askHand _ _ = return False -- never called + askSkat _ _ _ = undefined -- never called + toPlayer (NoBidder h) team = PL $ Stupid team h + onStart _ = return () diff --git a/src/Skat/Bidding.hs b/src/Skat/Bidding.hs index 1cb998c..e9e29e9 100644 --- a/src/Skat/Bidding.hs +++ b/src/Skat/Bidding.hs @@ -1,7 +1,11 @@ +{-# LANGUAGE OverloadedStrings #-} + module Skat.Bidding ( biddingScore, Game(..), Modifier(..) ) where +import Data.Aeson hiding (Null) + import Skat.Card import Data.List (sortOn) import Data.Ord (Down(..)) @@ -15,6 +19,22 @@ data Game = Colour Colour Modifier | NullOuvertHand deriving (Show, Eq) +instance FromJSON Game where + parseJSON = withObject "Game" $ \v -> do + gamekind <- v .: "game" + case (gamekind :: String) of + "colour" -> do + col <- v .: "colour" + mod <- v .: "modifier" + return $ Colour (read col) mod + "grand" -> do + mod <- v .: "modifier" + return $ Grand mod + "null" -> return Null + "nullhand" -> return NullHand + "nullouvert" -> return NullOuvert + "nullouverthand" -> return NullOuvertHand + -- | modifiers for grand and colour games data Modifier = Einfach | Schneider @@ -28,6 +48,19 @@ data Modifier = Einfach | Ouvert deriving (Show, Eq) +instance FromJSON Modifier where + parseJSON = withObject "Modifier" $ \v -> do + hnd <- v .: "hand" + if read hnd then do + schneider <- v .: "schneider" + schwarz <- v .: "schwarz" + ouvert <- v .: "ouvert" + case (schneider, schwarz, ouvert) of + (_, _, True) -> return Ouvert + (True, False, _) -> return HandSchneiderAngesagt + (_, True, _) -> return HandSchwarzAngesagt + else return Einfach + -- | calculate the value of a game with given cards biddingScore :: HasCard c => Game -> [c] -> Int biddingScore game@(Grand mod) cards = (spitzen game cards + modifierFactor mod) * 24 diff --git a/src/Skat/Matches.hs b/src/Skat/Matches.hs index 4aeaffe..3500655 100644 --- a/src/Skat/Matches.hs +++ b/src/Skat/Matches.hs @@ -1,8 +1,9 @@ module Skat.Matches ( - singleVsBots, pvp + singleVsBots, pvp, pvpWithBidding ) where import Control.Monad.State +import Control.Monad.Reader import System.Random (mkStdGen) import Skat @@ -10,6 +11,7 @@ import Skat.Operations import Skat.Player import Skat.Pile import Skat.Card +import Skat.Preperation import Skat.AI.Rulebased import Skat.AI.Online @@ -48,3 +50,21 @@ pvp comm1 comm2 comm3 = do (PL $ OnlineEnv Team Hand3 comm3) env = SkatEnv (distribute cards) Nothing Spades ps Hand1 liftIO $ evalStateT (publishGameStart Hand3 >> turn >>= publishGameResults) env + +pvpWithBidding :: Communicator c => c -> c -> c -> IO () +pvpWithBidding comm1 comm2 comm3 = do + cards <- shuffleCards + let ps = distribute cards + h1 = map toCard $ handCards Hand1 ps + h2 = map toCard $ handCards Hand2 ps + h3 = map toCard $ handCards Hand3 ps + bs = Bidders + (BD $ PrepOnline Hand1 comm1 $ h1) + (BD $ PrepOnline Hand2 comm2 $ h2) + (BD $ PrepOnline Hand3 comm3 $ h3) + env = PrepEnv ps bs + maySkatEnv <- liftIO $ runReaderT runPreperation env + case maySkatEnv of + Just skatEnv -> + liftIO $ evalStateT (publishGameStart Hand3 >> turn >>= publishGameResults) skatEnv + Nothing -> putStrLn "No one wanted to play." diff --git a/src/Skat/Preperation.hs b/src/Skat/Preperation.hs index 17538a0..11a16e5 100644 --- a/src/Skat/Preperation.hs +++ b/src/Skat/Preperation.hs @@ -1,11 +1,11 @@ {-# LANGUAGE ExistentialQuantification #-} module Skat.Preperation ( - + Bidder(..), Bid, BD(..), Bidders(..), PrepEnv(..), runPreperation ) where import Control.Monad.IO.Class -import Control.Monad.State +import Control.Monad.Reader import Skat.Pile import Skat.Card @@ -16,17 +16,16 @@ import Skat (SkatEnv, mkSkatEnv) type Bid = Int data PrepEnv = PrepEnv { piles :: Piles - , currentBid :: Bid - , currentHand :: Hand , bidders :: Bidders } deriving Show -type Preperation = StateT PrepEnv IO +type Preperation = ReaderT PrepEnv IO class Bidder a where hand :: a -> Hand + onStart :: MonadIO m => a -> m () askBid :: MonadIO m => a -> Hand -> Bid -> m (Maybe Bid) - askResponse :: MonadIO m => a -> Hand -> m Bool + askResponse :: MonadIO m => a -> Hand -> Bid -> m Bool askGame :: MonadIO m => a -> Bid -> m Game askHand :: MonadIO m => a -> Bid -> m Bool askSkat :: MonadIO m => a -> Bid -> [Card] -> m [Card] @@ -46,6 +45,7 @@ instance Bidder BD where askSkat (BD b) = askSkat b askResponse (BD b) = askResponse b toPlayer (BD b) = toPlayer b + onStart (BD b) = onStart b data Bidders = Bidders BD BD BD deriving Show @@ -63,7 +63,10 @@ toPlayers single (Bidders b1 b2 b3) = runPreperation :: Preperation (Maybe SkatEnv) runPreperation = do - bds <- gets bidders + bds <- asks bidders + onStart (bidder bds Hand1) + onStart (bidder bds Hand2) + onStart (bidder bds Hand3) (winner, bid) <- runBidding 0 (bidder bds Hand2) (bidder bds Hand1) (finalWinner, finalBid) <- runBidding 0 (bidder bds Hand3) (bidder bds winner) if finalBid == 0 then do @@ -78,15 +81,15 @@ runBidding startingBid reizer gereizter = do first <- askBid reizer (hand gereizter) startingBid case first of Just val -> do - response <- askResponse gereizter (hand reizer) + response <- askResponse gereizter (hand reizer) val if response then runBidding val reizer gereizter else return (hand reizer, val) Nothing -> return (hand gereizter, startingBid) initGame :: Hand -> Bid -> Preperation SkatEnv initGame single bid = do - ps <- gets piles - bds <- gets bidders + ps <- asks piles + bds <- asks bidders -- ask if player wants to play hand noSkat <- askHand (bidder bds single) bid -- either return piles or ask for skat cards and modify piles