gore-and-ash-demo 1.1.0.0 → 1.2.0.0
raw patch · 9 files changed
+142/−80 lines, 9 files
Files
- CHANGELOG.md +4/−0
- README.md +19/−0
- gore-and-ash-demo.cabal +5/−1
- src/client/Game.hs +25/−25
- src/client/Graphics/Bullet.hs +7/−9
- src/client/Graphics/Square.hs +9/−11
- src/client/Main.hs +17/−17
- src/server/Game/Player.hs +17/−17
- stack.yaml +39/−0
+ CHANGELOG.md view
@@ -0,0 +1,4 @@+1.2.0.0+=======++* Port to GHC 8.0.1 and new libraries.
+ README.md view
@@ -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+===========++++
gore-and-ash-demo.cabal view
@@ -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
src/client/Game.hs view
@@ -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
src/client/Graphics/Bullet.hs view
@@ -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
src/client/Graphics/Square.hs view
@@ -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)
src/client/Main.hs view
@@ -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'
src/server/Game/Player.hs view
@@ -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
+ stack.yaml view
@@ -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]