98 lines
3.3 KiB
Haskell
98 lines
3.3 KiB
Haskell
{-# LANGUAGE TypeSynonymInstances #-}
|
|
{-# LANGUAGE FlexibleInstances #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
module Skat.AI.Online where
|
|
|
|
import Control.Monad.Reader
|
|
import Data.Aeson
|
|
import qualified Data.ByteString.Lazy.Char8 as BS
|
|
|
|
import Skat.Player
|
|
import qualified Skat.Player.Utils as P
|
|
import Skat.Pile
|
|
import Skat.Card
|
|
import Skat.Render
|
|
|
|
class Communicator a where
|
|
send :: a -> String -> IO ()
|
|
receive :: a -> IO String
|
|
|
|
class Monad m => MonadClient m where
|
|
query :: String -> m ()
|
|
response :: m String
|
|
|
|
data OnlineEnv c = OnlineEnv { getTeam :: Team
|
|
, getHand :: Hand
|
|
, connection :: c }
|
|
|
|
instance Show (OnlineEnv c) where
|
|
show _ = "An online 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
|
|
|
|
type Online a m = ReaderT (OnlineEnv a) m
|
|
|
|
instance (Communicator c, MonadIO m) => MonadClient (Online c m) where
|
|
query s = do
|
|
conn <- asks connection
|
|
liftIO $ send conn s
|
|
response = do
|
|
conn <- asks connection
|
|
liftIO $ receive conn
|
|
|
|
instance MonadPlayer m => MonadPlayer (Online a m) where
|
|
trumpColour = lift $ trumpColour
|
|
turnColour = lift $ turnColour
|
|
showSkat = lift . showSkat
|
|
|
|
choose :: (Communicator c, MonadPlayer m) => [CardS Played] -> [Card] -> Online c m Card
|
|
choose table hand = do
|
|
query (BS.unpack $ encode $ ChooseQuery hand table)
|
|
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
|
|
|
|
cardPlayed :: (Communicator c, MonadPlayer m) => CardS Played -> Online c m ()
|
|
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
|
|
trCol <- trumpColour
|
|
ownHand <- asks getHand
|
|
query (BS.unpack $ encode $ GameStartQuery trCol ownHand singlePlayer)
|
|
|
|
data Query = ChooseQuery [Card] [CardS Played]
|
|
| CardPlayedQuery (CardS Played)
|
|
| GameResultsQuery Int Int
|
|
| GameStartQuery Colour Hand Hand
|
|
|
|
data Response = ChosenResponse Card
|
|
|
|
instance ToJSON Query where
|
|
toJSON (ChooseQuery hand table) =
|
|
object ["query" .= ("choose_card" :: String), "hand" .= hand, "table" .= table]
|
|
toJSON (CardPlayedQuery card) =
|
|
object ["query" .= ("card_played" :: String), "card" .= card]
|
|
toJSON (GameResultsQuery sgl tm) =
|
|
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
|
|
parseJSON = withObject "ChosenResponse" $ \v -> ChosenResponse
|
|
<$> v .: "card"
|