From dd629db320f6034453f2b911235fb5fa7b9b9ca1 Mon Sep 17 00:00:00 2001 From: flavis Date: Tue, 7 Apr 2020 01:34:38 +0200 Subject: [PATCH] handle ueberreizung --- src/Skat/AI/Online.hs | 5 +- src/Skat/AI/Stupid.hs | 2 +- src/Skat/Bidding.hs | 116 +++++++++++++++++++++++++++++++++------- src/Skat/Card.hs | 4 +- src/Skat/Matches.hs | 9 ++-- src/Skat/Preperation.hs | 35 ++++++------ 6 files changed, 126 insertions(+), 45 deletions(-) diff --git a/src/Skat/AI/Online.hs b/src/Skat/AI/Online.hs index e5e47a3..509f7b8 100644 --- a/src/Skat/AI/Online.hs +++ b/src/Skat/AI/Online.hs @@ -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 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) r <- response 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]) | CardPlayedQuery (CardS Played) | GameResultsQuery Result - | GameStartQuery Game Hand + | GameStartQuery HideGame Hand | BidQuery Hand Bid | BidResponseQuery Hand Bid | AskGameQuery Bid diff --git a/src/Skat/AI/Stupid.hs b/src/Skat/AI/Stupid.hs index 77b22fd..9d225e2 100644 --- a/src/Skat/AI/Stupid.hs +++ b/src/Skat/AI/Stupid.hs @@ -29,7 +29,7 @@ newtype NoBidder = NoBidder Hand -- | no bidding from that player instance Bidder NoBidder where 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 askGame _ _ = return $ Grand Hand askHand _ _ = return True diff --git a/src/Skat/Bidding.hs b/src/Skat/Bidding.hs index f97b4b9..d80bab6 100644 --- a/src/Skat/Bidding.hs +++ b/src/Skat/Bidding.hs @@ -2,7 +2,7 @@ module Skat.Bidding ( biddingScore, Game(..), Modifier(..), isHand, getTrump, Result(..), - getResults, isOuvert, isSchwarz + getResults, isOuvert, isSchwarz, Bid, checkGame, HideGame(..) ) where import Data.Aeson hiding (Null, Result) @@ -13,6 +13,8 @@ import Data.Ord (Down(..)) import Control.Monad import Skat.Pile +type Bid = Int + -- | different game types data Game = Colour Colour Modifier | Grand Modifier @@ -22,6 +24,9 @@ data Game = Colour Colour Modifier | NullOuvertHand deriving (Show, Eq) +newtype HideGame = HideGame Game + deriving (Show, Eq) + instance ToJSON Game where toJSON (Grand mod) = object ["game" .= ("grand" :: String), "modifier" .= show mod] @@ -32,6 +37,13 @@ instance ToJSON Game where toJSON NullOuvert = object ["game" .= ("nullouvert" :: 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 parseJSON = withObject "Game" $ \v -> do gamekind <- v .: "game" @@ -56,7 +68,7 @@ data Modifier = Einfach | Hand | HandSchneider | HandSchneiderAngesagt - | HandSchneiderSchwarz + | HandSchwarz | HandSchneiderAngesagtSchwarz | HandSchwarzAngesagt | Ouvert @@ -76,11 +88,26 @@ instance FromJSON Modifier where _ -> return Hand else return Einfach -isHand :: Modifier -> Bool -isHand Einfach = False -isHand Schneider = False -isHand Schwarz = False -isHand _ = True +prettyShow :: Modifier -> String +prettyShow Schneider = show Einfach +prettyShow Schwarz = show Einfach +prettyShow HandSchneider = show Hand +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 NullOuvert = True @@ -89,6 +116,17 @@ isOuvert (Grand Ouvert) = True isOuvert (Colour _ Ouvert) = True 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 biddingScore :: HasCard c => Game -> [c] -> Int 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 Hearts mod) cards = (spitzen game cards + modifierFactor mod) * 10 biddingScore game@(Colour Diamonds mod) cards = (spitzen game cards + modifierFactor mod) * 9 -biddingScore Null _ = 23 -biddingScore NullHand _ = 35 -biddingScore NullOuvert _ = 46 -biddingScore NullOuvertHand _ = 59 +biddingScore game _ = baseFactor game -- | calculate the modifier based on the game kind modifierFactor :: Modifier -> Int @@ -109,7 +144,7 @@ modifierFactor Schwarz = 3 modifierFactor Hand = 2 modifierFactor HandSchneider = 3 modifierFactor HandSchneiderAngesagt = 4 -modifierFactor HandSchneiderSchwarz = 4 +modifierFactor HandSchwarz = 4 modifierFactor HandSchneiderAngesagtSchwarz = 5 modifierFactor HandSchwarzAngesagt = 6 modifierFactor Ouvert = 7 @@ -173,16 +208,36 @@ hasWon (Grand mod) ps = let (b, mod') = meetsCall mod ps meetsCall :: Modifier -> Piles -> (Bool, Modifier) meetsCall Hand ps = case wonByPoints ps of (b, Schneider) -> (b, HandSchneider) - (b, Schwarz) -> (b, HandSchneiderSchwarz) + (b, Schwarz) -> (b, HandSchwarz) (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 (b, Schneider) -> (b, HandSchneiderAngesagt) (b, Schwarz) -> (b, HandSchneiderAngesagtSchwarz) (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 (b, Schneider) -> (False, HandSchwarzAngesagt) (b, Schwarz) -> (b, 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 wonByPoints :: Piles -> (Bool, Modifier) @@ -195,10 +250,33 @@ wonByPoints ps where (sgl, _) = count ps :: (Int, Int) -- | get result of game -getResults :: Game -> Hand -> Piles -> Piles -> Result -getResults game sglPlayer before after = Result afterGame score sglPoints teamPoints - where (won, afterGame) = hasWon game after - hand = skatCards before ++ (map toCard $ handCards sglPlayer before) +getResults :: Game -> Bid -> Hand -> Piles -> Piles -> Result +getResults game bid sglPlayer before after = case checkGame bid hand game of + Just game' -> let (won, afterGame) = hasWon game' after + 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 - 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 diff --git a/src/Skat/Card.hs b/src/Skat/Card.hs index 2547305..d1c27d1 100644 --- a/src/Skat/Card.hs +++ b/src/Skat/Card.hs @@ -173,7 +173,9 @@ compareCards trump turnCol c1@(Card tp1 col1) c2@(Card tp2 col2) = compareRender :: Trump -> Card -> Card -> Ordering compareRender trump c1@(Card tp1 col1) c2@(Card tp2 col2) = 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 EQ -> compare tp1 tp2 v -> v diff --git a/src/Skat/Matches.hs b/src/Skat/Matches.hs index 232dcb4..46b02ed 100644 --- a/src/Skat/Matches.hs +++ b/src/Skat/Matches.hs @@ -48,9 +48,9 @@ continue (UnfinishedGame skatEnv prepEnv tricks) comm1 comm2 comm3 = do match :: PrepEnv -> IO (Either Unfinished (Maybe Match)) match prepEnv = do - maySkatEnv <- runReaderT runPreperation prepEnv + (maySkatEnv, prepEnv') <- runStateT runPreperation prepEnv case maySkatEnv of - Just skatEnv -> runGame prepEnv skatEnv + Just skatEnv -> runGame prepEnv' skatEnv Nothing -> putStrLn "no one wanted to play" >> return (Right Nothing) runGame :: PrepEnv -> SkatEnv -> IO (Either Unfinished (Maybe Match)) @@ -69,6 +69,7 @@ runGame prepEnv skatEnv = do if isFinished then do let res = getResults (skatGame skatEnv) + (Skat.Preperation.current prepEnv) (skatSinglePlayer skatEnv) (Skat.Preperation.piles prepEnv) (Skat.piles finalEnv) @@ -111,7 +112,7 @@ singleWithBidding comm = do (BD $ PrepOnline Hand1 comm h1) (BD $ NoBidder Hand2) (BD $ NoBidder Hand3) - env = PrepEnv ps bs + env = makePrep ps bs void $ match env 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 Hand2 comm2 $ h2) (BD $ PrepOnline Hand3 comm3 $ h3) - env = PrepEnv ps bs + env = makePrep ps bs match env diff --git a/src/Skat/Preperation.hs b/src/Skat/Preperation.hs index fd5e72d..c879682 100644 --- a/src/Skat/Preperation.hs +++ b/src/Skat/Preperation.hs @@ -3,11 +3,11 @@ module Skat.Preperation ( Bidder(..), Bid, BD(..), Bidders(..), PrepEnv(..), runPreperation, - publishGameResults, bidder + publishGameResults, bidder, makePrep ) where import Control.Monad.IO.Class -import Control.Monad.Reader +import Control.Monad.State import Skat.Pile import Skat.Card @@ -15,13 +15,15 @@ import Skat.Player (PL, Players(..)) import Skat.Bidding import Skat (SkatEnv, mkSkatEnv) -type Bid = Int - data PrepEnv = PrepEnv { piles :: Piles - , bidders :: Bidders } + , bidders :: Bidders + , current :: Bid } 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 hand :: a -> Hand @@ -36,7 +38,7 @@ class Bidder a where onBid _ _ _ _ = return () onResponse :: MonadIO m => a -> Bool -> Hand -> Hand -> m () onResponse _ _ _ _ = return () - onGame :: MonadIO m => a -> Game -> Hand -> m () + onGame :: MonadIO m => a -> HideGame -> Hand -> m () onGame _ _ _ = return () onResult :: MonadIO m => a -> Result -> m () onResult _ _ = return () @@ -80,7 +82,7 @@ toPlayers single (Bidders b1 b2 b3) = runPreperation :: Preperation (Maybe SkatEnv) runPreperation = do - bds <- asks bidders + bds <- gets bidders onStart (bidder bds Hand1) onStart (bidder bds Hand2) onStart (bidder bds Hand3) @@ -101,6 +103,7 @@ runBidding startingBid reizer gereizter = do Just val | val > startingBid -> do publishBid first (hand reizer) (hand gereizter) + modify $ \env -> env { current = val } response <- askResponse gereizter (hand reizer) val publishResponse response (hand reizer) (hand gereizter) if response then runBidding val reizer gereizter @@ -114,8 +117,8 @@ runBidding startingBid reizer gereizter = do initGame :: Hand -> Bid -> Preperation SkatEnv initGame single bid = do - ps <- asks piles - bds <- asks bidders + ps <- gets piles + bds <- gets 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 @@ -129,15 +132,11 @@ initGame single bid = do handleGame :: BD -> Bid -> Bool -> Preperation Game handleGame bd bid noSkat = do + cards <- (\ps -> map toCard (handCards (hand bd) ps) ++ skatCards ps) <$> gets piles -- ask bidder for game proposal <- askGame bd bid -- check if proposal is allowed - case proposal of - 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 + if isHand proposal == noSkat then return proposal else handleGame bd bid noSkat handleSkat :: BD -> Bid -> Piles -> Preperation Piles handleSkat bd bid ps = do @@ -155,7 +154,7 @@ publishGameResults res bidders = do onResult (bidder bidders Hand3) res 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 bid reizer gereizter = mapBidders (\b -> onBid b bid reizer gereizter) @@ -168,7 +167,7 @@ publishNoGame = mapBidders onNoGame mapBidders :: (BD -> Preperation ()) -> Preperation () mapBidders f = do - bds <- asks bidders + bds <- gets bidders f (bidder bds Hand1) f (bidder bds Hand2) f (bidder bds Hand3)