Add two new messages for client to load an area and to move on an area

src/Automaton.hs

@@ -8,42 +8,65 @@ import Control.Monad.State (get, put)
 import Control.Monad.IO.Class (liftIO)
 import Data.Aeson (encode)
 import Data.ByteString.Lazy.Char8 (ByteString, putStrLn, unpack)
+import Data.Vector ((!))
 import Prelude hiding (log, putStrLn)
-import qualified Area (Key(..))
+import qualified Area (Key(..), dex)
 import qualified Character (new)
-import Game (Game(..), Position(..), State(..))
+import Game (Direction(..), Game(..), Position(..), State(..))
 import Message (Connected, receive, send)
 import qualified Message.Client as Client (Message(..))
 import qualified Message.Server as Server (Message(..))
 
-edges :: Game -> Client.Message -> Connected Game
+edges :: Game -> Client.Message -> Connected ()
-edges Empty Client.NewGame = return $ Game {
+edges Empty Client.NewGame = set $ Game {
       character = Character.new
     , state = At $ Position {
           area = Area.Key 0
         , x = 0
         , y = 0
+        , direction = S
       }
   }
 
-edges Empty (Client.Resume {Client.game}) = return game
+edges Empty (Client.Resume {Client.game}) = set game
 
-edges game message = do
+edges game@(Game {state = At position}) (Client.Move {Client.to}) =
+  set $ game {state = At newPosition}
+  where
+    newPosition
+      | direction position == to =
+        let (dx, dy) =
+              case to of
+                N -> (0, -1)
+                S -> (0, 1)
+                E -> (1, 0)
+                W -> (-1, 0)
+              in
+        position { x = x position + dx, y = y position + dy }
+      | otherwise = position { direction = to }
+
+edges _ (Client.Load {Client.area}) =
+  case area of
+    Area.Key n -> send . Server.Area $ Area.dex ! n
+
+edges _ message = do
   let errorMessage = "inacceptable message " `mappend` encode message `mappend` " in this context"
   send (Server.Error $ unpack errorMessage)
   log errorMessage
-  return game
 
 log :: ByteString -> Connected ()
 log line =
   liftIO $ putStrLn line
 
+set :: Game -> Connected ()
+set game = do
+  log $ encode game
+  put game
+  send $ Server.Game game
+
 run :: Connected ()
 run = do
   message <- Message.receive
   game <- get
-  newGame <- edges game message
+  edges game message
-  log $ encode newGame
-  put newGame
-  send $ Server.Game newGame
   run

src/Game.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE DeriveGeneric #-}
 module Game (
-      Game(..)
+      Direction(..)
+    , Game(..)
     , Position(..)
     , State(..)
   ) where
@@ -11,10 +12,18 @@ import GHC.Generics (Generic)
 import Character (Character)
 import qualified Area (Key)
 
+data Direction = N | S | E | W deriving (Eq, Generic)
+
+instance ToJSON Direction where
+  toEncoding = genericToEncoding defaultOptions
+instance FromJSON Direction where
+  parseJSON = genericParseJSON defaultOptions
+
 data Position = Position {
       area :: Area.Key
     , x :: Int
     , y :: Int
+    , direction :: Direction
   } deriving (Generic)
 
 instance ToJSON Position where

src/Message/Client.hs

@@ -5,13 +5,21 @@ module Message.Client (
 
 import Data.Aeson (FromJSON(..), ToJSON(..), genericParseJSON, genericToEncoding, defaultOptions)
 import GHC.Generics (Generic)
-import Game (Game)
+import qualified Area (Key)
+import Game (Game, Direction)
 
 data Message =
     NewGame
   | Resume {
       game :: Game
-    } deriving (Generic)
+    }
+  | Load {
+      area :: Area.Key
+    }
+  | Move {
+      to :: Direction
+    }
+  deriving (Generic)
 
 instance ToJSON Message where
   toEncoding = genericToEncoding defaultOptions

src/Message/Server.hs

@@ -4,6 +4,7 @@ module Message.Server (
   ) where
 
 import Data.Aeson (ToJSON(..), genericToEncoding, defaultOptions)
+import Area (Area)
 import Game (Game)
 import GHC.Generics (Generic)
 
@@ -11,7 +12,9 @@ data Message =
     Game Game
   | Error {
       error :: String
-    } deriving (Generic)
+    }
+  | Area Area
+  deriving (Generic)
 
 instance ToJSON Message where
   toEncoding = genericToEncoding defaultOptions