diff --git a/app/Main.hs b/app/Main.hs index 99fa6e4..51891d8 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -12,6 +12,7 @@ import Skat.Card import Skat.Operations import Skat.Player import Skat.Pile +import Skat.Bidding import Skat.AI.Stupid import Skat.AI.Online @@ -37,7 +38,7 @@ runAI = do env <- shuffledEnv let ps = piles env cs = handCards Hand3 ps - trs = filter (isTrump Spades) cs + trs = filter (isTrump $ TrumpColour Spades) cs if length trs >= 5 && any ((==32) . getID) cs then do pts <- fst <$> evalStateT turn env @@ -46,11 +47,11 @@ runAI = do else runAI env :: SkatEnv -env = SkatEnv piles Nothing Spades playersExamp Hand1 +env = SkatEnv piles Nothing (Colour Spades Einfach) playersExamp Hand1 where piles = distribute allCards envStupid :: SkatEnv -envStupid = SkatEnv piles Nothing Spades pls2 Hand1 +envStupid = SkatEnv piles Nothing (Colour Spades Einfach) pls2 Hand1 where piles = distribute allCards playersExamp :: Players @@ -68,22 +69,22 @@ pls2 = Players shuffledEnv :: IO SkatEnv shuffledEnv = do cards <- shuffleCards - return $ SkatEnv (distribute cards) Nothing Spades playersExamp Hand1 + return $ SkatEnv (distribute cards) Nothing (Colour Spades Einfach) playersExamp Hand1 shuffledEnv2 :: IO SkatEnv shuffledEnv2 = do cards <- shuffleCards - return $ SkatEnv (distribute cards) Nothing Spades pls2 Hand1 + return $ SkatEnv (distribute cards) Nothing (Colour Spades Einfach) pls2 Hand1 env2 :: SkatEnv -env2 = SkatEnv piles Nothing Hearts playersExamp Hand2 +env2 = SkatEnv piles Nothing (Colour Hearts Einfach) playersExamp Hand2 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 Diamonds pls2 Hand3 +env3 = SkatEnv piles Nothing (Colour Diamonds Einfach) pls2 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 2134fad..cb86064 100644 --- a/app/TestEnvs.hs +++ b/app/TestEnvs.hs @@ -5,6 +5,7 @@ import Skat.Card import Skat.Pile import Skat.Player import Skat.AI.Stupid +import Skat.Bidding pls2 :: Players pls2 = Players @@ -13,7 +14,7 @@ pls2 = Players (PL $ Stupid Single Hand3) env3 :: SkatEnv -env3 = SkatEnv piles Nothing Diamonds pls2 Hand3 +env3 = SkatEnv piles Nothing (Colour Diamonds Einfach) pls2 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 ] @@ -28,4 +29,4 @@ env3 = SkatEnv piles Nothing Diamonds pls2 Hand3 shuffledEnv2 :: IO SkatEnv shuffledEnv2 = do cards <- shuffleCards - return $ SkatEnv (distribute cards) Nothing Spades pls2 Hand1 + return $ SkatEnv (distribute cards) Nothing (Colour Spades Einfach) pls2 Hand1 diff --git a/package.yaml b/package.yaml index eafde5b..4866e6b 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: skat -version: 0.1.0.5 +version: 0.1.0.7 github: "githubuser/skat" license: BSD3 author: "flavis" diff --git a/skat.cabal b/skat.cabal index c6fc91f..e53ca43 100644 --- a/skat.cabal +++ b/skat.cabal @@ -4,10 +4,10 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 625d9f93a3dec23993347bdccc3746fdf28ac4b67c85ec04a99f505ff61a171f +-- hash: 9c412ae20820c69f342fb431118c3d2be6a5461e1b5a521d92c1546f163ee94a name: skat -version: 0.1.0.5 +version: 0.1.0.7 description: Please see the README on Gitea at homepage: https://github.com/githubuser/skat#readme bug-reports: https://github.com/githubuser/skat/issues diff --git a/src/Skat.hs b/src/Skat.hs index 1f83ada..1a7e2f5 100644 --- a/src/Skat.hs +++ b/src/Skat.hs @@ -10,13 +10,14 @@ import Data.List import Data.Vector (Vector) import Skat.Card +import Skat.Bidding import Skat.Pile import Skat.Player (Players) import qualified Skat.Player as P data SkatEnv = SkatEnv { piles :: Piles - , turnColour :: Maybe Colour - , trumpColour :: Colour + , turnColour :: Maybe TurnColour + , game :: Game , players :: Players , currentHand :: Hand } deriving Show @@ -24,7 +25,7 @@ data SkatEnv = SkatEnv { piles :: Piles type Skat = StateT SkatEnv IO instance P.MonadPlayer Skat where - trumpColour = gets trumpColour + trump = gets $ getTrump . game turnColour = gets turnColour showSkat p = case P.team p of Single -> fmap (Just . skatCards) $ gets piles @@ -44,19 +45,19 @@ modifyPlayers :: (Players -> Players) -> Skat () modifyPlayers f = modify g where g env@(SkatEnv {players}) = env { players = f players } -setTurnColour :: Maybe Colour -> SkatEnv -> SkatEnv +setTurnColour :: Maybe TurnColour -> SkatEnv -> SkatEnv setTurnColour col sk = sk { turnColour = col } setCurrentHand :: Hand -> SkatEnv -> SkatEnv setCurrentHand hand sk = sk { currentHand = hand } -mkSkatEnv :: Piles -> Maybe Colour -> Colour -> Players -> Hand -> SkatEnv +mkSkatEnv :: Piles -> Maybe TurnColour -> Game -> Players -> Hand -> SkatEnv mkSkatEnv = SkatEnv allowedCards :: Skat [CardS Owner] allowedCards = do curHand <- gets currentHand pls <- gets players - turnCol <- gets turnColour - trumpCol <- gets trumpColour + turnCol <- P.turnColour + trumpCol <- P.trump getp $ allowed curHand trumpCol turnCol diff --git a/src/Skat/AI/Human.hs b/src/Skat/AI/Human.hs index cec6e60..4fef6fd 100644 --- a/src/Skat/AI/Human.hs +++ b/src/Skat/AI/Human.hs @@ -16,7 +16,7 @@ instance Player Human where team = getTeam hand = getHand chooseCard p table _ hand = do - trumpCol <- trumpColour + trumpCol <- trump turnCol <- turnColour let possible = filter (isAllowed trumpCol turnCol hand) hand c <- liftIO $ askIO (map getCard table) (map toCard possible) (map toCard hand) diff --git a/src/Skat/AI/Online.hs b/src/Skat/AI/Online.hs index 919e075..1e3bee3 100644 --- a/src/Skat/AI/Online.hs +++ b/src/Skat/AI/Online.hs @@ -6,7 +6,7 @@ module Skat.AI.Online where import Control.Monad.Reader import Control.Concurrent.Chan -import Data.Aeson +import Data.Aeson hiding (Result) import Data.Maybe import qualified Data.ByteString.Lazy.Char8 as BS @@ -49,8 +49,6 @@ instance Communicator c => Player (OnlineEnv c) where hand = getHand chooseCard p table _ hand = runReaderT (choose table hand) p >>= \c -> return (c, p) onCardPlayed p c = runReaderT (cardPlayed c) p >> return p - onGameResults p res = runReaderT (onResults res) p - onGameStart p singlePlayer = runReaderT (onStartOnline singlePlayer) p instance Communicator c => Bidder (PrepOnline c) where hand = prepHand @@ -87,8 +85,12 @@ instance Communicator c => Bidder (PrepOnline c) where Nothing -> askSkat p bid cards toPlayer p tm = PL $ OnlineEnv tm (prepHand p) (prepConnection p) onStart p = do - let cards = prepCards p + let cards = sortRender Jacks $ prepCards p liftIO $ send (prepConnection p) (BS.unpack $ encode $ CardsQuery cards) + onResult p res = + liftIO $ send (prepConnection p) (BS.unpack $ encode $ GameResultsQuery res) + onGame p game sglPlayer = do + liftIO $ send (prepConnection p) (BS.unpack $ encode $ GameStartQuery game sglPlayer) type Online a m = ReaderT (OnlineEnv a) m @@ -101,13 +103,13 @@ instance (Communicator c, MonadIO m) => MonadClient (Online c m) where liftIO $ receive conn instance MonadPlayer m => MonadPlayer (Online a m) where - trumpColour = lift $ trumpColour + trump = lift $ trump turnColour = lift $ turnColour showSkat = lift . showSkat choose :: HasCard a => (Communicator c, MonadPlayer m) => [CardS Played] -> [a] -> Online c m Card choose table hand' = do - let hand = map toCard hand' + let hand = sortRender Jacks $ map toCard hand' query (BS.unpack $ encode $ ChooseQuery hand table) r <- response case decode (BS.pack r) of @@ -119,21 +121,12 @@ choose table hand' = do cardPlayed :: (Communicator c, MonadPlayer m) => CardS Played -> Online c m () cardPlayed card = query (BS.unpack $ encode $ CardPlayedQuery card) -onResults :: (Communicator c, MonadIO m) => (Int, Int) -> Online c m () -onResults (sgl, tm) = query (BS.unpack $ encode $ GameResultsQuery sgl tm) - -onStartOnline :: (Communicator c, MonadPlayer m) => Hand -> Online c m () -onStartOnline singlePlayer = do - trCol <- trumpColour - ownHand <- asks getHand - query (BS.unpack $ encode $ GameStartQuery trCol ownHand singlePlayer) - -- | QUERIES AND RESPONSES data Query = ChooseQuery [Card] [CardS Played] | CardPlayedQuery (CardS Played) - | GameResultsQuery Int Int - | GameStartQuery Colour Hand Hand + | GameResultsQuery Result + | GameStartQuery Game Hand | BidQuery Hand Bid | BidResponseQuery Hand Bid | AskGameQuery Bid @@ -153,15 +146,16 @@ instance ToJSON Query where object ["query" .= ("choose_card" :: String), "hand" .= hand, "table" .= table] toJSON (CardPlayedQuery card) = object ["query" .= ("card_played" :: String), "card" .= card] - toJSON (GameResultsQuery sgl tm) = - object ["query" .= ("results" :: String), "single" .= sgl, "team" .= tm] - toJSON (GameStartQuery trumps handNo sglPlayer) = - object ["query" .= ("start_game" :: String), "trumps" .= show trumps, - "hand" .= toInt handNo, "single" .= toInt sglPlayer ] + toJSON (GameResultsQuery result) = + object ["query" .= ("results" :: String), "result" .= result] + toJSON (GameStartQuery game sglPlayer) = + object [ "query" .= ("start_game" :: String) + , "game" .= game + , "single" .= toInt sglPlayer ] toJSON (BidQuery hand bid) = object ["query" .= ("bid" :: String), "whom" .= show hand, "current" .= bid] toJSON (BidResponseQuery hand bid) = - object ["query" .= ("bid_response" :: String), "from" .= show hand ] + object ["query" .= ("bid_response" :: String), "from" .= show hand, "bid" .= bid ] toJSON (AskHandQuery) = object ["query" .= ("play_hand" :: String)] toJSON (AskSkatQuery cards bid) = diff --git a/src/Skat/AI/Rulebased.hs b/src/Skat/AI/Rulebased.hs index 0290f8e..b23ce00 100644 --- a/src/Skat/AI/Rulebased.hs +++ b/src/Skat/AI/Rulebased.hs @@ -26,6 +26,7 @@ import Skat (Skat, modifyp, mkSkatEnv) import Skat.Operations import qualified Skat.AI.Minmax as Minmax import qualified Skat.AI.Stupid as Stupid (Stupid(..)) +import Skat.Bidding data AIEnv = AIEnv { getTeam :: Team , getHand :: Hand @@ -55,8 +56,8 @@ modifyg f = modify g type AI m = StateT AIEnv m instance MonadPlayer m => MonadPlayer (AI m) where - trumpColour = lift $ trumpColour - turnColour = lift $ turnColour + trump = lift trump + turnColour = lift turnColour showSkat = lift . showSkat instance MonadPlayerOpen m => MonadPlayerOpen (AI m) where @@ -65,7 +66,7 @@ instance MonadPlayerOpen m => MonadPlayerOpen (AI m) where type Simulator m = ReaderT Piles (AI m) instance MonadPlayer m => MonadPlayer (Simulator m) where - trumpColour = lift $ trumpColour + trump = lift trump turnColour = lift $ turnColour showSkat = lift . showSkat @@ -112,15 +113,15 @@ has hand cs = M.mapWithKey f | card `elem` cs = [H hand] | otherwise = hands -hasNoLonger :: MonadPlayer m => Hand -> Colour -> AI m () +hasNoLonger :: MonadPlayer m => Hand -> TurnColour -> AI m () hasNoLonger hand colour = do - trCol <- trumpColour + trCol <- trump modifyg $ hasNoLonger_ trCol hand colour -hasNoLonger_ :: Colour -> Hand -> Colour -> Guess -> Guess -hasNoLonger_ trColour hand effCol = M.mapWithKey f +hasNoLonger_ :: Trump -> Hand -> TurnColour -> Guess -> Guess +hasNoLonger_ trump hand effCol = M.mapWithKey f where f card hands - | effectiveColour trColour card == effCol && (H hand) `elem` hands = filter (/=H hand) hands + | effectiveColour trump card == effCol && (H hand) `elem` hands = filter (/=H hand) hands | otherwise = hands isSkat :: [Card] -> Guess -> Guess @@ -136,7 +137,7 @@ analyzeTurn (c1, c2, c3) = do modifyg (getCard c1 `hasBeenPlayed`) modifyg (getCard c2 `hasBeenPlayed`) modifyg (getCard c3 `hasBeenPlayed`) - trCol <- trumpColour + trCol <- trump let turnCol = getColour $ getCard c1 demanded = effectiveColour trCol (getCard c1) col2 = effectiveColour trCol (getCard c2) @@ -218,7 +219,7 @@ onPlayed :: MonadPlayer m => CardS Played -> AI m () onPlayed c = do liftIO $ print c modifyg (getCard c `hasBeenPlayed`) - trCol <- trumpColour + trCol <- trump turnCol <- turnColour let col = effectiveColour trCol (getCard c) case turnCol of @@ -308,13 +309,14 @@ chooseSimulating :: (MonadState AIEnv m, MonadPlayerOpen m) chooseSimulating = do piles <- showPiles turnCol <- turnColour - trumpCol <- trumpColour + trumpCol <- trump myHand <- gets getHand depth <- gets simulationDepth let ps = Players (PL $ Stupid.Stupid Team Hand1) (PL $ Stupid.Stupid Team Hand2) (PL $ Stupid.Stupid Single Hand3) - env = mkSkatEnv piles turnCol trumpCol ps myHand + -- TODO: fix + env = mkSkatEnv piles turnCol undefined ps myHand liftIO $ evalStateT (toCard <$> (Minmax.choose depth :: Skat (CardS Owner))) env simulate :: (MonadState AIEnv m, MonadPlayerOpen m) @@ -323,7 +325,7 @@ simulate card = do -- retrieve all relevant info piles <- showPiles turnCol <- turnColour - trumpCol <- trumpColour + trumpCol <- trump myTeam <- gets getTeam myHand <- gets getHand depth <- gets simulationDepth @@ -334,7 +336,8 @@ simulate card = do (PL $ mkAIEnv Team Hand1 newDepth) (PL $ mkAIEnv Team Hand2 newDepth) (PL $ mkAIEnv Single Hand3 newDepth) - env = mkSkatEnv piles turnCol trumpCol ps (next myHand) + -- TODO: fix + env = mkSkatEnv piles turnCol undefined ps (next myHand) -- simulate the game after playing the given card (sgl, tm) <- liftIO $ evalStateT (do modifyp $ playCard myHand card @@ -357,7 +360,7 @@ predictValue (own, others) = do potential :: (MonadState AIEnv m, MonadPlayerOpen m, HasCard c) => [c] -> m Int potential cs = do - tr <- trumpColour + tr <- trump let trs = filter (isTrump tr) cs value = count . map toCard $ cs positions <- filter (==0) <$> mapM (position . toCard) cs @@ -366,7 +369,7 @@ potential cs = do position :: (MonadState AIEnv m, MonadPlayer m) => Card -> m Int position card = do - tr <- trumpColour + tr <- trump guess <- gets guess let effCol = effectiveColour tr card l = M.toList guess diff --git a/src/Skat/AI/Stupid.hs b/src/Skat/AI/Stupid.hs index 33a4508..f8a29a1 100644 --- a/src/Skat/AI/Stupid.hs +++ b/src/Skat/AI/Stupid.hs @@ -4,6 +4,7 @@ import Skat.Player import Skat.Pile import Skat.Card import Skat.Preperation +import Skat.Bidding data Stupid = Stupid { getTeam :: Team , getHand :: Hand } @@ -13,7 +14,7 @@ instance Player Stupid where team = getTeam hand = getHand chooseCard p _ _ hand = do - trumpCol <- trumpColour + trumpCol <- trump turnCol <- turnColour let possible = filter (isAllowed trumpCol turnCol hand) hand return (toCard $ head possible, p) @@ -24,10 +25,10 @@ newtype NoBidder = NoBidder Hand -- | no bidding from that player instance Bidder NoBidder where hand (NoBidder h) = h - askBid _ _ _ = return Nothing - askResponse _ _ _ = return False - askGame _ _ = undefined -- never called - askHand _ _ = return False -- never called + askBid _ _ bid = return $ Just 20 + askResponse _ _ bid = if bid < 24 then return True else return False + askGame _ _ = return $ Grand Hand + askHand _ _ = return True askSkat _ _ _ = undefined -- never called toPlayer (NoBidder h) team = PL $ Stupid team h onStart _ = return () diff --git a/src/Skat/Bidding.hs b/src/Skat/Bidding.hs index 6b5191f..365daa2 100644 --- a/src/Skat/Bidding.hs +++ b/src/Skat/Bidding.hs @@ -1,15 +1,17 @@ {-# LANGUAGE OverloadedStrings #-} module Skat.Bidding ( - biddingScore, Game(..), Modifier(..), isHand + biddingScore, Game(..), Modifier(..), isHand, getTrump, Result(..), + getResults ) where -import Data.Aeson hiding (Null) +import Data.Aeson hiding (Null, Result) import Skat.Card import Data.List (sortOn) import Data.Ord (Down(..)) import Control.Monad +import Skat.Pile -- | different game types data Game = Colour Colour Modifier @@ -20,6 +22,16 @@ data Game = Colour Colour Modifier | NullOuvertHand deriving (Show, Eq) +instance ToJSON Game where + toJSON (Grand mod) = + object ["game" .= ("grand" :: String), "modifier" .= show mod] + toJSON (Colour col mod) = + object ["game" .= ("colour" :: String), "modifier" .= show mod, "colour" .= show col] + toJSON Null = object ["game" .= ("null" :: String)] + toJSON NullHand = object ["game" .= ("nullhand" :: String)] + toJSON NullOuvert = object ["game" .= ("nullouvert" :: String)] + toJSON NullOuvertHand = object ["game" .= ("nullouverthand" :: String)] + instance FromJSON Game where parseJSON = withObject "Game" $ \v -> do gamekind <- v .: "game" @@ -118,6 +130,65 @@ spitzen game cards -- | get all trumps for a given game out of a hand of cards getTrumps :: HasCard c => Game -> [c] -> [Card] -getTrumps (Grand _) cards = sortOn Down $ filter ((==Jack) . getType) $ map toCard cards -getTrumps (Colour col _) cards = sortOn Down $ filter (isTrump col) $ map toCard cards +getTrumps (Grand _) cards = sortOn Down $ filter (isTrump Jacks) $ map toCard cards +getTrumps (Colour col _) cards = sortOn Down $ filter (isTrump $ TrumpColour col) $ map toCard cards getTrumps _ _ = [] + +-- | get trump for a given game +getTrump :: Game -> Trump +getTrump (Colour col _) = TrumpColour col +getTrump (Grand _) = Jacks +getTrump _ = None + +data Result = Result Game Int Int Int + deriving (Show, Eq) + +instance ToJSON Result where + toJSON (Result game points sgl tm) = + object ["game" .= game, "points" .= points, "single" .= sgl, "team" .= tm] + +isSchwarz :: Team -> Piles -> Bool +isSchwarz tm = null . wonCards tm + +hasWon :: Game -> Piles -> (Bool, Game) +hasWon Null ps = (Single `isSchwarz` ps, Null) +hasWon NullHand ps = (Single `isSchwarz` ps, NullHand) +hasWon NullOuvert ps = (Single `isSchwarz` ps, NullOuvert) +hasWon NullOuvertHand ps = (Single `isSchwarz` ps, NullOuvertHand) +hasWon (Colour col mod) ps = let (b, mod') = meetsCall mod ps + in (b, Colour col mod') +hasWon (Grand mod) ps = let (b, mod') = meetsCall mod ps + in (b, Grand mod') + +meetsCall :: Modifier -> Piles -> (Bool, Modifier) +meetsCall Hand ps = case wonByPoints ps of + (b, Schneider) -> (b, HandSchneider) + (b, Schwarz) -> (b, HandSchneiderSchwarz) + (b, Einfach) -> (b, Hand) +meetsCall HandSchneiderAngesagt ps = case wonByPoints ps of + (b, Schneider) -> (b, HandSchneiderAngesagt) + (b, Schwarz) -> (b, HandSchneiderAngesagtSchwarz) + (b, Einfach) -> (False, HandSchneiderAngesagt) +meetsCall HandSchwarzAngesagt ps = case wonByPoints ps of + (b, Schneider) -> (False, HandSchwarzAngesagt) + (b, Schwarz) -> (b, HandSchwarzAngesagt) + (b, Einfach) -> (False, HandSchwarzAngesagt) +meetsCall _ ps = wonByPoints ps + +wonByPoints :: Piles -> (Bool, Modifier) +wonByPoints ps + | Team `isSchwarz` ps = (True, Schwarz) + | sgl >= 90 = (True, Schneider) + | Single `isSchwarz` ps = (False, Schwarz) + | sgl <= 30 = (False, Schneider) + | otherwise = (sgl > 60, Einfach) + 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) + (sglPoints, teamPoints) = count after + gameScore = biddingScore afterGame hand + score = if won then gameScore else (-2) * gameScore diff --git a/src/Skat/Card.hs b/src/Skat/Card.hs index 062bdff..2ac33eb 100644 --- a/src/Skat/Card.hs +++ b/src/Skat/Card.hs @@ -31,6 +31,16 @@ data Type = Seven | Jack deriving (Eq, Ord, Show, Enum, Read) +data NullType = NSeven + | NEight + | NNine + | NTen + | NJack + | NQueen + | NKing + | NAce + deriving (Eq, Ord, Show, Enum, Read) + instance Countable Type Int where count Ace = 11 count Ten = 10 @@ -45,6 +55,15 @@ data Colour = Diamonds | Clubs deriving (Eq, Ord, Show, Enum, Read) +data Trump = TrumpColour Colour + | Jacks + | None + deriving (Show, Eq) + +data TurnColour = TurnColour Colour + | Trump + deriving (Show, Eq) + data Card = Card Type Colour deriving (Eq, Show, Ord, Read) @@ -98,50 +117,85 @@ instance Countable (S.Set Card) Int where instance NFData Card where rnf (Card t c) = t `seq` c `seq` () -equals :: Colour -> Maybe Colour -> Bool +equals :: TurnColour -> Maybe TurnColour -> Bool equals col (Just x) = col == x equals col Nothing = True -isTrump :: HasCard c => Colour -> c -> Bool -isTrump trumpCol crd +isTrump :: HasCard c => Trump -> c -> Bool +isTrump None crd = False +isTrump Jacks crd = getType (toCard crd) == Jack +isTrump (TrumpColour trumpCol) crd | getType (toCard crd) == Jack = True | otherwise = getColour (toCard crd) == trumpCol -effectiveColour :: HasCard c => Colour -> c -> Colour -effectiveColour trumpCol crd = if trump then trumpCol else getColour (toCard crd) - where trump = isTrump trumpCol crd +effectiveColour :: HasCard c => Trump -> c -> TurnColour +effectiveColour trump card + | isTrump trump card = Trump + | otherwise = TurnColour $ getColour (toCard card) -isAllowed :: (Foldable t, HasCard c1, HasCard c2) => Colour -> Maybe Colour -> t c1 -> c2 -> Bool -isAllowed trumpCol turnCol cs crd = +isAllowed :: (Foldable t, HasCard c1, HasCard c2) => Trump -> Maybe TurnColour -> t c1 -> c2 -> Bool +isAllowed trump turnCol cs crd = if col `equals` turnCol then True - else not $ F.any (\ca -> effectiveColour trumpCol ca `equals` turnCol && toCard ca /= toCard crd) cs - where col = effectiveColour trumpCol (toCard crd) + else not $ F.any (\ca -> effectiveColour trump ca `equals` turnCol && toCard ca /= toCard crd) cs + where col = effectiveColour trump (toCard crd) -compareCards :: Colour - -> Maybe Colour +compareCards :: Trump + -> Maybe TurnColour -> Card -> Card -> Ordering compareCards _ _ (Card Jack col1) (Card Jack col2) = compare col1 col2 -compareCards trumpCol turnCol c1@(Card tp1 col1) c2@(Card tp2 col2) = +compareCards trump turnCol c1@(Card tp1 col1) c2@(Card tp2 col2) = case (trp1, trp2) of (True, True) -> compare tp1 tp2 - (False, False) -> case compare (col1 `equals` turnCol) - (col2 `equals` turnCol) of - EQ -> compare tp1 tp2 - v -> v + (False, False) -> case ( effectiveColour trump c1 `equals` turnCol + , effectiveColour trump c2 `equals` turnCol ) of + (True, True) -> compareTypes trump tp1 tp2 + (True, False) -> GT + (False, True) -> LT + _ -> EQ _ -> compare trp1 trp2 - where trp1 = isTrump trumpCol c1 - trp2 = isTrump trumpCol c2 + where trp1 = isTrump trump c1 + trp2 = isTrump trump c2 -sortCards :: HasCard c => Colour -> Maybe Colour -> [c] -> [c] -sortCards trumpCol turnCol cs = sortBy f cs - where f c1 c2 = compareCards trumpCol turnCol (toCard c1) (toCard c2) +compareRender :: Trump -> Card -> Card -> Ordering +compareRender trump c1@(Card tp1 col1) c2@(Card tp2 col2) = + case (trp1, trp2) of + (True, True) -> compare tp1 tp2 + (False, False) -> case compare col1 col2 of + EQ -> compare tp1 tp2 + v -> v + _ -> compare trp1 trp2 + where trp1 = isTrump trump c1 + trp2 = isTrump trump c2 -highestCard :: HasCard c => Colour -> Maybe Colour -> [c] -> c -highestCard trumpCol turnCol cs = maximumBy f cs - where f c1 c2 = compareCards trumpCol turnCol (toCard c1) (toCard c2) +compareTypes :: Trump + -> Type + -> Type + -> Ordering +compareTypes None tp1 tp2 = compare (toNullType tp1) (toNullType tp2) + where toNullType Seven = NSeven + toNullType Eight = NEight + toNullType Nine = NNine + toNullType Ten = NTen + toNullType Jack = NJack + toNullType Queen = NQueen + toNullType King = NKing + toNullType Ace = NAce +compareTypes _ tp1 tp2 = compare tp1 tp2 + +sortCards :: HasCard c => Trump -> Maybe TurnColour -> [c] -> [c] +sortCards trump turnCol cs = sortBy f cs + where f c1 c2 = compareCards trump turnCol (toCard c1) (toCard c2) + +sortRender :: HasCard c => Trump -> [c] -> [c] +sortRender trump cs = sortBy f cs + where f c1 c2 = compareRender trump (toCard c2) (toCard c1) + +highestCard :: HasCard c => Trump -> Maybe TurnColour -> [c] -> c +highestCard trump turnCol cs = maximumBy f cs + where f c1 c2 = compareCards trump turnCol (toCard c1) (toCard c2) shuffleCards :: IO [Card] shuffleCards = do diff --git a/src/Skat/Matches.hs b/src/Skat/Matches.hs index e01ae98..bb1044a 100644 --- a/src/Skat/Matches.hs +++ b/src/Skat/Matches.hs @@ -1,5 +1,5 @@ module Skat.Matches ( - singleVsBots, pvp, pvpWithBidding, singleWithBidding + singleVsBots, pvp, singleWithBidding ) where import Control.Monad.State @@ -12,11 +12,26 @@ import Skat.Player import Skat.Pile import Skat.Card import Skat.Preperation +import Skat.Bidding import Skat.AI.Rulebased import Skat.AI.Online import Skat.AI.Stupid +match :: PrepEnv -> IO () +match prepEnv = do + maySkatEnv <- runReaderT runPreperation prepEnv + case maySkatEnv of + Just (sglPlayer, skatEnv) -> do + finished <- execStateT turn skatEnv + let res = getResults + (game skatEnv) + sglPlayer + (Skat.piles skatEnv) + (Skat.piles finished) + publishGameResults res (bidders prepEnv) + Nothing -> putStrLn "no one wanted to play" + -- | predefined card distribution for testing purposes cardDistr :: Piles cardDistr = emptyPiles hand1 hand2 hand3 skt @@ -38,8 +53,8 @@ singleVsBots comm = do (PL $ OnlineEnv Team Hand1 comm) (PL $ Stupid Team Hand2) (PL $ mkAIEnv Single Hand3 10) - env = SkatEnv (distribute cards) Nothing Spades ps Hand1 - liftIO $ evalStateT (publishGameStart >> turn >>= publishGameResults) env + env = SkatEnv (distribute cards) Nothing (Colour Spades Einfach) ps Hand1 + void $ evalStateT turn env singleWithBidding :: Communicator c => c -> IO () singleWithBidding comm = do @@ -51,24 +66,10 @@ singleWithBidding comm = do (BD $ NoBidder Hand2) (BD $ NoBidder Hand3) env = PrepEnv ps bs - maySkatEnv <- liftIO $ runReaderT runPreperation env - case maySkatEnv of - Just skatEnv -> - liftIO $ evalStateT (publishGameStart >> turn >>= publishGameResults) skatEnv - Nothing -> putStrLn "No one wanted to play." + match env pvp :: Communicator c => c -> c -> c -> IO () pvp comm1 comm2 comm3 = do - cards <- shuffleCards - let ps = Players - (PL $ OnlineEnv Team Hand1 comm1) - (PL $ OnlineEnv Team Hand2 comm2) - (PL $ OnlineEnv Team Hand3 comm3) - env = SkatEnv (distribute cards) Nothing Spades ps Hand1 - liftIO $ evalStateT (publishGameStart >> turn >>= publishGameResults) env - -pvpWithBidding :: Communicator c => c -> c -> c -> IO () -pvpWithBidding comm1 comm2 comm3 = do cards <- shuffleCards let ps = distribute cards h1 = map toCard $ handCards Hand1 ps @@ -79,8 +80,4 @@ pvpWithBidding comm1 comm2 comm3 = do (BD $ PrepOnline Hand2 comm2 $ h2) (BD $ PrepOnline Hand3 comm3 $ h3) env = PrepEnv ps bs - maySkatEnv <- liftIO $ runReaderT runPreperation env - case maySkatEnv of - Just skatEnv -> - liftIO $ evalStateT (publishGameStart >> turn >>= publishGameResults) skatEnv - Nothing -> putStrLn "No one wanted to play." + match env diff --git a/src/Skat/Operations.hs b/src/Skat/Operations.hs index 686b57e..9ec940e 100644 --- a/src/Skat/Operations.hs +++ b/src/Skat/Operations.hs @@ -1,6 +1,6 @@ module Skat.Operations ( - turn, turnGeneric, play, playOpen, publishGameResults, - publishGameStart, play_, sortRender, undo_ + turn, turnGeneric, play, playOpen, + play_, sortRender, undo_ ) where import Control.Monad.State @@ -13,21 +13,13 @@ import Skat import Skat.Card import Skat.Pile import Skat.Player (chooseCard, Players(..), Player(..), PL(..), - updatePlayer, playersToList, player, MonadPlayer, getSinglePlayer) + updatePlayer, playersToList, player, MonadPlayer, getSinglePlayer, trump) import Skat.Utils (shuffle) -compareRender :: Card -> Card -> Ordering -compareRender (Card t1 c1) (Card t2 c2) = case compare c1 c2 of - EQ -> compare t1 t2 - v -> v - -sortRender :: [Card] -> [Card] -sortRender = sortBy compareRender - play_ :: HasCard c => c -> Skat () play_ card = do hand <- gets currentHand - trCol <- gets trumpColour + trCol <- trump modifyp $ playCard hand card table <- getp tableCards case length table of @@ -36,7 +28,7 @@ play_ card = do 3 -> evaluateTable >>= modify . setCurrentHand _ -> modify (setCurrentHand $ next hand) -undo_ :: HasCard c => c -> Hand -> Maybe Colour -> Team -> Skat () +undo_ :: HasCard c => c -> Hand -> Maybe TurnColour -> Team -> Skat () undo_ card oldCurrent oldTurnCol oldWinner = do modify $ setCurrentHand oldCurrent modify $ setTurnColour oldTurnCol @@ -51,7 +43,7 @@ turnGeneric playFunc depth = do ps <- gets players let p = player ps n over <- getp $ handEmpty n - trCol <- gets trumpColour + trCol <- trump case length table of 0 -> playFunc p >> modify (setCurrentHand $ next n) >> turnGeneric playFunc depth 1 -> do @@ -72,7 +64,7 @@ turn = turnGeneric play 10 evaluateTable :: Skat Hand evaluateTable = do - trumpCol <- gets trumpColour + trumpCol <- trump turnCol <- gets turnColour table <- getp tableCards ps <- gets players @@ -89,7 +81,7 @@ play :: (Show p, Player p) => p -> Skat Card play p = do table <- getp tableCards turnCol <- gets turnColour - trump <- gets trumpColour + trump <- trump cards <- getp $ handCards (hand p) fallen <- getp played (card, p') <- chooseCard p table fallen cards @@ -107,14 +99,3 @@ playOpen p = do card <- chooseCardOpen p modifyp $ playCard (hand p) card return card - -publishGameResults :: (Int, Int) -> Skat () -publishGameResults res = do - pls <- gets players - mapM_ (\p -> onGameResults p res) (playersToList pls) - -publishGameStart :: Skat () -publishGameStart = do - pls <- gets players - let sglPlayer = getSinglePlayer pls - mapM_ (\p -> onGameStart p sglPlayer) (playersToList pls) diff --git a/src/Skat/Pile.hs b/src/Skat/Pile.hs index d7a97d7..ed760ed 100644 --- a/src/Skat/Pile.hs +++ b/src/Skat/Pile.hs @@ -153,12 +153,12 @@ handCards Hand1 = _hand1 handCards Hand2 = _hand2 handCards Hand3 = _hand3 -allowed :: Hand -> Colour -> Maybe Colour -> Piles -> [CardS Owner] -allowed hand trCol turnCol ps +allowed :: Hand -> Trump -> Maybe TurnColour -> Piles -> [CardS Owner] +allowed hand trump turnCol ps | null sameColour = cards | otherwise = sameColour where cards = handCards hand ps - sameColour = filter (\ca -> effectiveColour trCol ca `equals` turnCol) cards + sameColour = filter (\ca -> effectiveColour trump ca `equals` turnCol) cards skatCards :: Piles -> [Card] skatCards = map getCard . _skat diff --git a/src/Skat/Player.hs b/src/Skat/Player.hs index df05621..37374e2 100644 --- a/src/Skat/Player.hs +++ b/src/Skat/Player.hs @@ -8,8 +8,8 @@ import Skat.Card import Skat.Pile class (Monad m, MonadIO m) => MonadPlayer m where - trumpColour :: m Colour - turnColour :: m (Maybe Colour) + trump :: m Trump + turnColour :: m (Maybe TurnColour) showSkat :: Player p => p -> m (Maybe [Card]) class (Monad m, MonadIO m, MonadPlayer m) => MonadPlayerOpen m where @@ -38,16 +38,6 @@ class Player p where fallen = played piles myCards = handCards (hand p) piles fst <$> chooseCard p table fallen myCards - onGameResults :: MonadIO m - => p - -> (Int, Int) - -> m () - onGameResults _ _ = return () - onGameStart :: MonadPlayer m - => p - -> Hand - -> m () - onGameStart _ _ = return () data PL = forall p. (Show p, Player p) => PL p @@ -64,8 +54,6 @@ instance Player PL where v <- onCardPlayed p card return $ PL v chooseCardOpen (PL p) = chooseCardOpen p - onGameResults (PL p) res = onGameResults p res - onGameStart (PL p) singlePlayer = onGameStart p singlePlayer data Players = Players PL PL PL deriving Show diff --git a/src/Skat/Player/Utils.hs b/src/Skat/Player/Utils.hs index e5f4e4d..c4591a8 100644 --- a/src/Skat/Player/Utils.hs +++ b/src/Skat/Player/Utils.hs @@ -8,11 +8,11 @@ import Skat.Card (Card, HasCard(..)) isAllowed :: (HasCard c, MonadPlayer m) => [c] -> c -> m Bool isAllowed hand card = do - trCol <- trumpColour + tr <- trump turnCol <- turnColour - return $ C.isAllowed trCol turnCol hand card + return $ C.isAllowed tr turnCol hand card isTrump :: MonadPlayer m => Card -> m Bool isTrump card = do - trCol <- trumpColour - return $ C.isTrump trCol card + tr <- trump + return $ C.isTrump tr card diff --git a/src/Skat/Preperation.hs b/src/Skat/Preperation.hs index db30d32..79d4faa 100644 --- a/src/Skat/Preperation.hs +++ b/src/Skat/Preperation.hs @@ -1,7 +1,9 @@ {-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE TupleSections #-} module Skat.Preperation ( - Bidder(..), Bid, BD(..), Bidders(..), PrepEnv(..), runPreperation + Bidder(..), Bid, BD(..), Bidders(..), PrepEnv(..), runPreperation, + publishGameResults ) where import Control.Monad.IO.Class @@ -30,6 +32,10 @@ class Bidder a where askHand :: MonadIO m => a -> Bid -> m Bool askSkat :: MonadIO m => a -> Bid -> [Card] -> m [Card] toPlayer :: a -> Team -> PL + onGame :: MonadIO m => a -> Game -> Hand -> m () + onGame _ _ _ = return () + onResult :: MonadIO m => a -> Result -> m () + onResult _ _ = return () -- | trick to allow heterogenous bidder list data BD = forall b. (Show b, Bidder b) => BD b @@ -46,6 +52,8 @@ instance Bidder BD where askResponse (BD b) = askResponse b toPlayer (BD b) = toPlayer b onStart (BD b) = onStart b + onGame (BD b) = onGame b + onResult (BD b) = onResult b data Bidders = Bidders BD BD BD deriving Show @@ -61,29 +69,31 @@ 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 SkatEnv) +runPreperation :: Preperation (Maybe (Hand, SkatEnv)) runPreperation = do bds <- asks bidders onStart (bidder bds Hand1) onStart (bidder bds Hand2) onStart (bidder bds Hand3) (winner, bid) <- runBidding 0 (bidder bds Hand2) (bidder bds Hand1) - (finalWinner, finalBid) <- runBidding 0 (bidder bds Hand3) (bidder bds winner) + (finalWinner, finalBid) <- runBidding bid (bidder bds Hand3) (bidder bds winner) if finalBid == 0 then do bid <- askBid (bidder bds finalWinner) finalWinner 0 case bid of - Just val -> Just <$> initGame finalWinner val + Just val -> (Just . (finalWinner,)) <$> initGame finalWinner val Nothing -> return Nothing - else Just <$> initGame finalWinner finalBid + else (Just . (finalWinner,)) <$> initGame finalWinner finalBid runBidding :: Bid -> BD -> BD -> Preperation (Hand, Bid) runBidding startingBid reizer gereizter = do first <- askBid reizer (hand gereizter) startingBid case first of - Just val -> do - response <- askResponse gereizter (hand reizer) val - if response then runBidding val reizer gereizter - else return (hand reizer, val) + Just val + | val > startingBid -> do + response <- askResponse gereizter (hand reizer) val + if response then runBidding val reizer gereizter + else return (hand reizer, val) + | otherwise -> return (hand gereizter, startingBid) Nothing -> return (hand gereizter, startingBid) initGame :: Hand -> Bid -> Preperation SkatEnv @@ -96,8 +106,10 @@ initGame single bid = do ps' <- if noSkat then return ps else handleSkat (bidder bds single) bid ps -- ask for game kind game <- handleGame (bidder bds single) bid noSkat + -- publish game start + publishGameStart game single -- construct skat env - return $ mkSkatEnv ps' Nothing Spades (toPlayers single bds) Hand1 + return $ mkSkatEnv ps' Nothing game (toPlayers single bds) Hand1 handleGame :: BD -> Bid -> Bool -> Preperation Game handleGame bd bid noSkat = do @@ -119,3 +131,16 @@ handleSkat bd bid ps = do case moveToSkat (hand bd) skat' ps of Just correct -> return correct Nothing -> handleSkat bd bid ps + +publishGameResults :: MonadIO m => Result -> Bidders -> m () +publishGameResults res bidders = do + onResult (bidder bidders Hand1) res + onResult (bidder bidders Hand2) res + onResult (bidder bidders Hand3) res + +publishGameStart :: Game -> Hand -> Preperation () +publishGameStart game sglPlayer = do + bds <- asks bidders + onGame (bidder bds Hand1) game sglPlayer + onGame (bidder bds Hand2) game sglPlayer + onGame (bidder bds Hand3) game sglPlayer