track every trick, return detailed match information

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

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

src/Skat/AI/Online.hs

@@ -84,6 +84,10 @@ instance Communicator c => Bidder (PrepOnline c) where
             Just (ChosenCards cards) -> return cards
             Nothing -> askSkat p bid cards
     toPlayer p tm = PL $ OnlineEnv tm (prepHand p) (prepConnection p)
+    onBid p mayBid reizer gereizter =
+        liftIO $ send (prepConnection p) (BS.unpack $ encode $ BidEvent mayBid reizer gereizter)
+    onResponse p response reizer gereizter =
+        liftIO $ send (prepConnection p) (BS.unpack $ encode $ ResponseEvent response reizer gereizter)
     onStart p = do
         let cards = sortRender Jacks $ prepCards p
         liftIO $ send (prepConnection p) (BS.unpack $ encode $ CardsQuery cards)
@@ -133,6 +137,8 @@ data Query = ChooseQuery [Card] [CardS Played]
            | AskHandQuery
            | AskSkatQuery [Card] Bid
            | CardsQuery [Card]
+           | BidEvent (Maybe Bid) Hand Hand
+           | ResponseEvent Bool Hand Hand
 
 newtype ChosenResponse = ChosenResponse Card
 newtype BidResponse = BidResponse Int
@@ -164,6 +170,19 @@ instance ToJSON Query where
         object ["query" .= ("cards" :: String), "cards" .= cards ]
     toJSON (AskGameQuery bid) =
         object ["query" .= ("ask_game" :: String), "bid" .= bid]
+    toJSON (BidEvent (Just bid) reizer gereizter) =
+        object ["query" .= ("bid_event" :: String), "bid" .= bid, "reizer" .= show reizer,
+                "gereizter" .= show gereizter ]
+    toJSON (BidEvent Nothing reizer gereizter) =
+        object [ "query" .= ("bid_event" :: String)
+               , "bid" .= ("weg" :: String)
+               , "reizer" .= show reizer
+               , "gereizter" .= show gereizter ]
+    toJSON (ResponseEvent response reizer gereizter) =
+        object [ "query" .= ("response_event" :: String)
+               , "response" .= response
+               , "reizer" .= show reizer
+               , "gereizter" .= show gereizter ]
 
 instance FromJSON ChosenResponse where
     parseJSON = withObject "ChosenResponse" $ \v -> ChosenResponse

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)

src/Skat/AI/Stupid.hs

@@ -1,5 +1,8 @@
 module Skat.AI.Stupid where
 
+import Control.Concurrent
+import Control.Monad.State
+
 import Skat.Player
 import Skat.Pile
 import Skat.Card
@@ -16,6 +19,7 @@ instance Player Stupid where
     chooseCard p _ _ hand = do
         trumpCol <- trump
         turnCol <- turnColour
+        liftIO $ threadDelay 1000000
         let possible = filter (isAllowed trumpCol turnCol hand) hand
         return (toCard $ head possible, p)
 

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

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

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)

src/Skat/Preperation.hs

@@ -32,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
+    onBid :: MonadIO m => a -> Maybe Bid -> Hand -> Hand -> m ()
+    onBid _ _ _ _ = return ()
+    onResponse :: MonadIO m => a -> Bool -> Hand -> Hand -> m ()
+    onResponse _ _ _ _ = return ()
     onGame :: MonadIO m => a -> Game -> Hand -> m ()
     onGame _ _ _ = return ()
     onResult :: MonadIO m => a -> Result -> m ()
@@ -54,6 +58,8 @@ instance Bidder BD where
     onStart (BD b) = onStart b
     onGame (BD b) = onGame b
     onResult (BD b) = onResult b
+    onBid (BD b) = onBid b
+    onResponse (BD b) = onResponse b
 
 data Bidders = Bidders BD BD BD
                deriving Show
@@ -79,6 +85,7 @@ runPreperation = do
     (finalWinner, finalBid) <- runBidding bid (bidder bds Hand3) (bidder bds winner)
     if finalBid == 0 then do
         bid <- askBid (bidder bds finalWinner) finalWinner 0
+        publishBid bid finalWinner finalWinner
         case bid of
             Just val -> (Just . (finalWinner,)) <$> initGame finalWinner val
             Nothing -> return Nothing
@@ -90,11 +97,17 @@ runBidding startingBid reizer gereizter = do
     case first of
         Just val
             | val > startingBid -> do
+                publishBid first (hand reizer) (hand gereizter)
                 response <- askResponse gereizter (hand reizer) val
+                publishResponse response (hand reizer) (hand gereizter)
                 if response then runBidding val reizer gereizter
                 else return (hand reizer, val)
-            | otherwise -> return (hand gereizter, startingBid)
+            | otherwise -> do
-        Nothing -> return (hand gereizter, startingBid)
+                publishBid Nothing (hand reizer) (hand gereizter)
+                return (hand gereizter, startingBid)
+        Nothing -> do
+            publishBid Nothing (hand reizer) (hand gereizter)
+            return (hand gereizter, startingBid)
 
 initGame :: Hand -> Bid -> Preperation SkatEnv
 initGame single bid = do
@@ -139,8 +152,17 @@ publishGameResults res bidders = do
     onResult (bidder bidders Hand3) res
 
 publishGameStart :: Game -> Hand -> Preperation ()
-publishGameStart game sglPlayer = do
+publishGameStart game sglPlayer = mapBidders (\b -> onGame b game sglPlayer)
+
+publishBid :: Maybe Bid -> Hand -> Hand -> Preperation ()
+publishBid bid reizer gereizter = mapBidders (\b -> onBid b bid reizer gereizter)
+
+publishResponse :: Bool -> Hand -> Hand -> Preperation ()
+publishResponse response reizer gereizter = mapBidders (\b -> onResponse b response reizer gereizter)
+
+mapBidders :: (BD -> Preperation ()) -> Preperation ()
+mapBidders f = do
     bds <- asks bidders
-    onGame (bidder bds Hand1) game sglPlayer
+    f (bidder bds Hand1)
-    onGame (bidder bds Hand2) game sglPlayer
+    f (bidder bds Hand2)
-    onGame (bidder bds Hand3) game sglPlayer
+    f (bidder bds Hand3)