diff --git a/AI/Server.hs b/AI/Server.hs new file mode 100644 index 0000000..d50db7f --- /dev/null +++ b/AI/Server.hs @@ -0,0 +1,105 @@ +module AI.Server where + +import qualified Network.Socket as Net +import qualified System.IO as Sys +import Control.Concurrent +import Control.Concurrent.Chan +import Control.Monad (forever) +import Control.Monad.Reader +import Data.List.Split + +data Buffering = NoBuffering + | LengthBuffering + | DelimiterBuffering String + deriving (Show) + +data ServerEnv = ServerEnv + { buffering :: Buffering -- ^ Buffermode + , socket :: Net.Socket -- ^ the socket used to communicate + , global :: Chan String + , onReceive :: OnReceive + } + +instance Show ServerEnv where + show env = "A Server" + +type Server = ReaderT ServerEnv IO + +type OnReceive = Sys.Handle -> Net.SockAddr -> String -> Server () + +broadcast :: String -> Server () +broadcast msg = do + bufmode <- asks buffering + chan <- asks global + case bufmode of + DelimiterBuffering delim -> liftIO $ writeChan chan $ msg ++ delim + _ -> liftIO $ writeChan chan msg + +send :: Sys.Handle -> String -> Server () +send connhdl msg = do + bufmode <- asks buffering + case bufmode of + DelimiterBuffering delim -> liftIO $ Sys.hPutStr connhdl $ msg ++ delim + _ -> liftIO $ Sys.hPutStr connhdl msg + + +-- | Initialize a new server with the given port number and buffering mode +initServer :: Net.PortNumber -> Buffering -> OnReceive -> IO ServerEnv +initServer port buffermode handler = do + sock <- Net.socket Net.AF_INET Net.Stream 0 + Net.setSocketOption sock Net.ReuseAddr 1 + Net.bind sock (Net.SockAddrInet port Net.iNADDR_ANY) + Net.listen sock 5 + chan <- newChan + forkIO $ forever $ do + msg <- readChan chan -- clearing the main channel + return () + return (ServerEnv buffermode sock chan handler) + +close :: ServerEnv -> IO () +close = Net.close . socket + +-- | Looping over requests and establish connection +procRequests :: Server () +procRequests = do + sock <- asks socket + (conn, clientaddr) <- liftIO $ Net.accept sock + env <- ask + liftIO $ forkIO $ runReaderT (procMessages conn clientaddr) env + procRequests + +-- | Handle one client +procMessages :: Net.Socket -> Net.SockAddr -> Server () +procMessages conn clientaddr = do + connhdl <- liftIO $ Net.socketToHandle conn Sys.ReadWriteMode + liftIO $ Sys.hSetBuffering connhdl Sys.NoBuffering + globalChan <- asks global + + commChan <- liftIO $ dupChan globalChan + + reader <- liftIO $ forkIO $ forever $ do + msg <- readChan commChan + Sys.hPutStrLn connhdl msg + + handler <- asks onReceive + messages <- liftIO $ Sys.hGetContents connhdl + buffermode <- asks buffering + case buffermode of + DelimiterBuffering delimiter -> + mapM_ (handler connhdl clientaddr) (splitOn delimiter messages) + LengthBuffering -> liftIO $ putStrLn (take 4 messages) + _ -> return () + + -- clean up + liftIO $ do killThread reader + Sys.hClose connhdl + +sampleHandler :: OnReceive +sampleHandler connhdl addr query = do + liftIO $ putStrLn $ "new query " ++ query + send connhdl $ "> " ++ query + +main :: IO () +main = do + env <- initServer 4242 LengthBuffering sampleHandler + runReaderT procRequests env diff --git a/AI/Socket.hs b/AI/Socket.hs new file mode 100644 index 0000000..a482bcc --- /dev/null +++ b/AI/Socket.hs @@ -0,0 +1,98 @@ +{-# 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 diff --git a/Main.hs b/Main.hs index 82b2c24..81ed765 100644 --- a/Main.hs +++ b/Main.hs @@ -9,7 +9,7 @@ import Player import Pile import AI.Stupid -import AI.Human +import AI.Socket import AI.Rulebased main :: IO () @@ -28,7 +28,9 @@ runAI = do cs = handCards Hand3 ps trs = filter (isTrump Spades) cs if length trs >= 5 && any ((==32) . getID) cs - then fst <$> evalStateT (turn Hand1) env + then do + pts <- fst <$> evalStateT (turn Hand1) env + if pts > 60 then return 1 else return 0 else runAI env :: SkatEnv @@ -42,7 +44,7 @@ envStupid = SkatEnv piles Nothing Spades pls2 playersExamp :: Players playersExamp = Players (PL $ Stupid Team Hand1) - (PL $ Stupid Team Hand2) + (PL $ mkSocketEnv Team Hand2) (PL $ mkAIEnv Single Hand3 10) pls2 :: Players