packages feed

gore-and-ash-demo (empty) → 1.0.0.0

raw patch · 27 files changed

+1534/−0 lines, 27 filesdep +GLFW-bdep +OpenGLdep +basesetup-changed

Dependencies added: GLFW-b, OpenGL, base, bytestring, cereal, containers, deepseq, exception-transformers, exceptions, gore-and-ash, gore-and-ash-actor, gore-and-ash-logging, gore-and-ash-network, gore-and-ash-sdl, gore-and-ash-sync, hashable, lens, linear, network, sdl2, text, text-show, time, transformers, unordered-containers, vector

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Gushcha Anton (c) 2015-2016++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of  nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ gore-and-ash-demo.cabal view
@@ -0,0 +1,136 @@+name:                gore-and-ash-demo+version:             1.0.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+license:             BSD3+license-file:        LICENSE+author:              Anton Gushcha+maintainer:          ncrashed@gmail.com+copyright:           2015-2016 Anton Gushcha+category:            Game+build-type:          Simple+cabal-version:       >=1.10++executable gore-and-ash-demo-client+  hs-source-dirs:      src/client+                       src/shared+  main-is:             Main.hs+  default-language:    Haskell2010+  +  other-modules:       +                       Consts+                       FPS+                       Game+                       Game.Bullet+                       Game.Bullet.Data+                       Game.Bullet.Shared+                       Game.Camera+                       Game.Core+                       Game.Data+                       Game.Player+                       Game.Player.Data+                       Game.Player.Shared+                       Game.Shared+                       Graphics.Bullet+                       Graphics.Square+                       +  build-depends:       base >= 4.7 && < 5+                     , bytestring >= 0.10.6.0+                     , cereal >= 0.4.1.1+                     , containers >= 0.5.6.2+                     , deepseq >= 1.4+                     , exception-transformers >= 0.4+                     , exceptions >= 0.8.0.2+                     , GLFW-b >= 1.4.7.3+                     , gore-and-ash >= 1.1.0.0+                     , gore-and-ash-actor >= 1.1.0.0+                     , gore-and-ash-logging >= 1.1.0.0+                     , gore-and-ash-network >= 1.1.0.0+                     , gore-and-ash-sdl >= 1.1.0.0+                     , gore-and-ash-sync >= 1.1.0.0+                     , hashable >= 1.2.3.3+                     , lens >= 4.12.3+                     , linear >= 1.19+                     , network >= 2.6.2.1+                     , OpenGL >= 3.0.0.0+                     , sdl2 >= 2.1.1 +                     , text >= 1.2.1+                     , text-show >= 2+                     , transformers >= 0.4.2+                     , unordered-containers >= 0.2.5.1+                     , vector >= 0.11.0.0++  default-extensions:  +                       Arrows+                       DataKinds+                       DeriveGeneric+                       FlexibleContexts+                       FlexibleInstances+                       GeneralizedNewtypeDeriving+                       MultiParamTypeClasses+                       OverloadedStrings+                       RankNTypes+                       RecordWildCards+                       TypeFamilies+                       ++  ghc-options: -Wall -threaded++executable gore-and-ash-demo-server+  hs-source-dirs:      src/server+                       src/shared+  main-is:             Main.hs+  default-language:    Haskell2010+  +  other-modules:       +                       FPS+                       Game+                       Game.Bullet+                       Game.Bullet.Data+                       Game.Bullet.Shared+                       Game.Core+                       Game.Data+                       Game.Player+                       Game.Player.Data+                       Game.Player.Shared+                       Game.Shared+                       +  build-depends:       base >= 4.7 && < 5+                     , bytestring >= 0.10.6.0+                     , cereal >= 0.4.1.1+                     , containers >= 0.5.6.2+                     , deepseq >= 1.4+                     , exception-transformers >= 0.4+                     , exceptions >= 0.8.0.2                     +                     , gore-and-ash >= 1.1.0.0+                     , gore-and-ash-actor >= 1.1.0.0+                     , gore-and-ash-logging >= 1.1.0.0+                     , gore-and-ash-network >= 1.1.0.0+                     , gore-and-ash-sync >= 1.1.0.0+                     , hashable >= 1.2.3.3+                     , lens >= 4.12.3+                     , linear >= 1.19+                     , network >= 2.6.2.1+                     , text >= 1.2.1+                     , text-show >= 2+                     , time >= 1.5.0.1+                     , transformers >= 0.4.2+                     , unordered-containers >= 0.2.5.1+                     +  default-extensions:  +                       Arrows+                       DataKinds+                       DeriveGeneric+                       FlexibleContexts+                       FlexibleInstances+                       GeneralizedNewtypeDeriving+                       MultiParamTypeClasses+                       OverloadedStrings+                       RankNTypes+                       RecordWildCards+                       ScopedTypeVariables+                       TupleSections+                       TypeFamilies+                       +  ghc-options: -Wall -threaded
+ src/client/Consts.hs view
@@ -0,0 +1,6 @@+module Consts where++import Data.Text ++mainWindowName :: Text+mainWindowName = "mainWindow"
+ src/client/Game.hs view
@@ -0,0 +1,124 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Game(+    mainWire+  , Player(..)+  , Camera(..)+  , Game(..)+  , AppMonad+  ) where++import Control.Wire+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 Game.GoreAndAsh+import Game.GoreAndAsh.Actor +import Game.GoreAndAsh.Logging+import Game.GoreAndAsh.Network+import Game.GoreAndAsh.SDL+import Game.GoreAndAsh.Sync ++import Consts+import Game.Bullet +import Game.Camera +import Game.Core+import Game.Data+import Game.Player+import Game.Shared++-- | Entry point of the game, controls global game stages+mainWire :: AppWire a (Maybe Game)+mainWire = waitConnection+  where+    -- | Game stage before connection established+    waitConnection = dSwitch $ proc _ -> do +      e <- mapE seqLeftHead . peersConnected -< ()+      traceEvent (const "Connected to server") -< e+      returnA -< (Nothing, waitPlayerId <$> e) ++    -- | Helper to get left most element from sequence or die+    seqLeftHead s = case S.viewl s of +      S.EmptyL -> error "seqLeftHead: empty sequence"+      (h S.:< _) -> h ++    -- | After connection succeded, get important data to begin game+    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 -< () +      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 +      e <- peerDisconnected peer -< ()+      traceEvent (const "Disconnected from server") -< e+      g <- runActor' (playGame pid peer bulletsColId playersColId) -< ()+      returnA -< (g, const disconnected <$> e)++    -- | Final stage, we are disconnected+    disconnected = pure Nothing++-- | 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 +  c <- runActor' $ cameraWire initialCamera -< ()+  ex <- exitCheck -< ()+  (ps, bs) <- case mg of +    Nothing -> returnA -< (H.empty, H.empty)+    Just g -> do +      ps <- processPlayers playersColId -< g+      bs <- processBullets bulletsColId -< g+      returnA -< (ps, bs)++  forceNF -< Just $! case mg of +    Nothing -> Game {+        gameId = globalGameId+      , gamePlayer = H.lookup pid ps+      , gameCamera = c+      , gamePlayers = ps+      , gameBullets = bs+      , gameExit = ex+      }+    Just g -> g {+        gamePlayer = H.lookup pid ps+      , gameCamera = c+      , gamePlayers = ps+      , gameBullets = bs+      , gameExit = ex+      }+  where+  -- | Check if user or system wants us to die+  exitCheck = proc _ -> do +    e <- windowClosed mainWindowName -< ()+    q <- liftGameMonad sdlQuitEventM -< ()+    returnA -< event False (const True) e || q++  -- | Maker of startup camera+  initialCamera i = Camera i 0 0.1++  -- | Handles spawing/despawing of other players+  processPlayers :: RemActorCollId -> AppWire Game PlayerMap+  processPlayers cid = proc g -> do+    ps <- runActor' $ remoteActorCollectionClient cid peer makePlayerActor -< gameCamera g+    returnA -< mapFromSeq $ fmap playerId ps `S.zip` ps+    where+      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 +    bs <- runActor' $ remoteActorCollectionClient cid peer (bulletActor peer) -< g+    returnA -< mapFromSeq $ fmap bulletId bs `S.zip` bs
+ src/client/Game/Bullet.hs view
@@ -0,0 +1,45 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Game.Bullet(+    module ReExport+  , bulletActor+  ) where++import Control.Wire +import Prelude hiding (id, (.))++import Game.Bullet.Data as ReExport+import Game.Core +import Game.Data ++import Game.GoreAndAsh+import Game.GoreAndAsh.Sync +import Game.GoreAndAsh.Actor+import Game.GoreAndAsh.Network ++import Graphics.Bullet++instance RemoteActor BulletId Bullet where+  type RemoteActorState BulletId = Bullet+  type RemoteActorId Bullet = BulletId++bulletActor :: Peer -> BulletId -> AppActor BulletId Game Bullet +bulletActor peer i = makeFixedActor i $ stateWire initalBullet mainController+  where+  initalBullet = Bullet {+      bulletId = i+    , bulletPos = 0+    , bulletVel = 0+    , bulletOwner = fromCounter (-1)+    }++  mainController :: AppWire (Game, Bullet) Bullet+  mainController = proc (g, b) -> do+    liftGameMonad3 renderBullet -< (bulletPos b, bulletVel b, gameCamera g)+    forceNF . clientSync bulletSync peer i -< b++  bulletSync :: FullSync AppMonad BulletId Bullet+  bulletSync = Bullet +    <$> pure i +    <*> serverSide 0 bulletPos +    <*> serverSide 1 bulletVel +    <*> serverSide 2 bulletOwner
+ src/client/Game/Bullet/Data.hs view
@@ -0,0 +1,43 @@+module Game.Bullet.Data(+    BulletId(..)+  , Bullet(..)+  , BulletMessage(..)+  , BulletNetMessage+  ) where++import Control.DeepSeq+import Data.Hashable+import Data.Typeable +import GHC.Generics (Generic)+import Linear+import Prelude hiding (id, (.))++import Game.GoreAndAsh.Actor+import Game.GoreAndAsh.Sync++import Game.Player.Data +import Game.Bullet.Shared++data Bullet = Bullet {+  bulletId :: !BulletId+, bulletPos :: !(V2 Double)+, bulletVel :: !(V2 Double)+, bulletOwner :: !PlayerId+} deriving (Generic)++instance NFData Bullet ++newtype BulletId = BulletId { unBulletId :: Int } deriving (Eq, Show, Generic) +instance NFData BulletId +instance Hashable BulletId ++data BulletMessage = BulletMessageStub deriving (Typeable, Generic)+instance NFData BulletMessage ++instance ActorMessage BulletId where+  type ActorMessageType BulletId = BulletMessage+  toCounter = unBulletId+  fromCounter = BulletId+  +instance NetworkMessage BulletId where +  type NetworkMessageType BulletId = BulletNetMessage
+ src/client/Game/Camera.hs view
@@ -0,0 +1,80 @@+module Game.Camera(+    Camera(..)+  , CameraId(..)+  , cameraWire+  , cameraMatrix+  , cameraToWorld+  , cameraFromWorld+  ) where++import Control.DeepSeq+import Control.Lens +import Control.Wire+import Control.Wire.Unsafe.Event+import GHC.Generics (Generic)+import Linear+import Prelude hiding (id, (.))++import Game.Core+import Game.GoreAndAsh+import Game.GoreAndAsh.Actor+import Game.GoreAndAsh.SDL++data Camera = Camera {+  cameraId :: !CameraId+, cameraPos :: !(V2 Double)+, cameraZoom :: !Double+} deriving (Generic)++instance NFData Camera ++newtype CameraId = CameraId { unCameraId :: Int } deriving (Eq, Show, Generic)+instance NFData CameraId ++data CameraMessage++instance ActorMessage CameraId where+  type ActorMessageType CameraId = CameraMessage+  toCounter = unCameraId+  fromCounter = CameraId++cameraWire :: (CameraId -> Camera) -> AppActor CameraId a Camera +cameraWire initialCamera = makeActor $ \i -> stateWire (initialCamera i) $ proc (_, c) -> do +  forceNF+    . moveCamera (V2 0 (-cameraSpeed)) ScancodeS +    . moveCamera (V2 0 cameraSpeed) ScancodeW +    . moveCamera (V2 cameraSpeed 0) ScancodeD+    . moveCamera (V2 (-cameraSpeed) 0) ScancodeA+    . zoomCamera 0.1 -< c+  where +    cameraSpeed :: Double +    cameraSpeed = 0.1++    moveCamera :: V2 Double -> Scancode -> AppWire Camera Camera+    moveCamera dv k = proc c -> do +      e <- keyPressing k -< ()+      let newCam = c {+            cameraPos = cameraPos c + dv +          }+      returnA -< event c (const newCam) e++    zoomCamera :: Double -> AppWire Camera Camera +    zoomCamera z = proc c -> do +      e <- mouseScrollY -< ()+      let newCam k = c {+            cameraZoom = min 3 $ max 0.01 $ cameraZoom c + 0.2 * z * k+          }+      returnA -< event c (newCam . fromIntegral) e ++-- | Calculate transformation matrix for camera+cameraMatrix :: Camera -> M33 Double+cameraMatrix Camera{..} = translate2D (V2 (-cameraPos^._x) (-cameraPos^._y))+  !*! scale2D (V2 (-cameraZoom) (-cameraZoom))++-- | Transform camera local coords to world+cameraToWorld :: Camera -> V2 Double -> V2 Double+cameraToWorld c v = inv33 (cameraMatrix c) `applyTransform2D` v++-- | Transform world coords to camera coords+cameraFromWorld :: Camera -> V2 Double -> V2 Double +cameraFromWorld c v = cameraMatrix c `applyTransform2D` v
+ src/client/Game/Core.hs view
@@ -0,0 +1,58 @@+module Game.Core(+    AppMonad(..)+  , AppWire+  , AppActor+  ) where++import Control.DeepSeq+import Control.Monad.Catch+import Control.Monad.Fix+import Control.Monad.IO.Class+import Control.Wire+import Data.Proxy +import Game.GoreAndAsh+import GHC.Generics (Generic)+import Prelude hiding (id, (.))++import Game.GoreAndAsh.Actor+import Game.GoreAndAsh.Logging+import Game.GoreAndAsh.Network+import Game.GoreAndAsh.SDL +import Game.GoreAndAsh.Sync ++-- | Application monad is monad stack build from given list of modules over base monad (IO)+type AppStack = ModuleStack [LoggingT, ActorT, NetworkT, SyncT, SDLT] IO+newtype AppState = AppState (ModuleState AppStack)+  deriving (Generic)++instance NFData AppState ++-- | Wrapper around type family+newtype AppMonad a = AppMonad (AppStack a)+  deriving (Functor, Applicative, Monad, MonadFix, MonadIO, LoggingMonad, NetworkMonad, ActorMonad, MonadCatch, MonadThrow, MonadSDL)++-- | Current GHC (7.10.3) isn't able to derive this+instance SyncMonad AppMonad where +  getSyncIdM = AppMonad . getSyncIdM+  getSyncTypeRepM = AppMonad . getSyncTypeRepM+  registerSyncIdM = AppMonad . registerSyncIdM+  addSyncTypeRepM a b = AppMonad $ addSyncTypeRepM a b+  syncScheduleMessageM peer ch i mt msg  = AppMonad $ syncScheduleMessageM peer ch i mt msg+  syncSetLoggingM = AppMonad . syncSetLoggingM+  syncSetRoleM = AppMonad . syncSetRoleM+  syncGetRoleM = AppMonad syncGetRoleM+  syncRequestIdM a b = AppMonad $ syncRequestIdM a b +  +instance GameModule AppMonad AppState where +  type ModuleState AppMonad = AppState+  runModule (AppMonad m) (AppState s) = do +    (a, s') <- runModule m s +    return (a, AppState s')+  newModuleState = AppState <$> newModuleState+  withModule _ = withModule (Proxy :: Proxy AppStack)+  cleanupModule (AppState s) = cleanupModule s ++-- | Arrow that is build over the monad stack+type AppWire a b = GameWire AppMonad a b+-- | App actor that is monadic action to create indexed wire+type AppActor i a b = GameActor AppMonad i a b
+ src/client/Game/Data.hs view
@@ -0,0 +1,42 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Game.Data(+    BulletMap+  , PlayerMap+  , Game(..)+  ) where++import Control.DeepSeq+import Game.Shared+import GHC.Generics+import qualified Data.HashMap.Strict as H ++import Game.Bullet.Data+import Game.Camera +import Game.Player.Data ++import Game.GoreAndAsh.Actor +import Game.GoreAndAsh.Sync ++type BulletMap = H.HashMap BulletId Bullet+type PlayerMap = H.HashMap PlayerId Player ++data Game = Game {+  gameId :: !GameId+, gamePlayer :: !(Maybe Player)+, gameCamera :: !Camera+, gamePlayers :: !PlayerMap+, gameBullets :: !BulletMap+, gameExit :: !Bool+} deriving (Generic)++instance NFData Game ++data GameMessage ++instance ActorMessage GameId where+  type ActorMessageType GameId = GameMessage +  toCounter = unGameId+  fromCounter = GameId++instance NetworkMessage GameId where +  type NetworkMessageType GameId = GameNetMessage
+ src/client/Game/Player.hs view
@@ -0,0 +1,95 @@+module Game.Player(+    module ReExport+  , playerActor+  , remotePlayerActor+  ) where++import Control.Wire+import Control.Wire.Unsafe.Event+import Linear+import Prelude hiding (id, (.))++import Game.Core+import Game.GoreAndAsh+import Game.GoreAndAsh.Actor+import Game.GoreAndAsh.Network+import Game.GoreAndAsh.SDL +import Game.GoreAndAsh.Sync++import Game.Camera +import Game.Player.Data as ReExport+import Graphics.Square++playerActor :: Peer -> PlayerId -> AppActor PlayerId Camera Player +playerActor peer i = makeFixedActor i $ stateWire initialPlayer $ proc (c, p) -> do +  processFire -< (c, p)+  liftGameMonad4 renderSquare -< (playerSize p, playerPos p, playerColor p, c)+  forceNF . clientSync playerSync peer i . controlPlayer -< p+  where+    initialPlayer = Player {+        playerId = i +      , playerPos = 0+      , playerColor = V3 1 0 0+      , playerRot = 0+      , playerSpeed = 0.5+      , playerSize = 1+      }+      +    controlPlayer :: AppWire Player Player+    controlPlayer = +        movePlayer (V2 (-1) 0) ScancodeRight+      . movePlayer (V2 1 0) ScancodeLeft+      . movePlayer (V2 0 1) ScancodeDown+      . movePlayer (V2 0 (-1)) ScancodeUp++    movePlayer :: V2 Double -> Scancode -> AppWire Player Player+    movePlayer dv k = proc p -> do +      e <- keyPressing k -< ()+      dt <- deltaTime -< ()+      let newPlayer = p {+            playerPos = playerPos p + dv * v2 (dt * playerSpeed p)+          }+          v2 a = V2 a a+      returnA -< event p (const newPlayer) e++    processFire :: AppWire (Camera, Player) ()+    processFire = proc (c, p) -> do +      e <- mouseClick ButtonLeft -< ()+      let wpos = cameraToWorld c <$> e+      let edir = (\v -> normalize $ v - playerPos p) <$> wpos +      let emsg = NetMsgPlayerFire <$> edir+      peerSendIndexed peer (ChannelID 0) i ReliableMessage -< emsg+      returnA -< ()++    playerSync :: FullSync AppMonad PlayerId Player +    playerSync = Player +      <$> pure i +      <*> clientSide peer 0 playerPos+      <*> clientSide peer 1 playerColor+      <*> clientSide peer 2 playerRot+      <*> clientSide peer 3 playerSpeed+      <*> clientSide peer 4 playerSize++-- | Actor for updating local state of remote player on server+remotePlayerActor :: Peer -> PlayerId -> AppActor PlayerId Camera Player+remotePlayerActor peer i = makeFixedActor i $ stateWire initPlayer $ proc (c, p) -> do +    liftGameMonad4 renderSquare -< (playerSize p, playerPos p, playerColor p, c)+    forceNF . clientSync playerSync peer i -< p+    where+    initPlayer = Player {+        playerId = i +      , playerPos = 0 +      , playerColor = 0+      , playerRot = 0+      , playerSpeed = 0+      , playerSize = 1+      }++    playerSync :: FullSync AppMonad PlayerId Player +    playerSync = Player +      <$> pure i +      <*> serverSide 0 playerPos+      <*> serverSide 1 playerColor+      <*> serverSide 2 playerRot+      <*> serverSide 3 playerSpeed+      <*> serverSide 4 playerSize
+ src/client/Game/Player/Data.hs view
@@ -0,0 +1,50 @@+module Game.Player.Data(+    Player(..)+  , PlayerId(..)+  , PlayerMessage(..)+  , PlayerNetMessage(..)+  ) where++import Control.DeepSeq+import Data.Hashable+import Data.Serialize+import Data.Typeable+import GHC.Generics (Generic)+import Linear+import Prelude hiding (id, (.))++import Game.GoreAndAsh.Actor+import Game.GoreAndAsh.Sync++import Game.Player.Shared++data Player = Player {+  playerId :: !PlayerId+, playerPos :: !(V2 Double)+, playerColor :: !(V3 Double) +, playerRot :: !Double+, playerSpeed :: !Double+, playerSize :: !Double+} deriving (Generic, Show)++instance NFData Player ++newtype PlayerId = PlayerId { unPlayerId :: Int } deriving (Eq, Show, Generic)+instance NFData PlayerId +instance Serialize PlayerId +instance Hashable PlayerId ++data PlayerMessage = PlayerMessageStub deriving (Typeable, Generic)+instance NFData PlayerMessage ++instance ActorMessage PlayerId where+  type ActorMessageType PlayerId = PlayerMessage+  toCounter = unPlayerId+  fromCounter = PlayerId++instance NetworkMessage PlayerId where +  type NetworkMessageType PlayerId = PlayerNetMessage++instance RemoteActor PlayerId Player where+  type RemoteActorState PlayerId = Player+  type RemoteActorId Player = PlayerId
+ src/client/Graphics/Bullet.hs view
@@ -0,0 +1,31 @@+module Graphics.Bullet(+    renderBullet+  ) where++import Consts+import Game.Camera +import Game.GoreAndAsh+import Game.GoreAndAsh.SDL +import Linear+import Linear.Affine+import SDL ++-- | Function of rendering player+renderBullet :: MonadSDL m => V2 Double -> V2 Double -> Camera -> GameMonadT m ()+renderBullet pos vel c = do  +  mwr <- sdlGetWindowM mainWindowName+  case mwr of +    Nothing -> return ()+    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)+  where+    velScaleFactor = 0.04+    startPoint = negate (velScaleFactor * 0.5 * vel)+    endPoint = velScaleFactor * 0.5 * vel++    apply wsize = P . fmap round . applyTransform2D (modelMtx wsize)++    modelMtx :: V2 Double -> M33 Double +    modelMtx wsize = viewportTransform2D 0 wsize !*! cameraMatrix c !*! translate2D pos
+ src/client/Graphics/Square.hs view
@@ -0,0 +1,36 @@+module Graphics.Square(+    renderSquare+  ) where++import Consts+import Data.Word+import Foreign.C.Types+import Game.Camera +import Game.GoreAndAsh+import Game.GoreAndAsh.SDL +import Linear+import Linear.Affine+import SDL ++-- | Function of rendering player+renderSquare :: MonadSDL m => Double -> V2 Double -> V3 Double -> Camera -> GameMonadT m ()+renderSquare size pos col c = do  +  mwr <- sdlGetWindowM mainWindowName+  case mwr of +    Nothing -> return ()+    Just (w, r) -> do +      wsize <- fmap (fmap fromIntegral) . get $ windowSize w+      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 wsize = viewportTransform2D 0 wsize !*! cameraMatrix c !*! translate2D pos++    transformedSquare :: V2 Double -> Rectangle CInt+    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
@@ -0,0 +1,87 @@+module Main where  ++import Consts+import Control.DeepSeq +import Control.Monad (join)+import Control.Monad.IO.Class+import Data.Maybe (fromMaybe)+import Data.Proxy +import FPS+import Game +import Game.GoreAndAsh+import Game.GoreAndAsh.Network+import Game.GoreAndAsh.SDL+import Game.GoreAndAsh.Sync+import Network.BSD (getHostByName, hostAddress)+import Network.Socket (SockAddr(..))+import System.Environment+import Text.Read ++import Linear (V4(..))++gameFPS :: Int +gameFPS = 60 ++parseArgs :: IO (String, Int)+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"+++main :: IO ()+main = withModule (Proxy :: Proxy AppMonad) $ do+  gs <- newGameState mainWire+  (host, port) <- liftIO parseArgs+  fps <- makeFPSBounder 60+  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 +        networkSetDetailedLoggingM False+        syncSetLoggingM False+        syncSetRoleM SyncSlave+        networkBind Nothing 1 2 0 0+        addr <- liftIO $ getAddr host (fromIntegral port)+        _ <- networkConnect addr 2 0+        _ <- sdlCreateWindowM mainWindowName "Gore&Ash Client" defaultWindow defaultRenderer+        sdlSetBackColor mainWindowName $ V4 200 200 200 255+      gameLoop fps gs'++    gameLoop fps gs = do+      waitFPSBound fps +      (mg, gs') <- stepGame gs (return ())+      mg `deepseq` if fromMaybe False $ gameExit <$> join mg+        then cleanupGameState gs'+        else gameLoop fps gs'++{-+main :: IO ()+main = do+  initializeAll+  window <- createWindow "My SDL Application" defaultWindow+  renderer <- createRenderer window (-1) defaultRenderer+  appLoop renderer++appLoop :: Renderer -> IO ()+appLoop renderer = do+  events <- pollEvents+  let eventIsQPress event =+        case eventPayload event of+          KeyboardEvent keyboardEvent ->+            keyboardEventKeyMotion keyboardEvent == Pressed &&+            keysymKeycode (keyboardEventKeysym keyboardEvent) == KeycodeQ+          _ -> False+      qPressed = not (null (filter eventIsQPress events))+  rendererDrawColor renderer $= V4 0 0 255 255+  clear renderer+  present renderer+  unless qPressed (appLoop renderer) -}
+ src/server/Game.hs view
@@ -0,0 +1,105 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Game(+    mainWire+  , Game(..)+  ) where++import Control.Wire+import Data.Maybe +import Data.Text (pack)+import Linear+import Prelude hiding (id, (.))+import qualified Data.HashMap.Strict as H +import qualified Data.Sequence as S ++import Game.Bullet +import Game.Core+import Game.Data+import Game.Player+import Game.Shared++import Game.GoreAndAsh+import Game.GoreAndAsh.Actor +import Game.GoreAndAsh.Logging+import Game.GoreAndAsh.Network+import Game.GoreAndAsh.Sync ++-- | Wire that returns next player color+playerColors :: AppWire (Event a) (V3 Double)+playerColors = dDispense [+    V3 1 0 0+  , V3 0 1 0+  , V3 0 0 1+  , V3 1 1 0+  , V3 1 0 1+  , V3 0 1 1+  ]++mainWire :: AppActor GameId a Game+mainWire = makeFixedActor globalGameId $ stateWire initGame $ proc (_, g) -> do +  forceNF . processBullets . processPlayers -< g+  where +    -- | Game at start of the simulation+    initGame = Game {+        gameId = globalGameId+      , gamePlayers = H.empty+      , gamePlayerPeers = H.empty+      , gameBullets = H.empty+      , gameBulletColId = fromCounter (-1)+      , gamePlayerColId = fromCounter (-1)+      }++    -- | Handles process of players connection and disconnections+    processPlayers :: AppWire Game Game+    processPlayers = proc g -> do +      conEvent <- peersConnected -< ()+      col <- playerColors -< conEvent+      let addEvent = fmap (spawnPlayer col) <$> conEvent++      disEvent <- peersDisconnected -< ()+      remEvent <- filterJustLE -< fmap (despawnPlayer g) <$> disEvent++      traceEvent (const "New player connected") -< addEvent -- Player id is not ready yet :(+      traceEvent (\i -> "Player " <> (pack . show) i <> " disconnected") -< remEvent++      (ps, i) <- runActor $ remoteActorCollectionServer S.empty -< (g, addEvent, remEvent)+      returnA -< g {+          gamePlayers = mapFromSeq $ fmap playerId  ps `S.zip` ps+        , gamePlayerPeers = mapFromSeq $ fmap playerPeer ps `S.zip` fmap playerId ps+        , gamePlayerColId = i+        }++    -- | Spawns new player from peer (creates new arrow)+    spawnPlayer :: V3 Double -> Peer -> AppActor PlayerId Game Player+    spawnPlayer c p = playerActor $ \i -> Player {+        playerId = i+      , playerPos = 0+      , playerColor = c+      , playerRot = 0+      , playerPeer = p+      , playerSpeed = 15+      , playerSize = 1+      }++    -- | Detects player id by peer for despawning+    despawnPlayer :: Game -> Peer -> Maybe PlayerId+    despawnPlayer Game{..} p = H.lookup p gamePlayerPeers++    -- | Handle bullets actors+    processBullets :: AppWire Game Game +    processBullets = proc g -> do +      addEvent <- mapE (fmap (bulletActor . newBullet)) . actorMessages globalGameId isGameSpawnBullet -< ()+      remEvent <- mapE (fmap $ \(GameDeleteBullet i) -> i) . actorMessages globalGameId isGameDeleteBullet -< ()+      (bs, i) <- runActor $ remoteActorCollectionServer S.empty -< (g, addEvent, remEvent)+      returnA -< g {+          gameBullets = mapFromSeq $ fmap bulletId bs `S.zip` bs+        , gameBulletColId = i+        }+      where+        newBullet (GameSpawnBullet pos vel owner) i = Bullet {+            bulletId = i +          , bulletPos = pos+          , bulletVel = vel+          , bulletOwner = owner+          }+        newBullet _ _ = error "newBullet: wrong message"
+ src/server/Game/Bullet.hs view
@@ -0,0 +1,72 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Game.Bullet(+    module ReExport+  , bulletActor+  ) where++import Control.Wire +import Data.Serialize+import Data.Word +import Linear +import Prelude hiding (id, (.))+import qualified Data.HashMap.Strict as H++import Game.Bullet.Data as ReExport+import Game.Core +import Game.Data +import Game.Player.Data+import Game.Shared ++import Game.GoreAndAsh+import Game.GoreAndAsh.Actor +import Game.GoreAndAsh.Sync ++instance RemoteActor BulletId Bullet where+  type RemoteActorState BulletId = Bullet+  type RemoteActorId Bullet = BulletId++bulletActor :: (BulletId -> Bullet) -> AppActor BulletId Game Bullet +bulletActor initalBullet = makeActor $ \i -> stateWire (initalBullet i) $ mainController i+  where++  mainController :: BulletId -> AppWire (Game, Bullet) Bullet+  mainController i = proc (g, b) -> do+    forceNF . serverSync bulletSync i . processBullet -< (b, g)+    where++    -- | Actual bullet logic+    processBullet :: AppWire (Bullet, Game) Bullet +    processBullet = proc (b, g) -> do +      actorSend globalGameId . at bulletLifespan -< GameDeleteBullet i+      playersShot -< (b, gamePlayers g)+      dt <- deltaTime -< ()+      let newPos = bulletPos b + V2 dt dt * bulletVel b +      returnA -< b {+          bulletPos = newPos+        } +      where +      -- | Test all players was shot+      playersShot :: AppWire (Bullet, PlayerMap) ()+      playersShot = liftGameMonad2 $ \b ps -> mapM_ (playerShot b) . H.elems $! ps ++      -- | Test single player was shot+      playerShot :: Bullet -> Player -> GameMonadT AppMonad ()+      playerShot b p = do +        let V2 px py = playerPos p +            V2 bx by = bulletPos b+            cond = abs (px - bx) <= playerSize p && abs (py - by) <= playerSize p+        if cond then do +            actorSendM globalGameId . GameDeleteBullet $! i+            actorSendM (playerId p) . PlayerShotMessage . bulletOwner $! b+          else return ()++    bulletSync :: FullSync AppMonad BulletId Bullet+    bulletSync = Bullet +      <$> pure i +      <*> fsync 0 bulletPos +      <*> fsync 1 bulletVel +      <*> fsync 2 bulletOwner+      where+        fsync :: (Eq a, Serialize a) +          => Word64 -> (Bullet -> a) -> Sync AppMonad BulletId Bullet a+        fsync fi f = condSync (fieldChanges f &> periodic 4 . arr f) f $ serverSide fi f
+ src/server/Game/Bullet/Data.hs view
@@ -0,0 +1,55 @@+module Game.Bullet.Data(+    BulletId(..)+  , Bullet(..)+  , BulletMessage(..)+  , BulletNetMessage+  , bulletSpeed+  , bulletLifespan+  ) where++import Control.DeepSeq+import Data.Hashable+import Data.Time.Clock (NominalDiffTime)+import Data.Typeable +import GHC.Generics (Generic)+import Linear+import Prelude hiding (id, (.))++import Game.GoreAndAsh.Actor+import Game.GoreAndAsh.Sync++import Game.Player.Data +import Game.Bullet.Shared ++data Bullet = Bullet {+  bulletId :: !BulletId+, bulletPos :: !(V2 Double)+, bulletVel :: !(V2 Double)+, bulletOwner :: !PlayerId+} deriving (Generic)++instance NFData Bullet ++newtype BulletId = BulletId { unBulletId :: Int } deriving (Eq, Show, Generic) +instance NFData BulletId +instance Hashable BulletId ++data BulletMessage = BulletMessageStub deriving (Typeable, Generic)+instance NFData BulletMessage ++instance ActorMessage BulletId where+  type ActorMessageType BulletId = BulletMessage+  toCounter = unBulletId+  fromCounter = BulletId+  +instance NetworkMessage BulletId where +  type NetworkMessageType BulletId = BulletNetMessage++instance ElementWithId Bullet BulletId where+    elementId = bulletId++bulletSpeed :: Double +bulletSpeed = 20++bulletLifespan :: NominalDiffTime +bulletLifespan = 5
+ src/server/Game/Core.hs view
@@ -0,0 +1,57 @@+module Game.Core(+    AppMonad+  , AppWire+  , AppActor+  ) where++import Control.DeepSeq+import Control.Monad.Catch+import Control.Monad.Fix +import Control.Monad.IO.Class+import Control.Wire+import Data.Proxy+import Game.GoreAndAsh+import GHC.Generics (Generic)+import Prelude hiding (id, (.))++import Game.GoreAndAsh.Actor+import Game.GoreAndAsh.Logging+import Game.GoreAndAsh.Network+import Game.GoreAndAsh.Sync++-- | Application monad is monad stack build from given list of modules over base monad (IO)+type AppStack = ModuleStack [LoggingT, ActorT, NetworkT, SyncT] IO+newtype AppState = AppState (ModuleState AppStack)+  deriving (Generic)++instance NFData AppState ++-- | Wrapper around type family+newtype AppMonad a = AppMonad (AppStack a)+  deriving (Functor, Applicative, Monad, MonadFix, MonadIO, LoggingMonad, NetworkMonad, ActorMonad, MonadThrow, MonadCatch)++-- | Current GHC (7.10.3) isn't able to derive this+instance SyncMonad AppMonad where +  getSyncIdM = AppMonad . getSyncIdM+  getSyncTypeRepM = AppMonad . getSyncTypeRepM+  registerSyncIdM = AppMonad . registerSyncIdM+  addSyncTypeRepM a b = AppMonad $ addSyncTypeRepM a b+  syncScheduleMessageM peer ch i mt msg  = AppMonad $ syncScheduleMessageM peer ch i mt msg+  syncSetLoggingM = AppMonad . syncSetLoggingM+  syncSetRoleM = AppMonad . syncSetRoleM+  syncGetRoleM = AppMonad syncGetRoleM+  syncRequestIdM a b = AppMonad $ syncRequestIdM a b +  +instance GameModule AppMonad AppState where +  type ModuleState AppMonad = AppState+  runModule (AppMonad m) (AppState s) = do +    (a, s') <- runModule m s +    return (a, AppState s')+  newModuleState = AppState <$> newModuleState+  withModule _ = withModule (Proxy :: Proxy AppStack)+  cleanupModule (AppState s) = cleanupModule s ++-- | Arrow that is build over the monad stack+type AppWire a b = GameWire AppMonad a b+-- | Action that makes indexed app wire+type AppActor i a b = GameActor AppMonad i a b
+ src/server/Game/Data.hs view
@@ -0,0 +1,68 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Game.Data(+    Game(..)+  , GameMessage(..)+  , PlayerMap+  , PlayerPeerMap+  , BulletsMap+  -- | Helpers+  , isGameSpawnBullet+  , isGameDeleteBullet+  ) where++import Control.DeepSeq+import GHC.Generics (Generic)+import Prelude hiding (id, (.))+import qualified Data.HashMap.Strict as H +import Linear ++import Game.Bullet.Data+import Game.Player.Data+import Game.Shared++import Game.GoreAndAsh.Actor+import Game.GoreAndAsh.Network+import Game.GoreAndAsh.Sync ++type PlayerMap = H.HashMap PlayerId Player+type PlayerPeerMap = H.HashMap Peer PlayerId +type BulletsMap = H.HashMap BulletId Bullet ++-- | Server local messages to game actor+data GameMessage = +    -- | Spawn bullet at given pos with given velocity and owner+    GameSpawnBullet !(V2 Double) !(V2 Double) !PlayerId +    -- | Deletes bullet with specified id+  | GameDeleteBullet !BulletId+  deriving (Generic, Show)++instance ActorMessage GameId where+  type ActorMessageType GameId = GameMessage +  toCounter = unGameId+  fromCounter = GameId++instance NetworkMessage GameId where +  type NetworkMessageType GameId = GameNetMessage++data Game = Game {+  gameId :: !GameId+, gamePlayers :: !PlayerMap+, gamePlayerPeers :: !PlayerPeerMap+, gameBullets :: !BulletsMap+, gameBulletColId :: !RemActorCollId +, gamePlayerColId :: !RemActorCollId+} deriving (Generic)++instance NFData Game ++-- | Detect specific message+isGameSpawnBullet :: GameMessage -> Bool+isGameSpawnBullet m = case m of +  GameSpawnBullet _ _ _ -> True+  _ -> False++-- | Detect specific message+isGameDeleteBullet :: GameMessage -> Bool+isGameDeleteBullet m = case m of +  GameDeleteBullet _ -> True+  _ -> False
+ src/server/Game/Player.hs view
@@ -0,0 +1,77 @@+module Game.Player(+    Player(..)+  , PlayerId(..)+  , PlayerMessage+  , playerActor+  ) where++import Control.Wire+import Control.Wire.Unsafe.Event (event)+import Data.Text (pack)+import Linear+import Prelude hiding (id, (.))++import Game.Bullet.Data+import Game.Core+import Game.Data+import Game.Player.Data+import Game.Shared++import Game.GoreAndAsh+import Game.GoreAndAsh.Actor+import Game.GoreAndAsh.Logging+import Game.GoreAndAsh.Network +import Game.GoreAndAsh.Sync++playerActor :: (PlayerId -> Player) -> AppActor PlayerId Game Player +playerActor initialPlayer = makeActor $ \i -> stateWire (initialPlayer i) $ mainController i+  where+  mainController i = proc (g, p) -> do+    p2 <- peerProcessIndexedM peer (ChannelID 0) i netProcess -< p+    (_, p3) <- peerProcessIndexedM peer (ChannelID 0) globalGameId globalNetProcess -< (g, p2)+    forceNF . serverSync playerSync i . playerShot -< p3+    where+    -- | Shortcut for peer+    peer = playerPeer $ initialPlayer i++    -- | Handle when player is shot+    playerShot :: AppWire Player Player+    playerShot = proc p -> do +      emsg <- actorMessages i isPlayerShotMessage -< ()+      let newPlayer = p {+          playerPos = 0+        }+      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 +            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)+        actorSendM globalGameId $ GameSpawnBullet pos vel $ playerId 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 +      PlayerRequestId -> do+        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) ++    playerSync :: FullSync AppMonad PlayerId Player +    playerSync = Player +      <$> pure i +      <*> clientSide peer 0 playerPos+      <*> clientSide peer 1 playerColor+      <*> clientSide peer 2 playerRot+      <*> clientSide peer 3 playerSpeed+      <*> clientSide peer 4 playerSize+      <*> pure peer
+ src/server/Game/Player/Data.hs view
@@ -0,0 +1,63 @@+module Game.Player.Data(+    Player(..)+  , PlayerId(..)+  , PlayerMessage(..)+  , PlayerNetMessage(..)+  , isPlayerShotMessage+  ) where++import Control.DeepSeq+import Data.Hashable+import Data.Typeable +import Data.Serialize+import GHC.Generics (Generic)+import Linear+import Prelude hiding (id, (.))++import Game.Player.Shared++import Game.GoreAndAsh.Actor+import Game.GoreAndAsh.Network +import Game.GoreAndAsh.Sync++data Player = Player {+  playerId :: !PlayerId+, playerPos :: !(V2 Double)+, playerColor :: !(V3 Double) +, playerRot :: !Double +, playerSpeed :: !Double +, playerSize :: !Double+, playerPeer :: !Peer+} deriving (Generic)++instance NFData Player ++newtype PlayerId = PlayerId { unPlayerId :: Int } deriving (Eq, Show, Generic) +instance NFData PlayerId +instance Hashable PlayerId +instance Serialize PlayerId++data PlayerMessage =+    -- | The player was shot by specified player+    PlayerShotMessage !PlayerId +  deriving (Typeable, Generic)++instance NFData PlayerMessage ++instance ActorMessage PlayerId where+  type ActorMessageType PlayerId = PlayerMessage+  toCounter = unPlayerId+  fromCounter = PlayerId+  +instance NetworkMessage PlayerId where +  type NetworkMessageType PlayerId = PlayerNetMessage++instance RemoteActor PlayerId Player where+  type RemoteActorState PlayerId = Player+  type RemoteActorId Player = PlayerId+  +-- | Check specific type of message+isPlayerShotMessage :: PlayerMessage -> Bool+isPlayerShotMessage m = case m of +  PlayerShotMessage _ -> True+--  _ -> False
+ src/server/Main.hs view
@@ -0,0 +1,76 @@+module Main where ++import Control.Exception+import Control.Monad.IO.Class+import Data.Proxy +import Game +import Game.Core+import Game.GoreAndAsh+import Game.GoreAndAsh.Actor+import Game.GoreAndAsh.Network+import Game.GoreAndAsh.Sync+import Network.BSD (getHostByName, hostAddress)+import Network.Socket (SockAddr(..))+import System.Exit+import Data.IORef +import System.Environment+import Text.Read ++import FPS ++simulationFPS :: Int +simulationFPS = 60 ++parseArgs :: IO (String, Int)+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-server HOST PORT"++main :: IO ()+main = withModule (Proxy :: Proxy AppMonad) $ do+  gs <- newGameState $ runActor' mainWire+  gsRef <- newIORef gs+  (host, port) <- liftIO parseArgs+  fps <- makeFPSBounder simulationFPS+  firstStep fps host port gs gsRef `onCtrlC` exitHandler gsRef+  where+    -- | What to do on emergency exit+    exitHandler gsRef = do +      gs <- readIORef gsRef +      cleanupGameState gs+      exitSuccess++    -- | Resolve given hostname and port+    getAddr s p = do+      he <- getHostByName s+      return $ SockAddrInet p $ hostAddress he++    -- | Initialization step+    firstStep fps host port gs gsRef = do +      (_, gs') <- stepGame gs $ do +        networkSetDetailedLoggingM False+        syncSetLoggingM True+        syncSetRoleM SyncMaster+        addr <- liftIO $ getAddr host (fromIntegral port)+        networkBind (Just addr) 100 2 0 0+      writeIORef gsRef gs'+      gameLoop fps gs' gsRef++    -- | Normal game loop+    gameLoop fps gs gsRef = do +      waitFPSBound fps+      (_, gs') <- stepGame gs (return ())+      writeIORef gsRef gs'+      gameLoop fps gs' gsRef++-- | Executes given handler on Ctrl-C pressing+onCtrlC :: IO a -> IO () -> IO a+p `onCtrlC` q = catchJust isUserInterrupt p (const $ q >> p `onCtrlC` q)+  where+    isUserInterrupt :: AsyncException -> Maybe ()+    isUserInterrupt UserInterrupt = Just ()+    isUserInterrupt _             = Nothing
+ src/shared/FPS.hs view
@@ -0,0 +1,27 @@+module FPS(+    makeFPSBounder+  , waitFPSBound+  ) where++import GHC.Event+import Control.Concurrent+import Control.Monad ++type FPSBound = MVar ()++-- | Creates mvar that fills periodically with given fps+makeFPSBounder :: Int -> IO FPSBound+makeFPSBounder fps = do+  v <- newEmptyMVar +  tm <- getSystemTimerManager+  let t = ceiling ((1000000 :: Double) / fromIntegral fps)+  callback v tm t+  return v+  where+    callback v tm t = do +      putMVar v ()+      void $ registerTimeout tm t $ callback v tm t++-- | Wait until next FPS value is reached when the function unblocks+waitFPSBound :: FPSBound -> IO ()+waitFPSBound = takeMVar
+ src/shared/Game/Bullet/Shared.hs view
@@ -0,0 +1,5 @@+module Game.Bullet.Shared(+    BulletNetMessage+  ) where++data BulletNetMessage
+ src/shared/Game/Player/Shared.hs view
@@ -0,0 +1,15 @@+module Game.Player.Shared(+    PlayerNetMessage(..)+  ) where++import Control.DeepSeq+import Data.Serialize +import GHC.Generics (Generic)+import Linear ++data PlayerNetMessage = +    NetMsgPlayerFire !(V2 Double)+  deriving (Generic, Show)++instance NFData PlayerNetMessage+instance Serialize PlayerNetMessage
+ src/shared/Game/Shared.hs view
@@ -0,0 +1,49 @@+module Game.Shared(+    GameId(..)+  , GameNetMessage(..)+  , globalGameId+  , isPlayerRequestId+  , isPlayerResponseId+  -- | Helpers+  , mapFromSeq+  ) where++import Control.DeepSeq+import Data.Hashable +import Data.Serialize+import GHC.Generics+import qualified Data.Foldable as F +import qualified Data.HashMap.Strict as H +import qualified Data.Sequence as S ++-- | Fake id for game global space+newtype GameId = GameId { unGameId :: Int } deriving (Eq, Generic)++instance NFData GameId ++-- | Statically known game id+globalGameId :: GameId +globalGameId = GameId 0 ++-- | Generic messages that are not binded to specific actor+data GameNetMessage =+    PlayerRequestId+  | PlayerResponseId !Int !Int !Int -- ^ Id of player and bullets, players collections+  deriving (Generic, Show)++instance NFData GameNetMessage+instance Serialize GameNetMessage++isPlayerRequestId :: GameNetMessage -> Bool +isPlayerRequestId m = case m of +  PlayerRequestId -> True +  _ -> False++isPlayerResponseId :: GameNetMessage -> Bool +isPlayerResponseId m = case m of +  PlayerResponseId _ _ _ -> True +  _ -> False++-- | Construct HashMap from sequence+mapFromSeq :: (Hashable i, Eq i) => S.Seq (i, a) -> H.HashMap i a +mapFromSeq = F.foldl' (\acc (i, a) -> H.insert i a acc) H.empty