From 84251b648b470952057fac0629cc007d42448a5b Mon Sep 17 00:00:00 2001
From: Tissevert <tissevert+devel@marvid.fr>
Date: Sun, 18 Aug 2019 22:11:57 +0200
Subject: [PATCH] Start implementing a proper automaton with the new
 APILanguage

---
 hannah.cabal     |  8 +++--
 src/AI.hs        |  8 +++++
 src/Automaton.hs | 93 +++++++++++++++++++++++++++++++++++-------------
 src/Main.hs      |  4 +--
 4 files changed, 85 insertions(+), 28 deletions(-)
 create mode 100644 src/AI.hs

diff --git a/hannah.cabal b/hannah.cabal
index b268904..cbc3966 100644
--- a/hannah.cabal
+++ b/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
diff --git a/src/AI.hs b/src/AI.hs
new file mode 100644
index 0000000..5335beb
--- /dev/null
+++ b/src/AI.hs
@@ -0,0 +1,8 @@
+module AI (
+    move
+  ) where
+
+import Hanafuda.KoiKoi (Game(..), Move(..), PlayerKey)
+
+move :: PlayerKey -> Game -> Move
+move = undefined
diff --git a/src/Automaton.hs b/src/Automaton.hs
index 77fc8e0..ab8b99a 100644
--- a/src/Automaton.hs
+++ b/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 {
-      key :: Maybe Int
-    , room :: Map Int String
-  }
+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
+    }
 
-initialState :: State
-initialState = State {
-      key = Nothing
-    , room = empty
-  }
+type App a = ReaderT Connection IO a
 
-type App a = ReaderT Connection (StateT State IO) a
+send :: Message.FromClient -> App ()
+send = undefined
 
-liftIO :: IO a -> App a
-liftIO = lift . lift
+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 = do
-  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
+start = loop Initial
   where
-    ms = 1000
-
+    loop state = do
+      newMessage <- receive
+      answer newMessage state >>= loop
diff --git a/src/Main.hs b/src/Main.hs
index 6ef5a2a..0d40875 100644
--- a/src/Main.hs
+++ b/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 =