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

handle ueberreizung

Browse Source
This commit is contained in:
christian
2020-04-07 01:34:38 +02:00
parent fac461b759
commit dd629db320
6 changed files with 126 additions and 45 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Skat/AI/Online.hs
+3 -2
View File
@@ -117,7 +117,8 @@ instance MonadPlayer m => MonadPlayer (Online a m) where
choose :: (HasCard b, HasCard a) => (Communicator c, MonadPlayer m) => [CardS Played] -> Maybe [b] -> [a] -> Online c m Card choose :: (HasCard b, HasCard a) => (Communicator c, MonadPlayer m) => [CardS Played] -> Maybe [b] -> [a] -> Online c m Card
choose table mayOuvert hand' = do choose table mayOuvert hand' = do
let hand = sortRender Jacks $ map toCard hand' gm <- game
let hand = sortRender (getTrump gm) $ map toCard hand'
query (BS.unpack $ encode $ ChooseQuery hand table $ fmap (map toCard) mayOuvert) query (BS.unpack $ encode $ ChooseQuery hand table $ fmap (map toCard) mayOuvert)
r <- response r <- response
case decode (BS.pack r) of case decode (BS.pack r) of
@@ -134,7 +135,7 @@ cardPlayed card = query (BS.unpack $ encode $ CardPlayedQuery card)
data Query = ChooseQuery [Card] [CardS Played] (Maybe [Card]) data Query = ChooseQuery [Card] [CardS Played] (Maybe [Card])
| CardPlayedQuery (CardS Played) | CardPlayedQuery (CardS Played)
| GameResultsQuery Result | GameResultsQuery Result
| GameStartQuery Game Hand | GameStartQuery HideGame Hand
| BidQuery Hand Bid | BidQuery Hand Bid
| BidResponseQuery Hand Bid | BidResponseQuery Hand Bid
| AskGameQuery Bid | AskGameQuery Bid
src/Skat/AI/Stupid.hs
+1 -1
View File
@@ -29,7 +29,7 @@ newtype NoBidder = NoBidder Hand
-- | no bidding from that player -- | no bidding from that player
instance Bidder NoBidder where instance Bidder NoBidder where
hand (NoBidder h) = h hand (NoBidder h) = h
askBid _ _ bid = return $ Just 20 askBid _ _ bid = return $ Just 120
askResponse _ _ bid = if bid < 24 then return True else return False askResponse _ _ bid = if bid < 24 then return True else return False
askGame _ _ = return $ Grand Hand askGame _ _ = return $ Grand Hand
askHand _ _ = return True askHand _ _ = return True
src/Skat/Bidding.hs
+97 -19
View File
@@ -2,7 +2,7 @@
module Skat.Bidding ( module Skat.Bidding (
biddingScore, Game(..), Modifier(..), isHand, getTrump, Result(..), biddingScore, Game(..), Modifier(..), isHand, getTrump, Result(..),
getResults, isOuvert, isSchwarz getResults, isOuvert, isSchwarz, Bid, checkGame, HideGame(..)
) where ) where
import Data.Aeson hiding (Null, Result) import Data.Aeson hiding (Null, Result)
@@ -13,6 +13,8 @@ import Data.Ord (Down(..))
import Control.Monad import Control.Monad
import Skat.Pile import Skat.Pile
type Bid = Int
-- | different game types -- | different game types
data Game = Colour Colour Modifier data Game = Colour Colour Modifier
| Grand Modifier | Grand Modifier
@@ -22,6 +24,9 @@ data Game = Colour Colour Modifier
| NullOuvertHand | NullOuvertHand
deriving (Show, Eq) deriving (Show, Eq)
newtype HideGame = HideGame Game
deriving (Show, Eq)
instance ToJSON Game where instance ToJSON Game where
toJSON (Grand mod) = toJSON (Grand mod) =
object ["game" .= ("grand" :: String), "modifier" .= show mod] object ["game" .= ("grand" :: String), "modifier" .= show mod]
@@ -32,6 +37,13 @@ instance ToJSON Game where
toJSON NullOuvert = object ["game" .= ("nullouvert" :: String)] toJSON NullOuvert = object ["game" .= ("nullouvert" :: String)]
toJSON NullOuvertHand = object ["game" .= ("nullouverthand" :: String)] toJSON NullOuvertHand = object ["game" .= ("nullouverthand" :: String)]
instance ToJSON HideGame where
toJSON (HideGame (Grand mod)) =
object ["game" .= ("grand" :: String), "modifier" .= prettyShow mod]
toJSON (HideGame (Colour col mod)) =
object ["game" .= ("colour" :: String), "modifier" .= prettyShow mod, "colour" .= show col]
toJSON (HideGame game) = toJSON game
instance FromJSON Game where instance FromJSON Game where
parseJSON = withObject "Game" $ \v -> do parseJSON = withObject "Game" $ \v -> do
gamekind <- v .: "game" gamekind <- v .: "game"
@@ -56,7 +68,7 @@ data Modifier = Einfach
| Hand | Hand
| HandSchneider | HandSchneider
| HandSchneiderAngesagt | HandSchneiderAngesagt
| HandSchneiderSchwarz | HandSchwarz
| HandSchneiderAngesagtSchwarz | HandSchneiderAngesagtSchwarz
| HandSchwarzAngesagt | HandSchwarzAngesagt
| Ouvert | Ouvert
@@ -76,11 +88,26 @@ instance FromJSON Modifier where
_ -> return Hand _ -> return Hand
else return Einfach else return Einfach
isHand :: Modifier -> Bool prettyShow :: Modifier -> String
isHand Einfach = False prettyShow Schneider = show Einfach
isHand Schneider = False prettyShow Schwarz = show Einfach
isHand Schwarz = False prettyShow HandSchneider = show Hand
isHand _ = True prettyShow HandSchwarz = show Hand
prettyShow HandSchneiderAngesagtSchwarz = show HandSchneiderAngesagt
prettyShow mod = show mod
isHand :: Game -> Bool
isHand NullHand = True
isHand NullOuvertHand = True
isHand (Colour _ mod) = modIsHand mod
isHand (Grand mod) = modIsHand mod
isHand _ = False
modIsHand :: Modifier -> Bool
modIsHand Einfach = False
modIsHand Schneider = False
modIsHand Schwarz = False
modIsHand _ = True
isOuvert :: Game -> Bool isOuvert :: Game -> Bool
isOuvert NullOuvert = True isOuvert NullOuvert = True
@@ -89,6 +116,17 @@ isOuvert (Grand Ouvert) = True
isOuvert (Colour _ Ouvert) = True isOuvert (Colour _ Ouvert) = True
isOuvert _ = False isOuvert _ = False
baseFactor :: Game -> Int
baseFactor (Grand _) = 24
baseFactor (Colour Clubs _) = 12
baseFactor (Colour Spades _) = 11
baseFactor (Colour Hearts _) = 10
baseFactor (Colour Diamonds _) = 9
baseFactor Null = 23
baseFactor NullHand = 35
baseFactor NullOuvert = 46
baseFactor NullOuvertHand = 59
-- | calculate the value of a game with given cards -- | calculate the value of a game with given cards
biddingScore :: HasCard c => Game -> [c] -> Int biddingScore :: HasCard c => Game -> [c] -> Int
biddingScore game@(Grand mod) cards = (spitzen game cards + modifierFactor mod) * 24 biddingScore game@(Grand mod) cards = (spitzen game cards + modifierFactor mod) * 24
@@ -96,10 +134,7 @@ biddingScore game@(Colour Clubs mod) cards = (spitzen game cards + modifierFa
biddingScore game@(Colour Spades mod) cards = (spitzen game cards + modifierFactor mod) * 11 biddingScore game@(Colour Spades mod) cards = (spitzen game cards + modifierFactor mod) * 11
biddingScore game@(Colour Hearts mod) cards = (spitzen game cards + modifierFactor mod) * 10 biddingScore game@(Colour Hearts mod) cards = (spitzen game cards + modifierFactor mod) * 10
biddingScore game@(Colour Diamonds mod) cards = (spitzen game cards + modifierFactor mod) * 9 biddingScore game@(Colour Diamonds mod) cards = (spitzen game cards + modifierFactor mod) * 9
biddingScore Null _ = 23 biddingScore game _ = baseFactor game
biddingScore NullHand _ = 35
biddingScore NullOuvert _ = 46
biddingScore NullOuvertHand _ = 59
-- | calculate the modifier based on the game kind -- | calculate the modifier based on the game kind
modifierFactor :: Modifier -> Int modifierFactor :: Modifier -> Int
@@ -109,7 +144,7 @@ modifierFactor Schwarz = 3
modifierFactor Hand = 2 modifierFactor Hand = 2
modifierFactor HandSchneider = 3 modifierFactor HandSchneider = 3
modifierFactor HandSchneiderAngesagt = 4 modifierFactor HandSchneiderAngesagt = 4
modifierFactor HandSchneiderSchwarz = 4 modifierFactor HandSchwarz = 4
modifierFactor HandSchneiderAngesagtSchwarz = 5 modifierFactor HandSchneiderAngesagtSchwarz = 5
modifierFactor HandSchwarzAngesagt = 6 modifierFactor HandSchwarzAngesagt = 6
modifierFactor Ouvert = 7 modifierFactor Ouvert = 7
@@ -173,16 +208,36 @@ hasWon (Grand mod) ps = let (b, mod') = meetsCall mod ps
meetsCall :: Modifier -> Piles -> (Bool, Modifier) meetsCall :: Modifier -> Piles -> (Bool, Modifier)
meetsCall Hand ps = case wonByPoints ps of meetsCall Hand ps = case wonByPoints ps of
(b, Schneider) -> (b, HandSchneider) (b, Schneider) -> (b, HandSchneider)
(b, Schwarz) -> (b, HandSchneiderSchwarz) (b, Schwarz) -> (b, HandSchwarz)
(b, Einfach) -> (b, Hand) (b, Einfach) -> (b, Hand)
meetsCall Schneider ps = case wonByPoints ps of
(b, Schneider) -> (b, Schneider)
(b, Schwarz) -> (b, Schwarz)
(b, Einfach) -> (False, Schneider)
meetsCall Schwarz ps = case wonByPoints ps of
(b, Schneider) -> (False, Schwarz)
(b, Schwarz) -> (b, Schwarz)
(b, Einfach) -> (False, Schwarz)
meetsCall HandSchneider ps = case wonByPoints ps of
(b, Schneider) -> (b, HandSchneider)
(b, Schwarz) -> (b, HandSchwarz)
(b, Einfach) -> (False, HandSchneider)
meetsCall HandSchneiderAngesagt ps = case wonByPoints ps of meetsCall HandSchneiderAngesagt ps = case wonByPoints ps of
(b, Schneider) -> (b, HandSchneiderAngesagt) (b, Schneider) -> (b, HandSchneiderAngesagt)
(b, Schwarz) -> (b, HandSchneiderAngesagtSchwarz) (b, Schwarz) -> (b, HandSchneiderAngesagtSchwarz)
(b, Einfach) -> (False, HandSchneiderAngesagt) (b, Einfach) -> (False, HandSchneiderAngesagt)
meetsCall HandSchwarz ps = case wonByPoints ps of
(b, Schneider) -> (False, HandSchwarz)
(b, Schwarz) -> (b, HandSchwarz)
(b, Einfach) -> (False, HandSchwarz)
meetsCall HandSchwarzAngesagt ps = case wonByPoints ps of meetsCall HandSchwarzAngesagt ps = case wonByPoints ps of
(b, Schneider) -> (False, HandSchwarzAngesagt) (b, Schneider) -> (False, HandSchwarzAngesagt)
(b, Schwarz) -> (b, HandSchwarzAngesagt) (b, Schwarz) -> (b, HandSchwarzAngesagt)
(b, Einfach) -> (False, HandSchwarzAngesagt) (b, Einfach) -> (False, HandSchwarzAngesagt)
meetsCall Ouvert ps = case wonByPoints ps of
(b, Schneider) -> (False, Ouvert)
(b, Schwarz) -> (b, Ouvert)
(b, Einfach) -> (False, Ouvert)
meetsCall _ ps = wonByPoints ps meetsCall _ ps = wonByPoints ps
wonByPoints :: Piles -> (Bool, Modifier) wonByPoints :: Piles -> (Bool, Modifier)
@@ -195,10 +250,33 @@ wonByPoints ps
where (sgl, _) = count ps :: (Int, Int) where (sgl, _) = count ps :: (Int, Int)
-- | get result of game -- | get result of game
getResults :: Game -> Hand -> Piles -> Piles -> Result getResults :: Game -> Bid -> Hand -> Piles -> Piles -> Result
getResults game sglPlayer before after = Result afterGame score sglPoints teamPoints getResults game bid sglPlayer before after = case checkGame bid hand game of
where (won, afterGame) = hasWon game after Just game' -> let (won, afterGame) = hasWon game' after
hand = skatCards before ++ (map toCard $ handCards sglPlayer before) gameScore = biddingScore afterGame hand
score = if won then gameScore else (-2) * gameScore
in Result afterGame score sglPoints teamPoints
Nothing -> let gameScore = baseFactor game * ceiling (fromIntegral bid / fromIntegral (baseFactor game))
score = (-2) * gameScore
in Result game score sglPoints teamPoints
where hand = skatCards before ++ (map toCard $ handCards sglPlayer before)
(sglPoints, teamPoints) = count after (sglPoints, teamPoints) = count after
gameScore = biddingScore afterGame hand
score = if won then gameScore else (-2) * gameScore checkGame :: HasCard c => Bid -> [c] -> Game -> Maybe Game
checkGame bid cards game@(Colour col mod)
| biddingScore game cards >= bid = Just game
| otherwise = upgrade mod >>= \mod' -> checkGame bid cards (Colour col mod')
checkGame bid cards game@(Grand mod)
| biddingScore game cards >= bid = Just game
| otherwise = upgrade mod >>= \mod' -> checkGame bid cards (Grand mod')
checkGame bid cards game
| biddingScore game cards >= bid = Just game
| otherwise = Nothing
upgrade :: Modifier -> Maybe Modifier
upgrade Einfach = Just Schneider
upgrade Schneider = Just Schwarz
upgrade Hand = Just HandSchneider
upgrade HandSchneider = Just HandSchwarz
upgrade HandSchneiderAngesagt = Just HandSchneiderAngesagtSchwarz
upgrade _ = Nothing
src/Skat/Card.hs
+3 -1
View File
@@ -173,7 +173,9 @@ compareCards trump turnCol c1@(Card tp1 col1) c2@(Card tp2 col2) =
compareRender :: Trump -> Card -> Card -> Ordering compareRender :: Trump -> Card -> Card -> Ordering
compareRender trump c1@(Card tp1 col1) c2@(Card tp2 col2) = compareRender trump c1@(Card tp1 col1) c2@(Card tp2 col2) =
case (trp1, trp2) of case (trp1, trp2) of
(True, True) -> compare tp1 tp2 (True, True) -> case compare tp1 tp2 of
EQ -> compare col1 col2
v -> v
(False, False) -> case compare col1 col2 of (False, False) -> case compare col1 col2 of
EQ -> compare tp1 tp2 EQ -> compare tp1 tp2
v -> v v -> v
src/Skat/Matches.hs
+5 -4
View File
@@ -48,9 +48,9 @@ continue (UnfinishedGame skatEnv prepEnv tricks) comm1 comm2 comm3 = do
match :: PrepEnv -> IO (Either Unfinished (Maybe Match)) match :: PrepEnv -> IO (Either Unfinished (Maybe Match))
match prepEnv = do match prepEnv = do
maySkatEnv <- runReaderT runPreperation prepEnv (maySkatEnv, prepEnv') <- runStateT runPreperation prepEnv
case maySkatEnv of case maySkatEnv of
Just skatEnv -> runGame prepEnv skatEnv Just skatEnv -> runGame prepEnv' skatEnv
Nothing -> putStrLn "no one wanted to play" >> return (Right Nothing) Nothing -> putStrLn "no one wanted to play" >> return (Right Nothing)
runGame :: PrepEnv -> SkatEnv -> IO (Either Unfinished (Maybe Match)) runGame :: PrepEnv -> SkatEnv -> IO (Either Unfinished (Maybe Match))
@@ -69,6 +69,7 @@ runGame prepEnv skatEnv = do
if isFinished then do if isFinished then do
let res = getResults let res = getResults
(skatGame skatEnv) (skatGame skatEnv)
(Skat.Preperation.current prepEnv)
(skatSinglePlayer skatEnv) (skatSinglePlayer skatEnv)
(Skat.Preperation.piles prepEnv) (Skat.Preperation.piles prepEnv)
(Skat.piles finalEnv) (Skat.piles finalEnv)
@@ -111,7 +112,7 @@ singleWithBidding comm = do
(BD $ PrepOnline Hand1 comm h1) (BD $ PrepOnline Hand1 comm h1)
(BD $ NoBidder Hand2) (BD $ NoBidder Hand2)
(BD $ NoBidder Hand3) (BD $ NoBidder Hand3)
env = PrepEnv ps bs env = makePrep ps bs
void $ match env void $ match env
pvp :: Communicator c => c -> c -> c -> IO (Either Unfinished (Maybe Match)) pvp :: Communicator c => c -> c -> c -> IO (Either Unfinished (Maybe Match))
@@ -125,5 +126,5 @@ pvp comm1 comm2 comm3 = do
(BD $ PrepOnline Hand1 comm1 $ h1) (BD $ PrepOnline Hand1 comm1 $ h1)
(BD $ PrepOnline Hand2 comm2 $ h2) (BD $ PrepOnline Hand2 comm2 $ h2)
(BD $ PrepOnline Hand3 comm3 $ h3) (BD $ PrepOnline Hand3 comm3 $ h3)
env = PrepEnv ps bs env = makePrep ps bs
match env match env
src/Skat/Preperation.hs
+17 -18
View File
@@ -3,11 +3,11 @@
module Skat.Preperation ( module Skat.Preperation (
Bidder(..), Bid, BD(..), Bidders(..), PrepEnv(..), runPreperation, Bidder(..), Bid, BD(..), Bidders(..), PrepEnv(..), runPreperation,
publishGameResults, bidder publishGameResults, bidder, makePrep
) where ) where
import Control.Monad.IO.Class import Control.Monad.IO.Class
import Control.Monad.Reader import Control.Monad.State
import Skat.Pile import Skat.Pile
import Skat.Card import Skat.Card
@@ -15,13 +15,15 @@ import Skat.Player (PL, Players(..))
import Skat.Bidding import Skat.Bidding
import Skat (SkatEnv, mkSkatEnv) import Skat (SkatEnv, mkSkatEnv)
type Bid = Int
data PrepEnv = PrepEnv { piles :: Piles data PrepEnv = PrepEnv { piles :: Piles
, bidders :: Bidders } , bidders :: Bidders
, current :: Bid }
deriving Show deriving Show
type Preperation = ReaderT PrepEnv IO makePrep :: Piles -> Bidders -> PrepEnv
makePrep ps bd = PrepEnv ps bd 0
type Preperation = StateT PrepEnv IO
class Bidder a where class Bidder a where
hand :: a -> Hand hand :: a -> Hand
@@ -36,7 +38,7 @@ class Bidder a where
onBid _ _ _ _ = return () onBid _ _ _ _ = return ()
onResponse :: MonadIO m => a -> Bool -> Hand -> Hand -> m () onResponse :: MonadIO m => a -> Bool -> Hand -> Hand -> m ()
onResponse _ _ _ _ = return () onResponse _ _ _ _ = return ()
onGame :: MonadIO m => a -> Game -> Hand -> m () onGame :: MonadIO m => a -> HideGame -> Hand -> m ()
onGame _ _ _ = return () onGame _ _ _ = return ()
onResult :: MonadIO m => a -> Result -> m () onResult :: MonadIO m => a -> Result -> m ()
onResult _ _ = return () onResult _ _ = return ()
@@ -80,7 +82,7 @@ toPlayers single (Bidders b1 b2 b3) =
runPreperation :: Preperation (Maybe SkatEnv) runPreperation :: Preperation (Maybe SkatEnv)
runPreperation = do runPreperation = do
bds <- asks bidders bds <- gets bidders
onStart (bidder bds Hand1) onStart (bidder bds Hand1)
onStart (bidder bds Hand2) onStart (bidder bds Hand2)
onStart (bidder bds Hand3) onStart (bidder bds Hand3)
@@ -101,6 +103,7 @@ runBidding startingBid reizer gereizter = do
Just val Just val
| val > startingBid -> do | val > startingBid -> do
publishBid first (hand reizer) (hand gereizter) publishBid first (hand reizer) (hand gereizter)
modify $ \env -> env { current = val }
response <- askResponse gereizter (hand reizer) val response <- askResponse gereizter (hand reizer) val
publishResponse response (hand reizer) (hand gereizter) publishResponse response (hand reizer) (hand gereizter)
if response then runBidding val reizer gereizter if response then runBidding val reizer gereizter
@@ -114,8 +117,8 @@ runBidding startingBid reizer gereizter = do
initGame :: Hand -> Bid -> Preperation SkatEnv initGame :: Hand -> Bid -> Preperation SkatEnv
initGame single bid = do initGame single bid = do
ps <- asks piles ps <- gets piles
bds <- asks bidders bds <- gets bidders
-- ask if player wants to play hand -- ask if player wants to play hand
noSkat <- askHand (bidder bds single) bid noSkat <- askHand (bidder bds single) bid
-- either return piles or ask for skat cards and modify piles -- either return piles or ask for skat cards and modify piles
@@ -129,15 +132,11 @@ initGame single bid = do
handleGame :: BD -> Bid -> Bool -> Preperation Game handleGame :: BD -> Bid -> Bool -> Preperation Game
handleGame bd bid noSkat = do handleGame bd bid noSkat = do
cards <- (\ps -> map toCard (handCards (hand bd) ps) ++ skatCards ps) <$> gets piles
-- ask bidder for game -- ask bidder for game
proposal <- askGame bd bid proposal <- askGame bd bid
-- check if proposal is allowed -- check if proposal is allowed
case proposal of if isHand proposal == noSkat then return proposal else handleGame bd bid noSkat
g@(Colour col mod) -> if isHand mod == noSkat
then return g else handleGame bd bid noSkat
g@(Grand mod) -> if isHand mod == noSkat
then return g else handleGame bd bid noSkat
g -> return g
handleSkat :: BD -> Bid -> Piles -> Preperation Piles handleSkat :: BD -> Bid -> Piles -> Preperation Piles
handleSkat bd bid ps = do handleSkat bd bid ps = do
@@ -155,7 +154,7 @@ publishGameResults res bidders = do
onResult (bidder bidders Hand3) res onResult (bidder bidders Hand3) res
publishGameStart :: Game -> Hand -> Preperation () publishGameStart :: Game -> Hand -> Preperation ()
publishGameStart game sglPlayer = mapBidders (\b -> onGame b game sglPlayer) publishGameStart game sglPlayer = mapBidders (\b -> onGame b (HideGame game) sglPlayer)
publishBid :: Maybe Bid -> Hand -> Hand -> Preperation () publishBid :: Maybe Bid -> Hand -> Hand -> Preperation ()
publishBid bid reizer gereizter = mapBidders (\b -> onBid b bid reizer gereizter) publishBid bid reizer gereizter = mapBidders (\b -> onBid b bid reizer gereizter)
@@ -168,7 +167,7 @@ publishNoGame = mapBidders onNoGame
mapBidders :: (BD -> Preperation ()) -> Preperation () mapBidders :: (BD -> Preperation ()) -> Preperation ()
mapBidders f = do mapBidders f = do
bds <- asks bidders bds <- gets bidders
f (bidder bds Hand1) f (bidder bds Hand1)
f (bidder bds Hand2) f (bidder bds Hand2)
f (bidder bds Hand3) f (bidder bds Hand3)