diff --git a/src/Automaton.hs b/src/Automaton.hs index c658d44..ec22a9f 100644 --- a/src/Automaton.hs +++ b/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 Empty Client.NewGame = return $ Game { +edges :: Game -> Client.Message -> Connected () +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 - log $ encode newGame - put newGame - send $ Server.Game newGame + edges game message run diff --git a/src/Game.hs b/src/Game.hs index 19fabad..55032a7 100644 --- a/src/Game.hs +++ b/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 diff --git a/src/Message/Client.hs b/src/Message/Client.hs index f96a101..755bf2f 100644 --- a/src/Message/Client.hs +++ b/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 diff --git a/src/Message/Server.hs b/src/Message/Server.hs index d5b6b7b..9c9a5b0 100644 --- a/src/Message/Server.hs +++ b/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