skat/AI/Socket.hs

{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}

module AI.Socket (
    mkSocketEnv
) where

import Control.Monad.Trans (liftIO)
import Control.Monad.Reader
import Control.Monad.State
import Control.Concurrent
import Control.Concurrent.Chan

import Player
import Pile
import Card
import Utils
import Render
import AI.Server

data SocketEnv = SocketEnv { getTeam :: Team
                           , getHand :: Hand
                           , table :: [CardS Played]
                           , myHand :: [Card]
                           , socketThread :: Maybe ThreadId
                           , socketServer :: Maybe ServerEnv }
                  deriving Show

setTable :: [CardS Played] -> SocketEnv -> SocketEnv
setTable tab env = env { table = tab }

setHand :: [Card] -> SocketEnv -> SocketEnv
setHand hand env = env { myHand = hand }

setSocket :: ThreadId -> SocketEnv -> SocketEnv
setSocket n env = env { socketThread = Just n }

clearSocket :: SocketEnv -> SocketEnv
clearSocket env = env { socketThread = Nothing }

setServer :: ServerEnv -> SocketEnv -> SocketEnv
setServer s env = env { socketServer = Just s }

type Socket m = StateT SocketEnv m

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

instance Player SocketEnv where
    team = getTeam
    hand = getHand
    chooseCard p table _ hand = runStateT (do
        modify $ setTable table
        modify $ setHand hand
        choose) p

choose :: MonadPlayer m => Socket m Card
choose = do
    initialize
    trumpCol <- trumpColour
    turnCol <- turnColour
    hand <- gets myHand
    (Just server) <- gets socketServer
    liftIO $ writeChan (global server) "hi"
    let possible = filter (isAllowed trumpCol turnCol hand) hand
    case length hand of
        1 -> liftIO (putStrLn "stopping server") >> stop
        _ -> return ()
    return $ head possible

initialize :: MonadPlayer m => Socket m ()
initialize = do
    state <- gets socketThread
    case state of
        Just _ -> return ()
        Nothing -> do
            liftIO $ putStrLn "initializing server"
            server <- liftIO $ initServer 4242 (DelimiterBuffering "\n") sampleHandler
            n <- liftIO $ forkIO $ runReaderT procRequests server
            modify $ setSocket n
            modify $ setServer server

stop :: MonadPlayer m => Socket m ()
stop = do
    state <- gets socketThread
    case state of
        Just n -> do liftIO $ putStrLn "killing thread"
                     liftIO $ killThread n
                     modify clearSocket
                     Just server <- gets socketServer
                     liftIO $ close server
        Nothing -> return ()

mkSocketEnv :: Team -> Hand -> SocketEnv
mkSocketEnv tm h = SocketEnv tm h [] [] Nothing Nothing