handle ueberreizung

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

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

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
+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 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 game                       _     = baseFactor game
-biddingScore NullHand                   _     = 35
-biddingScore NullOuvert                 _     = 46
-biddingScore NullOuvertHand             _     = 59
 
 -- | 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 -> 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)
-          (sglPoints, teamPoints) = count 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
+
+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

@@ -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

@@ -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

@@ -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
+    ps <- gets piles
-    bds <- asks bidders
+    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
+    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 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)