implement online player bidding

src/Skat/AI/Online.hs

@@ -15,6 +15,8 @@ import qualified Skat.Player.Utils as P
 import Skat.Pile
 import Skat.Card
 import Skat.Render
+import Skat.Preperation
+import Skat.Bidding
 
 class Communicator a where
     send :: a -> String -> IO ()
@@ -32,16 +34,61 @@ data OnlineEnv c = OnlineEnv { getTeam :: Team
                              , getHand :: Hand
                              , connection :: c }
 
+data PrepOnline c = PrepOnline { prepHand :: Hand
+                               , prepConnection :: c
+                               , prepCards :: [Card] }
+
 instance Show (OnlineEnv c) where
     show _ = "An online env"
 
+instance Show (PrepOnline c) where
+    show _ = "An online prep env"
+
 instance Communicator c => Player (OnlineEnv c) where
     team = getTeam
     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 (onStart singlePlayer) p
+    onGameStart p singlePlayer = runReaderT (onStartOnline singlePlayer) p
+
+instance Communicator c => Bidder (PrepOnline c) where
+    hand = prepHand
+    askBid p against bid = do
+        liftIO $ send (prepConnection p) (BS.unpack $ encode $ BidQuery against bid)
+        r <- liftIO $ receive (prepConnection p)
+        case decode (BS.pack r) of
+            Just (BidResponse newBid) -> do
+                if newBid > bid then return $ Just newBid else return Nothing
+            Nothing -> askBid p against bid
+    askResponse p bidder bid = do
+        liftIO $ send (prepConnection p) (BS.unpack $ encode $ BidResponseQuery bidder bid)
+        r <- liftIO $ receive (prepConnection p)
+        case decode (BS.pack r) of
+            Just (YesNo value) -> return value
+            Nothing -> askResponse p bidder bid
+    askGame p bid = do
+        liftIO $ send (prepConnection p) (BS.unpack $ encode $ AskGameQuery bid)
+        r <- liftIO $ receive (prepConnection p)
+        case decode (BS.pack r) of
+            Just (GameResponse game) -> return game
+            Nothing -> askGame p bid
+    askHand p bid = do
+        liftIO $ send (prepConnection p) (BS.unpack $ encode $ AskHandQuery)
+        r <- liftIO $ receive (prepConnection p)
+        case decode (BS.pack r) of
+            Just (YesNo value) -> return value
+            Nothing -> askHand p bid
+    askSkat p bid cards = do
+        liftIO $ send (prepConnection p) (BS.unpack $ encode $ AskSkatQuery cards bid)
+        r <- liftIO $ receive (prepConnection p)
+        case decode (BS.pack r) of
+            Just (ChosenCards cards) -> return cards
+            Nothing -> askSkat p bid cards
+    toPlayer p tm = PL $ OnlineEnv tm (prepHand p) (prepConnection p)
+    onStart p = do
+        let cards = prepCards p
+        liftIO $ send (prepConnection p) (BS.unpack $ encode $ CardsQuery cards)
 
 type Online a m = ReaderT (OnlineEnv a) m
 
@@ -75,18 +122,30 @@ 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)
 
-onStart :: (Communicator c, MonadPlayer m) => Hand -> Online c m ()
-onStart singlePlayer = do
+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
-
-data Response = ChosenResponse Card
+           | BidQuery Hand Bid
+           | BidResponseQuery Hand Bid
+           | AskGameQuery Bid
+           | AskHandQuery
+           | AskSkatQuery [Card] Bid
+           | CardsQuery [Card]
+
+newtype ChosenResponse = ChosenResponse Card
+newtype BidResponse = BidResponse Int
+newtype YesNo = YesNo Bool
+newtype GameResponse = GameResponse Game
+newtype ChosenCards = ChosenCards [Card]
      
 instance ToJSON Query where
     toJSON (ChooseQuery hand table) =
@@ -97,8 +156,34 @@ instance ToJSON Query where
         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]
