Fixed timestep and parse the initial spawn point from the entities lump

ocharles.plan.org

@@ -21,7 +21,9 @@ Trying to build as much of Quake 3 as I can using Haskell & Vulkan.
 
 ** [ ] Move logging from main to functions themselves :refactoring:
 
-** [ ] Fixed physics timestep :correctness:
+* <2018-09-18 Tue>
+** [X] Fixed physics timestep :correctness:
+** [X] Parse the entities lump for the initial spawn point :correctness:
 * <2018-09-14 Fri>
 ** [X] Better input handling :correctness:
 * <2018-09-13 Thu>

shell.nix

@@ -22,7 +22,7 @@ let
     haskellPackages.ghcWithHoogle
       ( hs:
         with hs;
-        [ managed sdl2 unliftio vulkan-api generic-deriving reactive-banana generic-lens ]
+        [ managed sdl2 unliftio vulkan-api generic-deriving reactive-banana generic-lens clock megaparsec ]
       );
 
 in

src/Quake3.hs

@@ -3,8 +3,13 @@
 module Main ( main ) where
 
 -- base
+import Control.Monad ( replicateM_ )
 import Control.Monad.IO.Class ( MonadIO, liftIO )
 import Data.Foldable ( traverse_ )
+import Data.Maybe ( mapMaybe )
+
+-- clock
+import qualified System.Clock
 
 -- managed
 import Control.Monad.Managed ( runManaged )
@@ -32,6 +37,8 @@ import qualified Graphics.Vulkan.Ext.VK_KHR_swapchain as Vulkan ()
 -- zero-to-quake-3
 import Foreign.Vulkan ( throwVkResult )
 import Quake3.Context ( Context(..), withQuake3Context )
+import qualified Quake3.BSP
+import qualified Quake3.Entity
 import qualified Quake3.Input
 import qualified Quake3.Render
 import qualified Quake3.Model
@@ -60,7 +67,10 @@ main =
 
         liftIO ( compile game >>= actuate )
 
-        tick context commandBuffers isRunning io
+        t0 <-
+          liftIO ( System.Clock.getTime System.Clock.Monotonic )
+
+        tick context commandBuffers isRunning io t0 0
 
 
 data InputOutput = InputOutput
@@ -70,7 +80,9 @@ data InputOutput = InputOutput
   }
 
 
-newGame :: MonadIO m => Quake3.Render.Resources -> m ( InputOutput, MomentIO () )
+newGame
+  :: MonadIO m
+  => Quake3.Render.Resources -> m ( InputOutput, MomentIO () )
 newGame resources = do
   ( onActionAddHandler, onActionHandler ) <-
     liftIO newAddHandler
@@ -81,6 +93,12 @@ newGame resources = do
   ( onPhysicsStepAddHandler, onPhysicsStepHandler ) <-
     liftIO newAddHandler
 
+  let
+    initialEntities =
+      mapMaybe
+        Quake3.Entity.parseEntity
+        ( Quake3.BSP.bspEntities ( Quake3.Render.bsp resources ) )
+
   return
     ( InputOutput { .. }
     , do
@@ -94,7 +112,7 @@ newGame resources = do
           fromAddHandler onPhysicsStepAddHandler
 
         model <-
-          Quake3.Model.quake3 onAction onPhysicsStep
+          Quake3.Model.quake3 initialEntities onAction onPhysicsStep
 
         reactimate
           ( Quake3.Render.updateFromModel resources
@@ -103,14 +121,22 @@ newGame resources = do
     )
 
 
+-- 1/120s
+physicsTimeStep :: System.Clock.TimeSpec
+physicsTimeStep =
+  8333333
+
+
 tick
   :: MonadIO m
   => Context
   -> [ Vulkan.VkCommandBuffer ]
   -> IORef Bool
   -> InputOutput
+  -> System.Clock.TimeSpec
+  -> Integer
   -> m ()
-tick ctx@Context{..} commandBuffers isRunningRef io@InputOutput{..} = do
+tick ctx@Context{..} commandBuffers isRunningRef io@InputOutput{..} tLastFrame accumulator = do
   isRunning <-
     readIORef isRunningRef
 
@@ -120,7 +146,15 @@ tick ctx@Context{..} commandBuffers isRunningRef io@InputOutput{..} = do
 
   where
 
+    tick' :: MonadIO m => m ()
     tick' = do
+      tThisFrame <-
+        liftIO ( System.Clock.getTime System.Clock.Monotonic )
+
+      let
+        frameTime =
+          tThisFrame - tLastFrame
+
       events <-
         SDL.pollEvents
 
@@ -130,9 +164,21 @@ tick ctx@Context{..} commandBuffers isRunningRef io@InputOutput{..} = do
             events
         )
 
