From fac461b75925902072d829a34956f74a41176ffe Mon Sep 17 00:00:00 2001 From: flavis Date: Mon, 6 Apr 2020 01:44:36 +0200 Subject: [PATCH] add ouvert games --- app/Main.hs | 12 +++---- app/TestEnvs.hs | 4 +-- package.yaml | 1 + skat.cabal | 5 ++- src/Skat.hs | 11 ++++--- src/Skat/AI/Human.hs | 2 +- src/Skat/AI/Online.hs | 23 ++++++++------ src/Skat/AI/Rulebased.hs | 6 ++-- src/Skat/AI/Stupid.hs | 2 +- src/Skat/Bidding.hs | 9 +++++- src/Skat/Matches.hs | 69 +++++++++++++++++++++++++++++++--------- src/Skat/Operations.hs | 50 +++++++++++++++++++++++------ src/Skat/Player.hs | 15 ++++++--- src/Skat/Preperation.hs | 10 +++--- 14 files changed, 157 insertions(+), 62 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index 1792811..342833f 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -47,11 +47,11 @@ runAI = do else runAI env :: SkatEnv -env = SkatEnv piles Nothing (Colour Spades Einfach) playersExamp Hand1 +env = SkatEnv piles Nothing (Colour Spades Einfach) playersExamp Hand1 Hand3 where piles = distribute allCards envStupid :: SkatEnv -envStupid = SkatEnv piles Nothing (Colour Spades Einfach) pls2 Hand1 +envStupid = SkatEnv piles Nothing (Colour Spades Einfach) pls2 Hand1 Hand3 where piles = distribute allCards playersExamp :: Players @@ -69,22 +69,22 @@ pls2 = Players shuffledEnv :: IO SkatEnv shuffledEnv = do cards <- shuffleCards - return $ SkatEnv (distribute cards) Nothing (Colour Spades Einfach) playersExamp Hand1 + return $ SkatEnv (distribute cards) Nothing (Colour Spades Einfach) playersExamp Hand1 Hand3 shuffledEnv2 :: IO SkatEnv shuffledEnv2 = do cards <- shuffleCards - return $ SkatEnv (distribute cards) Nothing (Colour Spades Einfach) pls2 Hand1 + return $ SkatEnv (distribute cards) Nothing (Colour Spades Einfach) pls2 Hand1 Hand3 env2 :: SkatEnv -env2 = SkatEnv piles Nothing (Colour Hearts Einfach) playersExamp Hand2 +env2 = SkatEnv piles Nothing (Colour Hearts Einfach) playersExamp Hand2 Hand3 where hand1 = [Card Eight Hearts, Card Queen Hearts, Card Ace Clubs, Card Queen Diamonds] hand2 = [Card Seven Hearts, Card King Hearts, Card Ten Hearts, Card Queen Spades] hand3 = [Card Seven Spades, Card King Spades, Card Ace Spades, Card Queen Clubs] piles = emptyPiles hand1 hand2 hand3 [] env3 :: SkatEnv -env3 = SkatEnv piles Nothing (Colour Diamonds Einfach) pls2 Hand3 +env3 = SkatEnv piles Nothing (Colour Diamonds Einfach) pls2 Hand3 Hand3 where hand1 = [ Card Jack Diamonds, Card Jack Clubs, Card Nine Spades, Card King Spades , Card Seven Diamonds, Card Nine Diamonds, Card Seven Clubs, Card Eight Clubs , Card Ten Clubs, Card Eight Hearts ] diff --git a/app/TestEnvs.hs b/app/TestEnvs.hs index cb86064..8604ea6 100644 --- a/app/TestEnvs.hs +++ b/app/TestEnvs.hs @@ -14,7 +14,7 @@ pls2 = Players (PL $ Stupid Single Hand3) env3 :: SkatEnv -env3 = SkatEnv piles Nothing (Colour Diamonds Einfach) pls2 Hand3 +env3 = SkatEnv piles Nothing (Colour Diamonds Einfach) pls2 Hand3 Hand3 where hand1 = [ Card Jack Diamonds, Card Jack Clubs, Card Nine Spades, Card King Spades , Card Seven Diamonds, Card Nine Diamonds, Card Seven Clubs, Card Eight Clubs , Card Ten Clubs, Card Eight Hearts ] @@ -29,4 +29,4 @@ env3 = SkatEnv piles Nothing (Colour Diamonds Einfach) pls2 Hand3 shuffledEnv2 :: IO SkatEnv shuffledEnv2 = do cards <- shuffleCards - return $ SkatEnv (distribute cards) Nothing (Colour Spades Einfach) pls2 Hand1 + return $ SkatEnv (distribute cards) Nothing (Colour Spades Einfach) pls2 Hand1 Hand3 diff --git a/package.yaml b/package.yaml index c9fa4be..ecec5c4 100644 --- a/package.yaml +++ b/package.yaml @@ -35,6 +35,7 @@ dependencies: - case-insensitive - vector - transformers +- exceptions library: source-dirs: src diff --git a/skat.cabal b/skat.cabal index fc82430..038af70 100644 --- a/skat.cabal +++ b/skat.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: a181979e99bc6631140cc5973d1714c0b5aa021f74c72938c0ee7ab47b581cf2 +-- hash: f2e3dd604c5fb3558a0a89d7551927574fb21db0892d1c2d70d401dd30807071 name: skat version: 0.1.0.7 @@ -56,6 +56,7 @@ library , case-insensitive , containers , deepseq + , exceptions , mtl , network , parallel @@ -82,6 +83,7 @@ executable skat-exe , case-insensitive , containers , deepseq + , exceptions , mtl , network , parallel @@ -109,6 +111,7 @@ test-suite skat-test , case-insensitive , containers , deepseq + , exceptions , mtl , network , parallel diff --git a/src/Skat.hs b/src/Skat.hs index 5ff06c2..9441bef 100644 --- a/src/Skat.hs +++ b/src/Skat.hs @@ -18,9 +18,10 @@ import qualified Skat.Player as P data SkatEnv = SkatEnv { piles :: Piles , turnColour :: Maybe TurnColour - , game :: Game + , skatGame :: Game , players :: Players - , currentHand :: Hand } + , currentHand :: Hand + , skatSinglePlayer :: Hand } deriving Show type Skat = StateT SkatEnv (WriterT [Trick] IO) @@ -37,11 +38,13 @@ execSkat :: Skat a -> SkatEnv -> IO SkatEnv execSkat action = (fmap fst) . runWriterT . execStateT action instance P.MonadPlayer Skat where - trump = gets $ getTrump . game + trump = getTrump <$> P.game turnColour = gets turnColour showSkat p = case P.team p of Single -> fmap (Just . skatCards) $ gets piles Team -> return Nothing + singlePlayer = gets skatSinglePlayer + game = gets skatGame instance P.MonadPlayerOpen Skat where showPiles = gets piles @@ -63,7 +66,7 @@ setTurnColour col sk = sk { turnColour = col } setCurrentHand :: Hand -> SkatEnv -> SkatEnv setCurrentHand hand sk = sk { currentHand = hand } -mkSkatEnv :: Piles -> Maybe TurnColour -> Game -> Players -> Hand -> SkatEnv +mkSkatEnv :: Piles -> Maybe TurnColour -> Game -> Players -> Hand -> Hand -> SkatEnv mkSkatEnv = SkatEnv allowedCards :: Skat [CardS Owner] diff --git a/src/Skat/AI/Human.hs b/src/Skat/AI/Human.hs index 4fef6fd..eed03ee 100644 --- a/src/Skat/AI/Human.hs +++ b/src/Skat/AI/Human.hs @@ -15,7 +15,7 @@ data Human = Human { getTeam :: Team instance Player Human where team = getTeam hand = getHand - chooseCard p table _ hand = do + chooseCard p table _ _ hand = do trumpCol <- trump turnCol <- turnColour let possible = filter (isAllowed trumpCol turnCol hand) hand diff --git a/src/Skat/AI/Online.hs b/src/Skat/AI/Online.hs index baade37..e5e47a3 100644 --- a/src/Skat/AI/Online.hs +++ b/src/Skat/AI/Online.hs @@ -47,7 +47,7 @@ instance Show (PrepOnline c) where instance Communicator c => Player (OnlineEnv c) where team = getTeam hand = getHand - chooseCard p table _ hand = runReaderT (choose table hand) p >>= \c -> return (c, p) + chooseCard p table _ mayOuvert hand = runReaderT (choose table mayOuvert hand) p >>= \c -> return (c, p) onCardPlayed p c = runReaderT (cardPlayed c) p >> return p instance Communicator c => Bidder (PrepOnline c) where @@ -112,24 +112,26 @@ instance MonadPlayer m => MonadPlayer (Online a m) where trump = lift $ trump turnColour = lift $ turnColour showSkat = lift . showSkat + singlePlayer = lift singlePlayer + game = lift game -choose :: HasCard a => (Communicator c, MonadPlayer m) => [CardS Played] -> [a] -> Online c m Card -choose table hand' = do +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' - query (BS.unpack $ encode $ ChooseQuery hand table) + query (BS.unpack $ encode $ ChooseQuery hand table $ fmap (map toCard) mayOuvert) r <- response case decode (BS.pack r) of Just (ChosenResponse card) -> do allowed <- P.isAllowed hand card - if card `elem` hand && allowed then return card else choose table hand' - Nothing -> choose table hand' + if card `elem` hand && allowed then return card else choose table mayOuvert hand' + Nothing -> choose table mayOuvert hand' cardPlayed :: (Communicator c, MonadPlayer m) => CardS Played -> Online c m () cardPlayed card = query (BS.unpack $ encode $ CardPlayedQuery card) -- | QUERIES AND RESPONSES -data Query = ChooseQuery [Card] [CardS Played] +data Query = ChooseQuery [Card] [CardS Played] (Maybe [Card]) | CardPlayedQuery (CardS Played) | GameResultsQuery Result | GameStartQuery Game Hand @@ -151,8 +153,9 @@ newtype GameResponse = GameResponse Game newtype ChosenCards = ChosenCards [Card] instance ToJSON Query where - toJSON (ChooseQuery hand table) = - object ["query" .= ("choose_card" :: String), "hand" .= hand, "table" .= table] + toJSON (ChooseQuery hand table mayOuvert) = + object [ "query" .= ("choose_card" :: String), "hand" .= hand, "table" .= table + , "single_hand" .= mayOuvert] toJSON (CardPlayedQuery card) = object ["query" .= ("card_played" :: String), "card" .= card] toJSON (GameResultsQuery result) = @@ -160,7 +163,7 @@ instance ToJSON Query where toJSON (GameStartQuery game sglPlayer) = object [ "query" .= ("start_game" :: String) , "game" .= game - , "single" .= toInt sglPlayer ] + , "single" .= show sglPlayer ] toJSON (BidQuery hand bid) = object ["query" .= ("bid" :: String), "whom" .= show hand, "current" .= bid] toJSON (BidResponseQuery hand bid) = diff --git a/src/Skat/AI/Rulebased.hs b/src/Skat/AI/Rulebased.hs index 3bce99d..18f1c1a 100644 --- a/src/Skat/AI/Rulebased.hs +++ b/src/Skat/AI/Rulebased.hs @@ -80,7 +80,7 @@ runWithPiles ps sim = runReaderT sim ps instance Player AIEnv where team = getTeam hand = getHand - chooseCard p table fallen hand = runStateT (do + chooseCard p table fallen _ hand = runStateT (do modify $ setTable table modify $ setHand (map toCard hand) modify $ setFallen fallen @@ -316,7 +316,7 @@ chooseSimulating = do (PL $ Stupid.Stupid Team Hand2) (PL $ Stupid.Stupid Single Hand3) -- TODO: fix - env = mkSkatEnv piles turnCol undefined ps myHand + env = mkSkatEnv piles turnCol undefined ps myHand undefined liftIO $ evalSkat (toCard <$> (Minmax.choose depth :: Skat (CardS Owner))) env simulate :: (MonadState AIEnv m, MonadPlayerOpen m) @@ -337,7 +337,7 @@ simulate card = do (PL $ mkAIEnv Team Hand2 newDepth) (PL $ mkAIEnv Single Hand3 newDepth) -- TODO: fix - env = mkSkatEnv piles turnCol undefined ps (next myHand) + env = mkSkatEnv piles turnCol undefined ps (next myHand) undefined -- simulate the game after playing the given card (sgl, tm) <- liftIO $ evalSkat (do modifyp $ playCard myHand card diff --git a/src/Skat/AI/Stupid.hs b/src/Skat/AI/Stupid.hs index aa63dba..77b22fd 100644 --- a/src/Skat/AI/Stupid.hs +++ b/src/Skat/AI/Stupid.hs @@ -16,7 +16,7 @@ data Stupid = Stupid { getTeam :: Team instance Player Stupid where team = getTeam hand = getHand - chooseCard p _ _ hand = do + chooseCard p _ _ _ hand = do trumpCol <- trump turnCol <- turnColour liftIO $ threadDelay 1000000 diff --git a/src/Skat/Bidding.hs b/src/Skat/Bidding.hs index 3e0f342..f97b4b9 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 + getResults, isOuvert, isSchwarz ) where import Data.Aeson hiding (Null, Result) @@ -82,6 +82,13 @@ isHand Schneider = False isHand Schwarz = False isHand _ = True +isOuvert :: Game -> Bool +isOuvert NullOuvert = True +isOuvert NullOuvertHand = True +isOuvert (Grand Ouvert) = True +isOuvert (Colour _ Ouvert) = True +isOuvert _ = False + -- | 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 diff --git a/src/Skat/Matches.hs b/src/Skat/Matches.hs index ad33d71..232dcb4 100644 --- a/src/Skat/Matches.hs +++ b/src/Skat/Matches.hs @@ -1,5 +1,5 @@ module Skat.Matches ( - singleVsBots, pvp, singleWithBidding, Match(..) + singleVsBots, pvp, singleWithBidding, Match(..), Unfinished(..), continue ) where import Control.Monad.State @@ -8,7 +8,7 @@ import System.Random (mkStdGen) import Skat import Skat.Operations -import Skat.Player +import Skat.Player as P import Skat.Pile import Skat.Card import Skat.Preperation @@ -24,20 +24,59 @@ data Match = Match { matchPiles :: Piles , matchSingle :: Hand } deriving Show -match :: PrepEnv -> IO (Maybe Match) +data Unfinished = UnfinishedGame { unfinishedGame :: SkatEnv + , unfinishedPrep :: PrepEnv + , unfinishedTricks :: [Trick] } + | UnfinishedPrep { unfinishedPrep :: PrepEnv } + deriving Show + +continue :: Communicator c => Unfinished -> c -> c -> c -> IO (Either Unfinished (Maybe Match)) +continue (UnfinishedGame skatEnv prepEnv tricks) comm1 comm2 comm3 = do + let ps = players skatEnv + ps' = Players + (PL $ OnlineEnv (P.team $ player ps Hand1) (P.hand $ player ps Hand1) comm1) + (PL $ OnlineEnv (P.team $ player ps Hand2) (P.hand $ player ps Hand2) comm2) + (PL $ OnlineEnv (P.team $ player ps Hand3) (P.hand $ player ps Hand3) comm3) + bs = bidders prepEnv + bs' = Bidders + (BD $ PrepOnline (Skat.Preperation.hand $ bidder bs Hand1) comm1 []) + (BD $ PrepOnline (Skat.Preperation.hand $ bidder bs Hand2) comm2 []) + (BD $ PrepOnline (Skat.Preperation.hand $ bidder bs Hand3) comm3 []) + skatEnv' = skatEnv { players = ps' } + prepEnv' = prepEnv { bidders = bs' } + runGame prepEnv' skatEnv' + +match :: PrepEnv -> IO (Either Unfinished (Maybe Match)) match prepEnv = do maySkatEnv <- runReaderT runPreperation prepEnv case maySkatEnv of - Just (sglPlayer, skatEnv) -> do - (_, finished, tricks) <- runSkat turn skatEnv - let res = getResults - (game skatEnv) - sglPlayer - (Skat.Preperation.piles prepEnv) - (Skat.piles finished) - publishGameResults res (bidders prepEnv) - return $ Just $ Match (Skat.Preperation.piles prepEnv) res tricks sglPlayer - Nothing -> putStrLn "no one wanted to play" >> return Nothing + Just skatEnv -> runGame prepEnv skatEnv + Nothing -> putStrLn "no one wanted to play" >> return (Right Nothing) + +runGame :: PrepEnv -> SkatEnv -> IO (Either Unfinished (Maybe Match)) +runGame prepEnv skatEnv = do + (isFinished, finalEnv, tricks) <- (flip runSkat) skatEnv $ do + -- send current table cards to clients + -- only relevant if this is a continued game + -- otherwise table is empty + table <- getp tableCards + ps <- playersToList <$> gets players + mapM_ (\card -> mapM_ (\p -> onCardPlayed p card) ps) (reverse table) + -- run game + turn + -- return if game has finished + gameOver + if isFinished then do + let res = getResults + (skatGame skatEnv) + (skatSinglePlayer skatEnv) + (Skat.Preperation.piles prepEnv) + (Skat.piles finalEnv) + publishGameResults res (bidders prepEnv) + return $ Right $ Just $ + Match (Skat.Preperation.piles prepEnv) res tricks (skatSinglePlayer skatEnv) + else do -- if not finished an error has occured, thus returning unfinished game state + return $ Left $ UnfinishedGame finalEnv prepEnv tricks -- | predefined card distribution for testing purposes cardDistr :: Piles @@ -60,7 +99,7 @@ singleVsBots comm = do (PL $ OnlineEnv Team Hand1 comm) (PL $ Stupid Team Hand2) (PL $ mkAIEnv Single Hand3 10) - env = SkatEnv (distribute cards) Nothing (Colour Spades Einfach) ps Hand1 + env = SkatEnv (distribute cards) Nothing (Colour Spades Einfach) ps Hand1 Hand3 void $ evalSkat turn env singleWithBidding :: Communicator c => c -> IO () @@ -75,7 +114,7 @@ singleWithBidding comm = do env = PrepEnv ps bs void $ match env -pvp :: Communicator c => c -> c -> c -> IO (Maybe Match) +pvp :: Communicator c => c -> c -> c -> IO (Either Unfinished (Maybe Match)) pvp comm1 comm2 comm3 = do cards <- shuffleCards let ps = distribute cards diff --git a/src/Skat/Operations.hs b/src/Skat/Operations.hs index 22e4e72..c89ca59 100644 --- a/src/Skat/Operations.hs +++ b/src/Skat/Operations.hs @@ -1,9 +1,11 @@ module Skat.Operations ( turn, turnGeneric, play, playOpen, - play_, sortRender, undo_ + play_, sortRender, undo_, gameOver ) where import Control.Monad.State +import Control.Monad.Catch +import Control.Exception hiding (catch, bracketOnError) import Control.Monad.Writer (tell) import System.Random (newStdGen, randoms) import Data.List @@ -14,8 +16,10 @@ import Skat import Skat.Card import Skat.Pile import Skat.Player (chooseCard, Players(..), Player(..), PL(..), - updatePlayer, playersToList, player, MonadPlayer, getSinglePlayer, trump) + updatePlayer, playersToList, player, MonadPlayer, getSinglePlayer, trump, game, + singlePlayer) import Skat.Utils (shuffle) +import Skat.Bidding play_ :: HasCard c => c -> Skat () play_ card = do @@ -43,19 +47,34 @@ turnGeneric playFunc depth = do table <- getp tableCards ps <- gets players let p = player ps n - over <- getp $ handEmpty n trCol <- trump case length table of - 0 -> playFunc p >> modify (setCurrentHand $ next n) >> turnGeneric playFunc depth + 0 -> do + catchAll + (do + playFunc p + modify (setCurrentHand $ next n) + turnGeneric playFunc depth) + (\_ -> countGame) 1 -> do modify $ setTurnColour (Just $ effectiveColour trCol $ head table) - playFunc p - modify (setCurrentHand $ next n) - turnGeneric playFunc depth - 2 -> playFunc p >> modify (setCurrentHand $ next n) >> turnGeneric playFunc depth + catchAll + (do + playFunc p + modify (setCurrentHand $ next n) + turnGeneric playFunc depth) + (\_ -> countGame) + 2 -> do + catchAll + (do + playFunc p + modify (setCurrentHand $ next n) + turnGeneric playFunc depth) + (\_ -> countGame) 3 -> do w <- evaluateTable + over <- gameOver if depth <= 1 || over then countGame else modify (setCurrentHand w) >> turnGeneric playFunc (depth - 1) @@ -86,7 +105,10 @@ play p = do trump <- trump cards <- getp $ handCards (hand p) fallen <- getp played - (card, p') <- chooseCard p table fallen cards + ouvert <- isOuvert <$> game + mayOuvert <- if ouvert then Just <$> (singlePlayer >>= getp . handCards) + else return Nothing + (card, p') <- chooseCard p table fallen mayOuvert cards modifyPlayers $ updatePlayer p' modifyp $ playCard (hand p) card ps <- fmap playersToList $ gets players @@ -101,3 +123,13 @@ playOpen p = do card <- chooseCardOpen p modifyp $ playCard (hand p) card return card + +gameOver :: Skat Bool +gameOver = do + tr <- trump + case tr of + None -> do + singleLost <- gets piles >>= return . not . (Single `isSchwarz`) + if singleLost then return True + else gets currentHand >>= getp . handCards >>= return . null + _ -> gets currentHand >>= getp . handCards >>= return . null diff --git a/src/Skat/Player.hs b/src/Skat/Player.hs index 37374e2..f6271b7 100644 --- a/src/Skat/Player.hs +++ b/src/Skat/Player.hs @@ -6,11 +6,14 @@ import Control.Monad.IO.Class import Skat.Card import Skat.Pile +import Skat.Bidding class (Monad m, MonadIO m) => MonadPlayer m where trump :: m Trump turnColour :: m (Maybe TurnColour) showSkat :: Player p => p -> m (Maybe [Card]) + singlePlayer :: m Hand + game :: m Game class (Monad m, MonadIO m, MonadPlayer m) => MonadPlayerOpen m where showPiles :: m (Piles) @@ -18,10 +21,11 @@ class (Monad m, MonadIO m, MonadPlayer m) => MonadPlayerOpen m where class Player p where team :: p -> Team hand :: p -> Hand - chooseCard :: (HasCard c, MonadPlayer m) + chooseCard :: (HasCard d, HasCard c, MonadPlayer m) => p -> [CardS Played] -> [CardS Played] + -> Maybe [d] -> [c] -> m (Card, p) onCardPlayed :: MonadPlayer m @@ -37,7 +41,10 @@ class Player p where let table = tableCards piles fallen = played piles myCards = handCards (hand p) piles - fst <$> chooseCard p table fallen myCards + ouvert <- isOuvert <$> game + mayOuvert <- if ouvert then Just <$> (singlePlayer >>= \hnd -> return $ handCards hnd piles) + else return Nothing + fst <$> chooseCard p table fallen mayOuvert myCards data PL = forall p. (Show p, Player p) => PL p @@ -47,8 +54,8 @@ instance Show PL where instance Player PL where team (PL p) = team p hand (PL p) = hand p - chooseCard (PL p) table fallen hand = do - (v, a) <- chooseCard p table fallen hand + chooseCard (PL p) table fallen mayOuvert hand = do + (v, a) <- chooseCard p table fallen mayOuvert hand return $ (v, PL a) onCardPlayed (PL p) card = do v <- onCardPlayed p card diff --git a/src/Skat/Preperation.hs b/src/Skat/Preperation.hs index 35827f7..fd5e72d 100644 --- a/src/Skat/Preperation.hs +++ b/src/Skat/Preperation.hs @@ -3,7 +3,7 @@ module Skat.Preperation ( Bidder(..), Bid, BD(..), Bidders(..), PrepEnv(..), runPreperation, - publishGameResults + publishGameResults, bidder ) where import Control.Monad.IO.Class @@ -78,7 +78,7 @@ toPlayers single (Bidders b1 b2 b3) = (toPlayer b2 $ if single == Hand2 then Single else Team) (toPlayer b3 $ if single == Hand3 then Single else Team) -runPreperation :: Preperation (Maybe (Hand, SkatEnv)) +runPreperation :: Preperation (Maybe SkatEnv) runPreperation = do bds <- asks bidders onStart (bidder bds Hand1) @@ -90,9 +90,9 @@ runPreperation = do bid <- askBid (bidder bds finalWinner) finalWinner 0 publishBid bid finalWinner finalWinner case bid of - Just val -> (Just . (finalWinner,)) <$> initGame finalWinner val + Just val -> Just <$> initGame finalWinner val Nothing -> publishNoGame >> return Nothing - else (Just . (finalWinner,)) <$> initGame finalWinner finalBid + else Just <$> initGame finalWinner finalBid runBidding :: Bid -> BD -> BD -> Preperation (Hand, Bid) runBidding startingBid reizer gereizter = do @@ -125,7 +125,7 @@ initGame single bid = do -- publish game start publishGameStart game single -- construct skat env - return $ mkSkatEnv ps' Nothing game (toPlayers single bds) Hand1 + return $ mkSkatEnv ps' Nothing game (toPlayers single bds) Hand1 single handleGame :: BD -> Bid -> Bool -> Preperation Game handleGame bd bid noSkat = do