Implement basic Automaton

This commit is contained in:
Tissevert 2019-08-19 18:48:11 +02:00
parent 84251b648b
commit 00d88dcc83
4 changed files with 61 additions and 31 deletions

View File

@ -29,6 +29,7 @@ executable hannah
, hanafuda
, hanafuda-APILanguage
, mtl
, text
, websockets
hs-source-dirs: src
default-language: Haskell2010

View File

@ -2,7 +2,8 @@ module AI (
move
) where
import Hanafuda.KoiKoi (Game(..), Move(..), PlayerKey)
import Hanafuda.KoiKoi (Move(..), PlayerKey)
import Hanafuda.Message (PublicGame)
move :: PlayerKey -> Game -> Move
move :: PlayerKey -> PublicGame -> Move
move = undefined

View File

@ -1,21 +1,23 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NamedFieldPuns #-}
module Automaton (
initialState
, start
start
) where
import AI (move)
import Network.WebSockets (Connection, receiveData, sendTextData)
--import Data.Aeson
import Control.Concurrent (forkIO, threadDelay)
import Data.Aeson (encode, eitherDecode')
import Data.ByteString.Lazy.Char8 (ByteString, append, pack, putStrLn)
import qualified Data.ByteString.Lazy.Char8 as ByteString (concat)
import Data.Map (Map, empty)
import Data.ByteString.Lazy.Char8 (ByteString, pack, putStrLn)
import Data.Text (Text)
import Control.Concurrent (threadDelay)
import Control.Monad.Reader (ReaderT, ask)
import Control.Monad.State (StateT)
import Control.Monad.Trans (lift)
import Hanafuda.KoiKoi (Game(..), PlayerKey)
import qualified Hanafuda.Message as Message (T(..), FromClient(..), Room)
import Hanafuda.KoiKoi (Game, GameBlueprint(..), PlayerKey)
import qualified Hanafuda.Message as Message (T(..), FromClient(..), PublicGame, Room)
import Network.WebSockets (Connection, receiveData, sendTextData)
import Prelude hiding (error, putStrLn)
data State =
@ -27,61 +29,88 @@ data State =
| LoggedIn {
key :: PlayerKey
, room :: Message.Room
, name :: String
, name :: Text
}
| Playing {
key :: PlayerKey
, room :: Message.Room
, name :: String
, game :: Game
, name :: Text
, game :: Message.PublicGame
}
deriving Show
type App a = ReaderT Connection IO a
sendIO :: Message.FromClient -> Connection -> IO ()
sendIO message connection = do
putStrLn $ ">" `append` encoded
sendTextData connection encoded
where
encoded = encode message
send :: Message.FromClient -> App ()
send = undefined
send message =
ask >>= lift . sendIO message
receive :: App Message.T
receive = undefined
receive = do
received <- ask >>= lift . receiveData
debug $ "<" `append` received
case eitherDecode' received of
Left errorMessage -> debug (pack errorMessage) >> receive
Right message -> return message
debug :: ByteString -> App ()
debug message = lift $ putStrLn message
answer :: Message.T -> State -> App State
answer welcome@(Message.Welcome {}) Initial = do
send $ Message.LogIn {name = "Hannah"}
send $ Message.LogIn {Message.name = "Hannah"}
return $ Connected {
key = Message.key welcome
, room = Message.room welcome
}
answer (Message.Relay {Message.from, Message.message = Message.LogIn {Message.name}}) (Connected {key, room})
| from == key = return $ LoggedIn {key, room, name = Message.name}
| from == key = return $ LoggedIn {key, room, name}
answer (Message.Relay {Message.message = Message.Invitation {}}) state@(LoggedIn {key, room, name}) = do
send $ Message.Answer {Message.accept = True}
return $ Playing {key, room, name, game = undefined}
answer (Message.Relay {Message.message = Message.Invitation {}}) _ =
send $ Message.Answer {Message.accept = False} >> return state
answer (Message.Relay {Message.message = Message.Invitation {}}) state = do
send $ Message.Answer {Message.accept = False}
return state
answer game@(Message.Game {Message.game, Message.logs}) state@(Playing {key}) =
if playing == key
then send $ AI.move key game
answer (Message.Game {Message.game, Message.logs}) state@(Playing {key}) = do
if playing game == key
then send $ Message.Play {Message.move = AI.move key game}
else return ()
return $ state {game}
--answer Pong =
answer Message.Pong state = ping >> return state
answer (Message.Error {Message.error}) state =
debug $ "Received error from server : " <> pack error >> return state
answer message state = do
debug $ "Unexpected message : " <> encode message <> " in state " <> show state
answer (Message.Error {Message.error}) state = do
debug $ "Received error from server : " `append` pack error
return state
answer message state = do
debug $ ByteString.concat [
"Unexpected message : ", encode message, " in state ", pack $ show state
]
return state
ping = do
connection <- ask
setTimeout (2*s) (sendIO Message.Ping connection)
where
setTimeout delay callback =
const () <$> (lift $ forkIO (threadDelay delay >> callback))
ms = 1000
s = 1000 * ms
start :: App ()
start = loop Initial
start = ping >> loop Initial
where
loop state = do
newMessage <- receive

View File

@ -4,11 +4,10 @@ import Network.WebSockets (ClientApp, runClient)
import Control.Monad.Reader (runReaderT)
import Control.Monad.State (runStateT)
import Config (host, port, path)
import Automaton (initialState, start)
import Automaton (start)
bot :: ClientApp ()
bot connection =
fst <$> runReaderT Automaton.start connection
bot connection = runReaderT Automaton.start connection
main :: IO ()
main =