skat/src/Skat/AI/Online.hs

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

module Skat.AI.Online where

import Control.Monad.Reader
import Network.WebSockets (Connection, sendTextData, receiveData)
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 Monad m => MonadClient m where
    query :: String -> m ()
    response :: m String

data OnlineEnv = OnlineEnv { getTeam :: Team
                           , getHand :: Hand
                           , connection :: Connection }
                 deriving Show

instance Show Connection where
    show _ = "A connection"

instance Player OnlineEnv 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 m = ReaderT OnlineEnv m

instance MonadIO m => MonadClient (Online m) where
    query s = do
        conn <- asks connection
        liftIO $ sendTextData conn (BS.pack s)
    response = do
        conn <- asks connection
        liftIO $ BS.unpack <$> receiveData conn

instance MonadPlayer m => MonadPlayer (Online m) where
    trumpColour = lift $ trumpColour
    turnColour = lift $ turnColour
    showSkat = lift . showSkat

choose :: MonadPlayer m => [CardS Played] -> [Card] -> Online 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 :: MonadPlayer m => CardS Played -> Online m ()
cardPlayed card = query (BS.unpack $ encode $ CardPlayedQuery card)

onResults :: MonadIO m => (Int, Int) -> Online m ()
onResults (sgl, tm) = query (BS.unpack $ encode $ GameResultsQuery sgl tm)

onStart :: MonadPlayer m => Hand -> Online 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"