christian/skat
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

implement grand and null mechanics, fix some online player issues

Browse Source
This commit is contained in:
christian
2020-03-31 01:27:27 +02:00
parent 5241033cb3
commit 2567bf4cd9
17 changed files with 291 additions and 174 deletions
Download Patch File Download Diff File Expand all files Collapse all files
app/Main.hs
+8 -7
View File
@@ -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 ]
app/TestEnvs.hs
+3 -2
View File
@@ -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
package.yaml
+1 -1
View File
@@ -1,5 +1,5 @@
name: skat
version: 0.1.0.5
version: 0.1.0.7
github: "githubuser/skat"
license: BSD3
author: "flavis"
skat.cabal
+2 -2
View File
@@ -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 <https://git.flavigny.de/christian/skat>
homepage: https://github.com/githubuser/skat#readme
bug-reports: https://github.com/githubuser/skat/issues
src/Skat.hs
+8 -7
View File
@@ -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
src/Skat/AI/Human.hs
+1 -1
View File
@@ -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)
src/Skat/AI/Online.hs
+17 -23
View File
@@ -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) =
src/Skat/AI/Rulebased.hs
+19 -16
View File
@@ -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
src/Skat/AI/Stupid.hs
+6 -5
View File
@@ -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 ()
src/Skat/Bidding.hs
+75 -4
View File
@@ -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
src/Skat/Card.hs
+79 -25
View File
@@ -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
src/Skat/Matches.hs
+20 -23
View File
@@ -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
src/Skat/Operations.hs
+8 -27
View File
@@ -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)
src/Skat/Pile.hs
+3 -3
View File
@@ -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
src/Skat/Player.hs
+2 -14
View File
@@ -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
src/Skat/Player/Utils.hs
+4 -4
View File
@@ -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
src/Skat/Preperation.hs
+35 -10
View File
@@ -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