Start implementing a proper automaton with the new APILanguage

hannah.cabal

@@ -18,12 +18,16 @@ cabal-version:       >=1.10
 
 executable hannah
   main-is:             Main.hs
-  other-modules:       Automaton
+  other-modules:       AI
+                     , Automaton
                      , Config
   -- other-extensions:    
-  build-depends:       base >=4.9 && <4.12
+  build-depends:       aeson
+                     , base >=4.9 && <4.13
                      , bytestring
                      , containers
+                     , hanafuda
+                     , hanafuda-APILanguage
                      , mtl
                      , websockets
   hs-source-dirs:      src

src/AI.hs

@@ -0,0 +1,8 @@
+module AI (
+    move
+  ) where
+
+import Hanafuda.KoiKoi (Game(..), Move(..), PlayerKey)
+
+move :: PlayerKey -> Game -> Move
+move = undefined

src/Automaton.hs

@@ -1,43 +1,88 @@
 {-# 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, putStrLn)
+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 Prelude hiding (putStrLn)
+import Hanafuda.KoiKoi (Game(..), PlayerKey)
+import qualified Hanafuda.Message as Message (T(..), FromClient(..), Room)
+import Prelude hiding (error, putStrLn)
 
-data State = State {
+data State =
-      key :: Maybe Int
+    Initial
-    , room :: Map Int String
+  | Connected {
+        key :: PlayerKey
+      , room :: Message.Room
+    }
+  | LoggedIn {
+        key :: PlayerKey
+      , room :: Message.Room
+      , name :: String
+    }
+  | Playing {
+        key :: PlayerKey
+      , room :: Message.Room
+      , name :: String
+      , game :: Game
     }
 
-initialState :: State
+type App a = ReaderT Connection IO a
-initialState = State {
+
-      key = Nothing
+send :: Message.FromClient -> App ()
-    , room = empty
+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
     }
 
-type App a = ReaderT Connection (StateT State IO) a
+answer (Message.Relay {Message.from, Message.message = Message.LogIn {Message.name}}) (Connected {key, room})
+  | from == key = return $ LoggedIn {key, room, name = Message.name}
 
-liftIO :: IO a -> App a
+answer (Message.Relay {Message.message = Message.Invitation {}}) state@(LoggedIn {key, room, name}) = do
-liftIO = lift . lift
+  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 = do
+start = loop Initial
-  connection <- ask
-  s <- liftIO $ receiveData connection
-  liftIO $ putStrLn s
-  liftIO $ sendTextData connection ("{\"tag\": \"LogIn\", \"name\": \"Hannah\"}" :: ByteString)
-  s2 <- liftIO $ receiveData connection
-  liftIO $ putStrLn s2
-  liftIO $ threadDelay $ 1000 * ms
   where
-    ms = 1000
+    loop state = do
-
+      newMessage <- receive
+      answer newMessage state >>= loop

src/Main.hs

@@ -7,8 +7,8 @@ import Config (host, port, path)
 import Automaton (initialState, start)
 
 bot :: ClientApp ()
-bot connection = fst <$> runStateT (runReaderT Automaton.start connection) initialState
+bot connection =
-
+  fst <$> runReaderT Automaton.start connection
 
 main :: IO ()
 main =