diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,4 @@ +1.2.0.0 +======= + +* Port to GHC 8.0.1 and new libraries. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,19 @@ +gore-and-ash-demo +================= + +The repo contains proof-of-concept implementation of simple game with [Gore&Ash](https://github.com/Teaspot-Studio/gore-and-ash) engine. + +Installation +============ + +1. Install `stack` from [stackage.net](http://www.stackage.org/); +2. Run `stack install` from root directory of the repo; +3. Start server `gore-and-ash-demo 0.0.0.0 5556`; +4. Start several clients with `gore-and-ash-client localhost 5556`. + +Screenshots +=========== + +![Screenshot 1](screens/screenshot_001.png) + +![Screenshot 2](screens/screenshot_002.png) diff --git a/gore-and-ash-demo.cabal b/gore-and-ash-demo.cabal --- a/gore-and-ash-demo.cabal +++ b/gore-and-ash-demo.cabal @@ -1,5 +1,5 @@ name: gore-and-ash-demo -version: 1.1.0.0 +version: 1.2.0.0 synopsis: Demonstration game for Gore&Ash game engine description: Please see README.md homepage: https://github.com/Teaspot-Studio/gore-and-ash-demo @@ -11,6 +11,10 @@ category: Game build-type: Simple cabal-version: >=1.10 +extra-source-files: + README.md + CHANGELOG.md + stack.yaml executable gore-and-ash-demo-client hs-source-dirs: src/client diff --git a/src/client/Game.hs b/src/client/Game.hs --- a/src/client/Game.hs +++ b/src/client/Game.hs @@ -11,19 +11,19 @@ import Control.Wire.Unsafe.Event (event) import Data.Text (pack) import Prelude hiding (id, (.)) -import qualified Data.HashMap.Strict as H -import qualified Data.Sequence as S +import qualified Data.HashMap.Strict as H +import qualified Data.Sequence as S import Game.GoreAndAsh -import Game.GoreAndAsh.Actor +import Game.GoreAndAsh.Actor import Game.GoreAndAsh.Logging import Game.GoreAndAsh.Network import Game.GoreAndAsh.SDL -import Game.GoreAndAsh.Sync +import Game.GoreAndAsh.Sync import Consts -import Game.Bullet -import Game.Camera +import Game.Bullet +import Game.Camera import Game.Core import Game.Data import Game.Player @@ -34,33 +34,33 @@ mainWire = waitConnection where -- | Game stage before connection established - waitConnection = dSwitch $ proc _ -> do + waitConnection = dSwitch $ proc _ -> do e <- mapE seqLeftHead . peersConnected -< () traceEvent (const "Connected to server") -< e - returnA -< (Nothing, waitPlayerId <$> e) + returnA -< (Nothing, waitPlayerId <$> e) -- | Helper to get left most element from sequence or die - seqLeftHead s = case S.viewl s of + seqLeftHead s = case S.viewl s of S.EmptyL -> error "seqLeftHead: empty sequence" - (h S.:< _) -> h + (h S.:< _) -> h -- | After connection succeded, get important data to begin game - waitPlayerId peer = switch $ proc _ -> do + waitPlayerId peer = switch $ proc _ -> do -- Send request for player id emsg <- now -< PlayerRequestId peerSendIndexed peer (ChannelID 0) globalGameId ReliableMessage -< emsg traceEvent (const "Waiting for player id") -< emsg - + -- Waiting for respond with player id - e <- mapE seqLeftHead . filterMsgs isPlayerResponseId . peerIndexedMessages peer (ChannelID 0) globalGameId -< () + e <- mapE seqLeftHead . filterMsgs isPlayerResponseId . peerIndexedMessages peer (ChannelID 0) globalGameId -< () traceEvent (\(PlayerResponseId i _ _) -> "Got player id: " <> pack (show i)) -< e - + -- When recieved switch to next stage let nextWire = (\(PlayerResponseId i bulletsColId playersColId) -> untilDisconnected peer (PlayerId i) (fromCounter bulletsColId) (fromCounter playersColId)) <$> e returnA -< (Nothing, nextWire) -- | Main game stage, actual playing - untilDisconnected peer pid bulletsColId playersColId = switch $ proc _ -> do + untilDisconnected peer pid bulletsColId playersColId = switch $ proc _ -> do e <- peerDisconnected peer -< () traceEvent (const "Disconnected from server") -< e g <- runActor' (playGame pid peer bulletsColId playersColId) -< () @@ -71,35 +71,35 @@ -- | Controller of main game stage when actual playing is happen playGame :: PlayerId -> Peer -> RemActorCollId -> RemActorCollId -> AppActor GameId a (Maybe Game) -playGame pid peer bulletsColId playersColId = makeFixedActor globalGameId $ stateWire Nothing $ proc (_, mg) -> do +playGame pid peer bulletsColId playersColId = makeFixedActor globalGameId $ stateWire Nothing $ proc (_, mg) -> do c <- runActor' $ cameraWire initialCamera -< () - ex <- exitCheck -< () - (ps, bs) <- case mg of + exitRes <- exitCheck -< () + (ps, bs) <- case mg of Nothing -> returnA -< (H.empty, H.empty) - Just g -> do + Just g -> do ps <- processPlayers playersColId -< g bs <- processBullets bulletsColId -< g returnA -< (ps, bs) - forceNF -< Just $! case mg of + forceNF -< Just $! case mg of Nothing -> Game { gameId = globalGameId , gamePlayer = H.lookup pid ps , gameCamera = c , gamePlayers = ps , gameBullets = bs - , gameExit = ex + , gameExit = exitRes } Just g -> g { gamePlayer = H.lookup pid ps , gameCamera = c , gamePlayers = ps , gameBullets = bs - , gameExit = ex + , gameExit = exitRes } where -- | Check if user or system wants us to die - exitCheck = proc _ -> do + exitCheck = proc _ -> do e <- windowClosed mainWindowName -< () q <- liftGameMonad sdlQuitEventM -< () returnA -< event False (const True) e || q @@ -113,12 +113,12 @@ ps <- runActor' $ remoteActorCollectionClient cid peer makePlayerActor -< gameCamera g returnA -< mapFromSeq $ fmap playerId ps `S.zip` ps where - makePlayerActor i = if i == pid + makePlayerActor i = if i == pid then playerActor peer pid else remotePlayerActor peer i -- | Handles spawing/despawing of bullets processBullets :: RemActorCollId -> AppWire Game BulletMap - processBullets cid = proc g -> do + processBullets cid = proc g -> do bs <- runActor' $ remoteActorCollectionClient cid peer (bulletActor peer) -< g returnA -< mapFromSeq $ fmap bulletId bs `S.zip` bs diff --git a/src/client/Graphics/Bullet.hs b/src/client/Graphics/Bullet.hs --- a/src/client/Graphics/Bullet.hs +++ b/src/client/Graphics/Bullet.hs @@ -3,20 +3,18 @@ ) where import Consts -import Game.Camera +import Game.Camera import Game.GoreAndAsh -import Game.GoreAndAsh.SDL -import Linear -import Linear.Affine -import SDL +import Game.GoreAndAsh.SDL +import SDL -- | Function of rendering player renderBullet :: MonadSDL m => V2 Double -> V2 Double -> Camera -> GameMonadT m () -renderBullet pos vel c = do +renderBullet pos vel c = do mwr <- sdlGetWindowM mainWindowName - case mwr of + case mwr of Nothing -> return () - Just (w, r) -> do + Just (w, r) -> do wsize <- fmap (fmap fromIntegral) . get $ windowSize w rendererDrawColor r $= V4 0 0 0 255 drawLine r (apply wsize startPoint) (apply wsize endPoint) @@ -27,5 +25,5 @@ apply wsize = P . fmap round . applyTransform2D (modelMtx wsize) - modelMtx :: V2 Double -> M33 Double + modelMtx :: V2 Double -> M33 Double modelMtx wsize = viewportTransform2D 0 wsize !*! cameraMatrix c !*! translate2D pos diff --git a/src/client/Graphics/Square.hs b/src/client/Graphics/Square.hs --- a/src/client/Graphics/Square.hs +++ b/src/client/Graphics/Square.hs @@ -5,32 +5,30 @@ import Consts import Data.Word import Foreign.C.Types -import Game.Camera +import Game.Camera import Game.GoreAndAsh -import Game.GoreAndAsh.SDL -import Linear -import Linear.Affine -import SDL +import Game.GoreAndAsh.SDL +import SDL -- | Function of rendering player renderSquare :: MonadSDL m => Double -> V2 Double -> V3 Double -> Camera -> GameMonadT m () -renderSquare size pos col c = do +renderSquare size pos col c = do mwr <- sdlGetWindowM mainWindowName - case mwr of + case mwr of Nothing -> return () - Just (w, r) -> do + Just (w, r) -> do wsize <- fmap (fmap fromIntegral) . get $ windowSize w - rendererDrawColor r $= transColor col + rendererDrawColor r $= transColor col fillRect r $ Just $ transformedSquare wsize where transColor :: V3 Double -> V4 Word8 transColor (V3 r g b) = V4 (round $ r * 255) (round $ g * 255) (round $ b * 255) 255 - modelMtx :: V2 Double -> M33 Double + modelMtx :: V2 Double -> M33 Double modelMtx wsize = viewportTransform2D 0 wsize !*! cameraMatrix c !*! translate2D pos transformedSquare :: V2 Double -> Rectangle CInt - transformedSquare wsize = Rectangle (P topleft) (botright - topleft) + transformedSquare wsize = Rectangle (P topleft) (botright - topleft) where topleft = fmap round . applyTransform2D (modelMtx wsize) $ V2 (-size/2) (-size/2) botright = fmap round . applyTransform2D (modelMtx wsize) $ V2 (size/2) (size/2) diff --git a/src/client/Main.hs b/src/client/Main.hs --- a/src/client/Main.hs +++ b/src/client/Main.hs @@ -1,13 +1,13 @@ -module Main where +module Main where import Consts -import Control.DeepSeq +import Control.DeepSeq import Control.Monad (join) import Control.Monad.IO.Class import Data.Maybe (fromMaybe) -import Data.Proxy +import Data.Proxy import FPS -import Game +import Game import Game.GoreAndAsh import Game.GoreAndAsh.Network import Game.GoreAndAsh.SDL @@ -15,18 +15,18 @@ import Network.BSD (getHostByName, hostAddress) import Network.Socket (SockAddr(..)) import System.Environment -import Text.Read +import Text.Read import Linear (V4(..)) -gameFPS :: Int -gameFPS = 60 +gameFPS :: Int +gameFPS = 60 parseArgs :: IO (String, Int) -parseArgs = do - args <- getArgs - case args of - [h, p] -> case readMaybe p of +parseArgs = do + args <- getArgs + case args of + [h, p] -> case readMaybe p of Nothing -> fail "Failed to parse port" Just pint -> return (h, pint) _ -> fail "Misuse of arguments: gore-and-ash-client HOST PORT" @@ -37,15 +37,15 @@ gs <- newGameState mainWire (host, port) <- liftIO parseArgs fps <- makeFPSBounder 60 - firstLoop fps host port gs - where + firstLoop fps host port gs + where -- | Resolve given hostname and port getAddr s p = do he <- getHostByName s return $ SockAddrInet p $ hostAddress he - firstLoop fps host port gs = do - (_, gs') <- stepGame gs $ do + firstLoop fps host port gs = do + (_, gs') <- stepGame gs $ do networkSetDetailedLoggingM False syncSetLoggingM False syncSetRoleM SyncSlave @@ -53,11 +53,11 @@ addr <- liftIO $ getAddr host (fromIntegral port) _ <- networkConnect addr 2 0 _ <- sdlCreateWindowM mainWindowName "Gore&Ash Client" defaultWindow defaultRenderer - sdlSetBackColor mainWindowName $ V4 200 200 200 255 + sdlSetBackColor mainWindowName $ Just $ V4 200 200 200 255 gameLoop fps gs' gameLoop fps gs = do - waitFPSBound fps + waitFPSBound fps (mg, gs') <- stepGame gs (return ()) mg `deepseq` if fromMaybe False $ gameExit <$> join mg then cleanupGameState gs' diff --git a/src/server/Game/Player.hs b/src/server/Game/Player.hs --- a/src/server/Game/Player.hs +++ b/src/server/Game/Player.hs @@ -20,10 +20,10 @@ import Game.GoreAndAsh import Game.GoreAndAsh.Actor import Game.GoreAndAsh.Logging -import Game.GoreAndAsh.Network +import Game.GoreAndAsh.Network import Game.GoreAndAsh.Sync -playerActor :: (PlayerId -> Player) -> AppActor PlayerId Game Player +playerActor :: (PlayerId -> Player) -> AppActor PlayerId Game Player playerActor initialPlayer = makeActor $ \i -> stateWire (initialPlayer i) $ mainController i where mainController i = proc (g, p) -> do @@ -36,7 +36,7 @@ -- | Handle when player is shot playerShot :: AppWire Player Player - playerShot = proc p -> do + playerShot = proc p -> do emsg <- actorMessages i isPlayerShotMessage -< () let newPlayer = p { playerPos = 0 @@ -44,31 +44,31 @@ returnA -< event p (const newPlayer) emsg -- | Process player specific net messages - netProcess :: Player -> PlayerNetMessage -> GameMonadT AppMonad Player - netProcess p msg = case msg of - NetMsgPlayerFire v -> do - let d = normalize v + netProcess :: Player -> PlayerNetMessage -> GameMonadT AppMonad Player + netProcess p msg = case msg of + NetMsgPlayerFire v -> do + let d = normalize v v2 a = V2 a a pos = playerPos p + d * v2 (playerSize p * 1.5) vel = d * v2 bulletSpeed - putMsgLnM $ "Fire bullet at " <> pack (show pos) <> " with velocity " <> pack (show vel) + putMsgLnM LogInfo $ "Fire bullet at " <> pack (show pos) <> " with velocity " <> pack (show vel) actorSendM globalGameId $ GameSpawnBullet pos vel $ playerId p - return p + return p -- | Process global net messages from given peer (player) globalNetProcess :: (Game, Player) -> GameNetMessage -> GameMonadT AppMonad (Game, Player) - globalNetProcess (g, p) msg = case msg of + globalNetProcess (g, p) msg = case msg of PlayerRequestId -> do - peerSendIndexedM peer (ChannelID 0) globalGameId ReliableMessage $ + peerSendIndexedM peer (ChannelID 0) globalGameId ReliableMessage $ PlayerResponseId (toCounter i) (toCounter $ gameBulletColId g) (toCounter $ gamePlayerColId g) return (g, p) - _ -> do - putMsgLnM $ pack $ show msg - return (g, p) + _ -> do + putMsgLnM LogInfo $ pack $ show msg + return (g, p) - playerSync :: FullSync AppMonad PlayerId Player - playerSync = Player - <$> pure i + playerSync :: FullSync AppMonad PlayerId Player + playerSync = Player + <$> pure i <*> clientSide peer 0 playerPos <*> clientSide peer 1 playerColor <*> clientSide peer 2 playerRot diff --git a/stack.yaml b/stack.yaml new file mode 100644 --- /dev/null +++ b/stack.yaml @@ -0,0 +1,39 @@ +# For more information, see: https://github.com/commercialhaskell/stack/blob/release/doc/yaml_configuration.md + +# Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2) +resolver: lts-7.9 + +# Local packages, usually specified by relative directory name +packages: +- '.' + +# Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3) +extra-deps: +- typesafe-endian-0.1.0.1 +- gore-and-ash-1.2.2.0 +- gore-and-ash-actor-1.2.2.0 +- gore-and-ash-logging-2.0.1.0 +- gore-and-ash-network-1.4.0.0 +- gore-and-ash-sync-1.2.0.1 +- gore-and-ash-sdl-2.1.1.0 + +# Override default flag values for local packages and extra-deps +flags: {} + +# Extra package databases containing global packages +extra-package-dbs: [] + +# Control whether we use the GHC we find on the path +# system-ghc: true + +# Require a specific version of stack, using version ranges +# require-stack-version: -any # Default +# require-stack-version: >= 0.1.4.0 + +# Override the architecture used by stack, especially useful on Windows +# arch: i386 +# arch: x86_64 + +# Extra directories used by stack for building +# extra-include-dirs: [/path/to/dir] +# extra-lib-dirs: [/path/to/dir]