skat/src/Skat/AI/Online.hs

{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}

module Skat.AI.Online where

import Control.Monad.Reader
import Control.Concurrent.Chan
import Data.Aeson hiding (Result)
import Data.Maybe
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
import Skat.Preperation
import Skat.Bidding

class Communicator a where
    send :: a -> String -> IO ()
    receive :: a -> IO String

instance Communicator (Chan String) where
    send = writeChan
    receive = readChan

class Monad m => MonadClient m where
    query :: String -> m ()
    response :: m String

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

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)
    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)
    onResult p res =
        liftIO $ send (prepConnection p) (BS.unpack $ encode $ GameResultsQuery res)
    onGame p game sglPlayer = do
        liftIO $ send (prepConnection p) (BS.unpack $ encode $ GameStartQuery game sglPlayer)

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
    trump = lift $ trump
    turnColour = lift $ turnColour
    showSkat = lift . showSkat

choose :: HasCard a => (Communicator c, MonadPlayer m) => [CardS Played] -> [a] -> Online c m Card
choose table hand' = do
    let hand = sortRender Jacks $ map toCard hand'
    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)

-- | QUERIES AND RESPONSES
    
data Query = ChooseQuery [Card] [CardS Played]
           | CardPlayedQuery (CardS Played)
           | GameResultsQuery Result
           | GameStartQuery Game Hand
           | BidQuery Hand Bid
           | BidResponseQuery Hand Bid
           | AskGameQuery Bid
           | AskHandQuery
           | AskSkatQuery [Card] Bid
           | CardsQuery [Card]
           | BidEvent (Maybe Bid) Hand Hand
           | ResponseEvent Bool Hand Hand

newtype ChosenResponse = ChosenResponse Card
newtype BidResponse = BidResponse Int
newtype YesNo = YesNo Bool
newtype GameResponse = GameResponse Game
                       deriving Show
newtype ChosenCards = ChosenCards [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 result) =
        object ["query" .= ("results" :: String), "result" .= result]
    toJSON (GameStartQuery game sglPlayer) =
        object [ "query" .= ("start_game" :: String)
               , "game" .= game
               , "single" .= toInt sglPlayer ]
    toJSON (BidQuery hand bid) =
        object ["query" .= ("bid" :: String), "whom" .= show hand, "current" .= bid]
    toJSON (BidResponseQuery hand bid) =
        object ["query" .= ("bid_response" :: String), "from" .= show hand, "bid" .= bid ]
    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 ]
    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
        <$> 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"