-
-instance FromJSON Response where
+                "hand" .= toInt handNo, "single" .= toInt sglPlayer ]
+    toJSON (BidQuery hand bid) =
+        object ["query" .= ("bid" :: String), "whom" .= show hand ]
+    toJSON (BidResponseQuery hand bid) =
+        object ["query" .= ("bid_response" :: String), "from" .= show hand ]
+    toJSON (AskHandQuery) =
+        object ["query" .= ("play_hand" :: String)]
+    toJSON (AskSkatQuery cards bid) =
+        object ["query" .= ("skat" :: String), "cards" .= cards, "bid" .= bid ]
+    toJSON (CardsQuery cards) =
+        object ["query" .= ("cards" :: String), "cards" .= cards ]
+
+instance FromJSON ChosenResponse where
     parseJSON = withObject "ChosenResponse" $ \v -> ChosenResponse
         <$> v .: "card"
+
+instance FromJSON BidResponse where
+    parseJSON = withObject "BidResponse" $ \v -> BidResponse
+        <$> v .: "bid"
+
+instance FromJSON YesNo where
+    parseJSON = withObject "BidYesNo" $ \v -> YesNo
+        <$> v .: "yesno"
+
+instance FromJSON GameResponse where
+    parseJSON = withObject "GameResponse" $ \v -> GameResponse
+        <$> v .: "game"
+
+instance FromJSON ChosenCards where
+    parseJSON = withObject "ChosenCards" $ \v -> ChosenCards
+        <$> v .: "cards"

src/Skat/AI/Stupid.hs

@@ -3,6 +3,7 @@ module Skat.AI.Stupid where
 import Skat.Player
 import Skat.Pile
 import Skat.Card
+import Skat.Preperation
 
 data Stupid = Stupid { getTeam :: Team
                      , getHand :: Hand }
@@ -16,3 +17,17 @@ instance Player Stupid where
         turnCol <- turnColour
         let possible = filter (isAllowed trumpCol turnCol hand) hand
         return (toCard $ head possible, p)
+
+newtype NoBidder = NoBidder Hand
+                   deriving Show
+
+-- | 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
+    askSkat _ _ _ = undefined -- never called
+    toPlayer (NoBidder h) team = PL $ Stupid team h
+    onStart _ = return ()

src/Skat/Bidding.hs

