christian/skat
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

implement online player bidding

Browse Source
This commit is contained in:
christian
2020-03-28 22:30:06 +01:00
parent b6b92c2cf9
commit 1ccce66d4a
5 changed files with 173 additions and 17 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Skat/AI/Online.hs
+90 -5
View File
@@ -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
| BidQuery Hand Bid
| BidResponseQuery Hand Bid
| AskGameQuery Bid
| AskHandQuery
| AskSkatQuery [Card] Bid
| CardsQuery [Card]
data Response = ChosenResponse 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) =
@@ -98,7 +157,33 @@ instance ToJSON Query where
toJSON (GameStartQuery trumps handNo sglPlayer) =
object ["query" .= ("start_game" :: String), "trumps" .= show trumps,
"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 Response where
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"
src/Skat/AI/Stupid.hs
+15
View File
@@ -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 ()
src/Skat/Bidding.hs
+33
View File
@@ -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
src/Skat/Matches.hs
+21 -1
View File
@@ -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."
src/Skat/Preperation.hs
+13 -10
View File
@@ -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