-      liftIO ( onPhysicsStepHandler 0.01 )
+      let
+        physicsBudget =
+          System.Clock.toNanoSecs frameTime + accumulator
+
+        ( steps, accumulator' ) =
+          physicsBudget `divMod` System.Clock.toNanoSecs physicsTimeStep
+
+      liftIO
+        ( do
+            replicateM_
+              ( fromIntegral steps )
+              ( onPhysicsStepHandler ( toSeconds physicsTimeStep ) )
 
-      liftIO ( onRenderHandler () )
+            onRenderHandler ()
+        )
 
       nextImageIndex <-
         acquireNextImage device swapchain nextImageSem
@@ -149,4 +195,9 @@ tick ctx@Context{..} commandBuffers isRunningRef io@InputOutput{..} = do
       liftIO ( Vulkan.vkQueueWaitIdle queue )
         >>= throwVkResult
 
-      tick ctx commandBuffers isRunningRef io
+      tick ctx commandBuffers isRunningRef io tThisFrame accumulator'
+
+
+toSeconds :: System.Clock.TimeSpec -> Double
+toSeconds =
+  ( / 1e-9 ) . fromIntegral . System.Clock.toNanoSecs

src/Quake3/BSP.hs

@@ -7,8 +7,10 @@ module Quake3.BSP ( BSP(..), Face(..), MeshVertList(..), VertexList(..), loadBSP
 import Control.Applicative ( liftA2, liftA3 )
 import Control.Monad ( guard, replicateM )
 import Control.Monad.IO.Class ( MonadIO, liftIO )
+import Control.Exception ( throwIO )
 import Data.Char ( ord )
 import Data.Foldable ( traverse_ )
+import Data.Function ( (&) )
 import Data.Int ( Int32 )
 
 -- binary
@@ -17,6 +19,16 @@ import qualified Data.Binary.Get
 -- bytestring
 import qualified Data.ByteString.Lazy
 
+-- containers
+import qualified Data.Map.Strict as Map
+
+-- text
+import qualified Data.Text as StrictText
+import qualified Data.Text.Encoding as StrictText
+
+-- zero-to-quake3
+import qualified Quake3.BSP.Entities
+
 
 data DirEntry = DirEntry
   { deOffset :: Int32
@@ -26,7 +38,8 @@ data DirEntry = DirEntry
 
 
 data BSP = BSP
-  { bspVertices :: VertexList
+  { bspEntities :: [ Quake3.BSP.Entities.EntityProperties ]
+  , bspVertices :: VertexList
   , bspMeshVerts :: MeshVertList
   , bspFaces :: [ Face ]
   }
@@ -62,7 +75,7 @@ getBSP = do
   fileBytes <-
     Data.Binary.Get.lookAhead Data.Binary.Get.getRemainingLazyByteString
 
-  [ _entities
+  [ entities
     , _textures
     , _planes
     , _nodes
@@ -89,9 +102,19 @@ getBSP = do
 
     replicateM 17 getDirEntry
 
+  entities <-
+    lookupBytes entities fileBytes
+      & Data.ByteString.Lazy.takeWhile ( /= 0 )
+      & Data.ByteString.Lazy.toStrict
+      & StrictText.decodeUtf8
+      & Quake3.BSP.Entities.parseEntityDefinitions
+      & either ( fail . show ) return
+
   return
     BSP
-      { bspVertices =
+      { bspEntities =
+          entities
+      , bspVertices =
           VertexList ( lookupBytes vertexes fileBytes )
       , bspMeshVerts =
           MeshVertList ( lookupBytes meshVerts fileBytes )

src/Quake3/BSP/Entities.hs

@@ -0,0 +1,105 @@
+{-# language FlexibleContexts #-}
+{-# language OverloadedStrings #-}
+
+module Quake3.BSP.Entities
+  ( EntityProperties
+  , getInt
+  , getIntV3
+  , getText
+  , parseEntityDefinitions
+  ) where
+
+-- base
+import Control.Applicative ( liftA2, many )
+import Data.Void ( Void )
+import Text.Read ( readMaybe )
+
+-- containers
+import qualified Data.Map.Strict as Map
+
+-- linear
+import Linear ( V3(..) )
+
+-- megaparsec
+import qualified Text.Megaparsec as Megaparsec
+import qualified Text.Megaparsec.Char as Megaparsec
+import qualified Text.Megaparsec.Char.Lexer as Megaparsec hiding ( space )
+
+-- text
+import qualified Data.Text as StrictText
+
+
+newtype EntityProperties =
+  EntityProperties ( Map.Map StrictText.Text StrictText.Text )
+  deriving ( Show )
+
+
+getInt :: StrictText.Text -> EntityProperties -> Maybe Int
+getInt key ( EntityProperties m ) =
+  fmap StrictText.unpack ( Map.lookup key m )
+    >>= readMaybe
+
+
+getIntV3 :: StrictText.Text -> EntityProperties -> Maybe ( V3 Int )
+getIntV3 key ( EntityProperties m ) = do
+  [ x, z, y ] <-
+    fmap ( words . StrictText.unpack ) ( Map.lookup key m )
+
+  traverse readMaybe ( V3 x y z )
+
+
+getText :: StrictText.Text -> EntityProperties -> Maybe StrictText.Text
+getText key ( EntityProperties m ) =
+  Map.lookup key m
+
+
+parseEntityDefinitions
+  :: StrictText.Text
+  -> Either ( Megaparsec.ParseError Char Void ) [ EntityProperties ]
+parseEntityDefinitions =
+  Megaparsec.parse parser "(entities)"
+
+
+parser
+  :: Megaparsec.MonadParsec e StrictText.Text m
+  => m [ EntityProperties ]
+parser =
+  many entityDefinition <* Megaparsec.eof
+
+
+entityDefinition
+  :: Megaparsec.MonadParsec e StrictText.Text m
+  => m EntityProperties
+entityDefinition =
+  EntityProperties
+    <$>
+      Megaparsec.between
+        ( symbol "{" )
+        ( symbol "}" )
+        ( fmap
+            Map.fromList
+            ( Megaparsec.many ( liftA2 (,) quotedString quotedString ) )
+        )
+
+
+quotedString
+  :: Megaparsec.MonadParsec e StrictText.Text m
+  => m StrictText.Text
+quotedString =
+  symbol "\""
+    *> fmap StrictText.pack ( many ( Megaparsec.satisfy ( /= '"' ) ) )
+    <* symbol "\""
+
+
+space
+  :: Megaparsec.MonadParsec e StrictText.Text m
+  => m ()
+space =
+  Megaparsec.space
+
+
+symbol
+  :: Megaparsec.MonadParsec e StrictText.Text m
+  => StrictText.Text -> m StrictText.Text
+symbol =
+  Megaparsec.symbol space

src/Quake3/Entity.hs

@@ -0,0 +1,22 @@
+{-# language DeriveGeneric #-}
+
+module Quake3.Entity ( Entity(..), parseEntity ) where
+
+-- base
+import GHC.Generics ( Generic )
+
+-- zero-to-quake3
+import qualified Quake3.BSP.Entities
+import qualified Quake3.Entity.InfoPlayerDeathmatch
+
+data Entity
+  = InfoPlayerDeathmatch Quake3.Entity.InfoPlayerDeathmatch.InfoPlayerDeathmatch
+  | Other
+  deriving ( Generic, Show )
+
+
+parseEntity
+  :: Quake3.BSP.Entities.EntityProperties
+  -> Maybe Entity
+parseEntity props =
+  InfoPlayerDeathmatch <$> Quake3.Entity.InfoPlayerDeathmatch.parse props