@@ -1,7 +1,11 @@
+{-# LANGUAGE OverloadedStrings #-}
+
 module Skat.Bidding (
     biddingScore, Game(..), Modifier(..)
 ) where
 
+import Data.Aeson hiding (Null)
+
 import Skat.Card
 import Data.List (sortOn)
 import Data.Ord (Down(..))
@@ -15,6 +19,22 @@ data Game = Colour Colour Modifier
           | NullOuvertHand
             deriving (Show, Eq)
 
+instance FromJSON Game where
+    parseJSON = withObject "Game" $ \v -> do
+        gamekind <- v .: "game"
+        case (gamekind :: String) of
+            "colour" -> do
+                col <- v .: "colour"
+                mod <- v .: "modifier"
+                return $ Colour (read col) mod
+            "grand" -> do
+                mod <- v .: "modifier"
+                return $ Grand mod
+            "null" -> return Null
+            "nullhand" -> return NullHand
+            "nullouvert" -> return NullOuvert
+            "nullouverthand" -> return NullOuvertHand
+
 -- | modifiers for grand and colour games
 data Modifier = Einfach
               | Schneider
@@ -28,6 +48,19 @@ data Modifier = Einfach
               | Ouvert
                 deriving (Show, Eq)
 
+instance FromJSON Modifier where
+    parseJSON = withObject "Modifier" $ \v -> do
+        hnd <- v .: "hand"
+        if read hnd then do
+            schneider <- v .: "schneider"
+            schwarz <- v .: "schwarz"
+            ouvert <- v .: "ouvert"
+            case (schneider, schwarz, ouvert) of
+                (_, _, True) -> return Ouvert
+                (True, False, _) -> return HandSchneiderAngesagt
+                (_, True, _) -> return HandSchwarzAngesagt
+        else return Einfach
+
 -- | 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

@@ -1,8 +1,9 @@
 module Skat.Matches (
-    singleVsBots, pvp
+    singleVsBots, pvp, pvpWithBidding
 ) where
 
 import Control.Monad.State
+import Control.Monad.Reader
 import System.Random (mkStdGen)
 
 import Skat
@@ -10,6 +11,7 @@ import Skat.Operations
 import Skat.Player
 import Skat.Pile
 import Skat.Card
+import Skat.Preperation
 
 import Skat.AI.Rulebased
 import Skat.AI.Online
@@ -48,3 +50,21 @@ pvp comm1 comm2 comm3 = do
                 (PL $ OnlineEnv Team Hand3 comm3)
         env = SkatEnv (distribute cards) Nothing Spades ps Hand1
     liftIO $ evalStateT (publishGameStart Hand3 >> 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
+        h2 = map toCard $ handCards Hand2 ps
+        h3 = map toCard $ handCards Hand3 ps
+        bs = Bidders
+                (BD $ PrepOnline Hand1 comm1 $ h1)
+                (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 Hand3 >> turn >>= publishGameResults) skatEnv
+        Nothing -> putStrLn "No one wanted to play."

src/Skat/Preperation.hs

@@ -1,11 +1,11 @@
 {-# LANGUAGE ExistentialQuantification #-}
 
 module Skat.Preperation (
-
+    Bidder(..), Bid, BD(..), Bidders(..), PrepEnv(..), runPreperation
 ) where
 
 import Control.Monad.IO.Class
-import Control.Monad.State
+import Control.Monad.Reader
 
 import Skat.Pile
 import Skat.Card
@@ -16,17 +16,16 @@ import Skat (SkatEnv, mkSkatEnv)
 type Bid = Int
 
 data PrepEnv = PrepEnv { piles :: Piles
-                       , currentBid :: Bid
-                       , currentHand :: Hand
                        , bidders :: Bidders }
                deriving Show
 
-type Preperation = StateT PrepEnv IO
+type Preperation = ReaderT PrepEnv IO
 
 class Bidder a where
     hand :: a -> Hand
+    onStart :: MonadIO m => a -> m ()
     askBid :: MonadIO m => a -> Hand -> Bid -> m (Maybe Bid)
-    askResponse :: MonadIO m => a -> Hand -> m Bool
+    askResponse :: MonadIO m => a -> Hand -> Bid -> m Bool
     askGame :: MonadIO m => a -> Bid -> m Game
     askHand :: MonadIO m => a -> Bid -> m Bool
     askSkat :: MonadIO m => a -> Bid -> [Card] -> m [Card]
@@ -46,6 +45,7 @@ instance Bidder BD where
     askSkat (BD b) = askSkat b
     askResponse (BD b) = askResponse b
     toPlayer (BD b) = toPlayer b
+    onStart (BD b) = onStart b
 
 data Bidders = Bidders BD BD BD
                deriving Show
@@ -63,7 +63,10 @@ toPlayers single (Bidders b1 b2 b3) =
 
 runPreperation :: Preperation (Maybe SkatEnv)
 runPreperation = do
-    bds <- gets bidders
+    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)
     if finalBid == 0 then do
@@ -78,15 +81,15 @@ runBidding startingBid reizer gereizter = do
     first <- askBid reizer (hand gereizter) startingBid
     case first of
         Just val -> do
-            response <- askResponse gereizter (hand reizer)
+            response <- askResponse gereizter (hand reizer) val
             if response then runBidding val reizer gereizter
             else return (hand reizer, val)
         Nothing -> return (hand gereizter, startingBid)
 
 initGame :: Hand -> Bid -> Preperation SkatEnv
 initGame single bid = do
-    ps <- gets piles
-    bds <- gets bidders
+    ps <- asks piles
+    bds <- asks bidders
     -- ask if player wants to play hand
     noSkat <- askHand (bidder bds single) bid
     -- either return piles or ask for skat cards and modify piles