Browse Source

Implement basic Automaton

main
Tissevert 3 years ago
parent
commit
00d88dcc83
  1. 1
      hannah.cabal
  2. 5
      src/AI.hs
  3. 77
      src/Automaton.hs
  4. 5
      src/Main.hs

1
hannah.cabal

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

5
src/AI.hs

@ -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

77
src/Automaton.hs

@ -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.Error {Message.error}) state = do
debug $ "Received error from server : " `append` pack error
return state
answer message state = do
debug $ "Unexpected message : " <> encode message <> " in state " <> show state
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

5
src/Main.hs

@ -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 =

Loading…
Cancel
Save