diff --git a/src/Skat/AI/Online.hs b/src/Skat/AI/Online.hs index 1e3bee3..05eb944 100644 --- a/src/Skat/AI/Online.hs +++ b/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 diff --git a/src/Skat/AI/Stupid.hs b/src/Skat/AI/Stupid.hs index f8a29a1..aa63dba 100644 --- a/src/Skat/AI/Stupid.hs +++ b/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) diff --git a/src/Skat/Preperation.hs b/src/Skat/Preperation.hs index 79d4faa..3900772 100644 --- a/src/Skat/Preperation.hs +++ b/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) - Nothing -> return (hand gereizter, startingBid) + | otherwise -> do + 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 - onGame (bidder bds Hand2) game sglPlayer - onGame (bidder bds Hand3) game sglPlayer + f (bidder bds Hand1) + f (bidder bds Hand2) + f (bidder bds Hand3)