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

add ouvert games

Browse Source
This commit is contained in:
christian
2020-04-06 01:44:36 +02:00
parent 1c3f85b9a6
commit fac461b759
14 changed files with 157 additions and 62 deletions
Download Patch File Download Diff File Expand all files Collapse all files
app/Main.hs
+6 -6
View File
@@ -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 ]
app/TestEnvs.hs
+2 -2
View File
@@ -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
package.yaml
+1
View File
@@ -35,6 +35,7 @@ dependencies:
- case-insensitive
- vector
- transformers
- exceptions
library:
source-dirs: src
skat.cabal
+4 -1
View File
@@ -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
src/Skat.hs
+7 -4
View File
@@ -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]
src/Skat/AI/Human.hs
+1 -1
View File
@@ -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
src/Skat/AI/Online.hs
+13 -10
View File
@@ -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) =
src/Skat/AI/Rulebased.hs
+3 -3
View File
@@ -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
src/Skat/AI/Stupid.hs
+1 -1
View File
@@ -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
src/Skat/Bidding.hs
+8 -1
View File
@@ -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
src/Skat/Matches.hs
+54 -15
View File
@@ -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
src/Skat/Operations.hs
+41 -9
View File
@@ -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
src/Skat/Player.hs
+11 -4
View File
@@ -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
src/Skat/Preperation.hs
+5 -5
View File
@@ -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