89 lines
2.4 KiB
Haskell
89 lines
2.4 KiB
Haskell
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE NamedFieldPuns #-}
|
|
module Automaton (
|
|
initialState
|
|
, start
|
|
) where
|
|
|
|
import AI (move)
|
|
import Network.WebSockets (Connection, receiveData, sendTextData)
|
|
--import Data.Aeson
|
|
import Data.Map (Map, empty)
|
|
import Data.ByteString.Lazy.Char8 (ByteString, pack, putStrLn)
|
|
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 Prelude hiding (error, putStrLn)
|
|
|
|
data State =
|
|
Initial
|
|
| Connected {
|
|
key :: PlayerKey
|
|
, room :: Message.Room
|
|
}
|
|
| LoggedIn {
|
|
key :: PlayerKey
|
|
, room :: Message.Room
|
|
, name :: String
|
|
}
|
|
| Playing {
|
|
key :: PlayerKey
|
|
, room :: Message.Room
|
|
, name :: String
|
|
, game :: Game
|
|
}
|
|
|
|
type App a = ReaderT Connection IO a
|
|
|
|
send :: Message.FromClient -> App ()
|
|
send = undefined
|
|
|
|
receive :: App Message.T
|
|
receive = undefined
|
|
|
|
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"}
|
|
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}
|
|
|
|
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 game@(Message.Game {Message.game, Message.logs}) state@(Playing {key}) =
|
|
if playing == key
|
|
then send $ AI.move key game
|
|
else return ()
|
|
return $ state {game}
|
|
|
|
--answer Pong =
|
|
|
|
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
|
|
return state
|
|
|
|
start :: App ()
|
|
start = loop Initial
|
|
where
|
|
loop state = do
|
|
newMessage <- receive
|
|
answer newMessage state >>= loop
|