diff --git a/app/Main.hs b/app/Main.hs index 51891d8..1792811 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -41,7 +41,7 @@ runAI = do trs = filter (isTrump $ TrumpColour Spades) cs if length trs >= 5 && any ((==32) . getID) cs then do - pts <- fst <$> evalStateT turn env + pts <- fst <$> evalSkat turn env -- if pts > 60 then return 1 else return 0 return pts else runAI @@ -109,4 +109,4 @@ application pending = do putStrLn $ BS.unpack msg playSkat :: IO () -playSkat = void $ (flip runStateT) env3 playCLI +playSkat = void $ (flip runSkat) env3 playCLI diff --git a/src/Skat.hs b/src/Skat.hs index 1a7e2f5..112e341 100644 --- a/src/Skat.hs +++ b/src/Skat.hs @@ -5,6 +5,7 @@ module Skat where import Control.Monad.State +import Control.Monad.Writer import Control.Monad.Reader import Data.List import Data.Vector (Vector) @@ -22,7 +23,19 @@ data SkatEnv = SkatEnv { piles :: Piles , currentHand :: Hand } deriving Show -type Skat = StateT SkatEnv IO +type Trick = (CardS Owner, CardS Owner, CardS Owner) +type Skat = StateT SkatEnv (WriterT [Trick] IO) + +runSkat :: Skat a -> SkatEnv -> IO (a, SkatEnv, [Trick]) +runSkat action env = do + ((val, env'), tricks) <- runWriterT $ runStateT action env + return (val, env', tricks) + +evalSkat :: Skat a -> SkatEnv -> IO a +evalSkat action = (fmap fst) . runWriterT . evalStateT action + +execSkat :: Skat a -> SkatEnv -> IO SkatEnv +execSkat action = (fmap fst) . runWriterT . execStateT action instance P.MonadPlayer Skat where trump = gets $ getTrump . game diff --git a/src/Skat/AI/Rulebased.hs b/src/Skat/AI/Rulebased.hs index b23ce00..3bce99d 100644 --- a/src/Skat/AI/Rulebased.hs +++ b/src/Skat/AI/Rulebased.hs @@ -22,7 +22,7 @@ import qualified Skat.Player.Utils as P import Skat.Pile hiding (isSkat) import Skat.Card import Skat.Utils -import Skat (Skat, modifyp, mkSkatEnv) +import Skat (Skat, modifyp, mkSkatEnv, evalSkat) import Skat.Operations import qualified Skat.AI.Minmax as Minmax import qualified Skat.AI.Stupid as Stupid (Stupid(..)) @@ -317,7 +317,7 @@ chooseSimulating = do (PL $ Stupid.Stupid Single Hand3) -- TODO: fix env = mkSkatEnv piles turnCol undefined ps myHand - liftIO $ evalStateT (toCard <$> (Minmax.choose depth :: Skat (CardS Owner))) env + liftIO $ evalSkat (toCard <$> (Minmax.choose depth :: Skat (CardS Owner))) env simulate :: (MonadState AIEnv m, MonadPlayerOpen m) => Card -> m Int @@ -339,7 +339,7 @@ simulate card = do -- TODO: fix env = mkSkatEnv piles turnCol undefined ps (next myHand) -- simulate the game after playing the given card - (sgl, tm) <- liftIO $ evalStateT (do + (sgl, tm) <- liftIO $ evalSkat (do modifyp $ playCard myHand card turnGeneric playOpen depth) env let v = if myTeam == Single then (sgl, tm) else (tm, sgl) diff --git a/src/Skat/Bidding.hs b/src/Skat/Bidding.hs index 365daa2..3e0f342 100644 --- a/src/Skat/Bidding.hs +++ b/src/Skat/Bidding.hs @@ -140,7 +140,10 @@ getTrump (Colour col _) = TrumpColour col getTrump (Grand _) = Jacks getTrump _ = None -data Result = Result Game Int Int Int +data Result = Result { resultGame :: Game + , resultScore :: Int + , resultSinglePoints :: Int + , resultTeamPoints :: Int } deriving (Show, Eq) instance ToJSON Result where diff --git a/src/Skat/Matches.hs b/src/Skat/Matches.hs index bb1044a..b0f02c9 100644 --- a/src/Skat/Matches.hs +++ b/src/Skat/Matches.hs @@ -1,5 +1,5 @@ module Skat.Matches ( - singleVsBots, pvp, singleWithBidding + singleVsBots, pvp, singleWithBidding, Match(..) ) where import Control.Monad.State @@ -18,19 +18,26 @@ import Skat.AI.Rulebased import Skat.AI.Online import Skat.AI.Stupid -match :: PrepEnv -> IO () +data Match = Match { matchPiles :: Piles + , matchResult :: Result + , matchTricks :: [Trick] + , matchSingle :: Hand } + deriving Show + +match :: PrepEnv -> IO (Maybe Match) match prepEnv = do maySkatEnv <- runReaderT runPreperation prepEnv case maySkatEnv of Just (sglPlayer, skatEnv) -> do - finished <- execStateT turn skatEnv + (_, finished, tricks) <- runSkat 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" + return $ Just $ Match (Skat.piles skatEnv) res tricks sglPlayer + Nothing -> putStrLn "no one wanted to play" >> return Nothing -- | predefined card distribution for testing purposes cardDistr :: Piles @@ -54,7 +61,7 @@ singleVsBots comm = do (PL $ Stupid Team Hand2) (PL $ mkAIEnv Single Hand3 10) env = SkatEnv (distribute cards) Nothing (Colour Spades Einfach) ps Hand1 - void $ evalStateT turn env + void $ evalSkat turn env singleWithBidding :: Communicator c => c -> IO () singleWithBidding comm = do @@ -66,9 +73,9 @@ singleWithBidding comm = do (BD $ NoBidder Hand2) (BD $ NoBidder Hand3) env = PrepEnv ps bs - match env + void $ match env -pvp :: Communicator c => c -> c -> c -> IO () +pvp :: Communicator c => c -> c -> c -> IO (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 9ec940e..22e4e72 100644 --- a/src/Skat/Operations.hs +++ b/src/Skat/Operations.hs @@ -4,6 +4,7 @@ module Skat.Operations ( ) where import Control.Monad.State +import Control.Monad.Writer (tell) import System.Random (newStdGen, randoms) import Data.List import Data.Ord @@ -72,6 +73,7 @@ evaluateTable = do winner = player ps winnerHand modifyp $ cleanTable (team winner) modify $ setTurnColour Nothing + tell [(table !! 2, table !! 1, table !! 0)] return $ hand winner countGame :: Skat (Int, Int)