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 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
src/Skat/AI/Stupid.hs
+1 -1
View File
@@ -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
src/Skat/Bidding.hs
+97 -19
View File
@@ -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
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 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
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 = 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
src/Skat/Preperation.hs
+17 -18
View File
@@ -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)