keid-core 0.1.7.1 → 0.1.7.2

raw patch · 7 files changed

+109/−46 lines, 7 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• ChangeLog.md +5/−0
• keid-core.cabal +2/−2
• src/Engine/Run.hs +15/−4
• src/Engine/Setup.hs +31/−21
• src/Engine/Setup/Window.hs +23/−5
• src/Engine/Types/Options.hs +22/−0
• src/Resource/Texture/Ktx1.hs +11/−14

@@ -1,5 +1,10 @@ # Changelog for keid-core +## 0.1.7.2++- Added `--size` option to set the initial window size.+- Added `--max-fps` option to limit frame rate.+ ## 0.1.7.1  - SPIR-V reflection loader changed to `spirv-reflect-ffi`.

@@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.34.4.+-- This file has been generated from package.yaml by hpack version 0.35.0. -- -- see: https://github.com/sol/hpack  name:           keid-core-version:        0.1.7.1+version:        0.1.7.2 synopsis:       Core parts of Keid engine. category:       Game Engine homepage:       https://keid.haskell-game.dev

@@ -11,6 +11,7 @@ import RIO.State (get, put) import UnliftIO.Resource (ReleaseKey, release) import Vulkan.Core10 qualified as Vk+import GHC.Clock (getMonotonicTimeNSec)  import Engine.DataRecycler (DataRecycler(..)) import Engine.DataRecycler qualified as DataRecycler@@ -19,7 +20,7 @@ import Engine.StageSwitch (getNextStage) import Engine.Types (Frame, NextStage(..), RecycledResources, StageStack, StackStage(..), Stage(..), StageRIO) import Engine.Types qualified as Engine-import Engine.Types.Options (optionsRecyclerWait)+import Engine.Types.Options (optionsRecyclerWait, optionsMaxFPS) import Engine.Types.RefCounted (releaseRefCounted) import Engine.Vulkan.Swapchain (SwapchainResources(srRelease), threwSwapchainError) import Engine.Vulkan.Types (RenderPass, getDevice)@@ -111,7 +112,7 @@    startFrame <- Frame.initial oldSR (drDump recycler) stage -  Engine.GlobalHandles{ghWindow} <- asks appEnv+  Engine.GlobalHandles{ghWindow, ghOptions} <- asks appEnv   quit <- liftIO $ GLFW.windowShouldClose ghWindow   if quit then do     logDebug $ "Forcing stage unwind for " <> display sTitle@@ -123,7 +124,7 @@     logInfo $ "Entering stage loop: " <> display sTitle     startTime <- getMonotonicTime     (finalFrame, stageAction) <- bracket sBeforeLoop sAfterLoop \_stagePrivates ->-      stageLoop (step stKey stage recycler) startFrame+      stageLoop (step stKey stage recycler (optionsMaxFPS ghOptions)) startFrame     endTime <- getMonotonicTime     let       frames  = Frame.fIndex finalFrame@@ -143,9 +144,11 @@   => ReleaseKey   -> Stage rp p rr st   -> DataRecycler (RecycledResources rr)+  -> Maybe Int   -> Frame rp p rr   -> StageRIO st (LoopAction (Frame rp p rr))-step stKey stage@Stage{..} DataRecycler{..} frame = do+step stKey stage@Stage{..} DataRecycler{..} maxFPSM frame = do+  startTime <- liftIO getMonotonicTimeNSec   liftIO GLFW.pollEvents    -- XXX: hard unwind all the stages, rendering nothing@@ -162,6 +165,14 @@           rs <- get           Frame.run drDump recyclerWait (renderFrame (sUpdateBuffers rs) sRecordCommands) frame         nextFrame <- Frame.advance drWait frame needsNewSwapchain++        for_ maxFPSM \maxFPS -> do+          -- Wait until the end of allocated time.+          endTime <- liftIO getMonotonicTimeNSec+          let elapsedUS = (fromEnum $ endTime - startTime) `div` 1e3 :: Int+              fpsCapUS = 1e6 `div` maxFPS+              waitUS = fpsCapUS - min fpsCapUS elapsedUS+          threadDelay waitUS          pure $ LoopNextFrame nextFrame       Just Finish ->

@@ -26,7 +26,8 @@ import Engine.Types (GlobalHandles(..)) import Engine.Types.Options (Options(..)) import Engine.Vulkan.Swapchain (SwapchainResources)-import Engine.Vulkan.Types (PhysicalDeviceInfo(..), Queues)+import Engine.Vulkan.Types (PhysicalDeviceInfo(..))+import Engine.Vulkan.Types qualified as Vulkan import Engine.Worker qualified as Worker import Engine.StageSwitch (newStageSwitchVar) @@ -40,6 +41,7 @@    (windowReqs, ghWindow) <- Window.allocate     (optionsFullscreen ghOptions)+    (optionsSize ghOptions)     (optionsDisplay ghOptions)     Window.pickLargest     "Keid Engine"@@ -110,45 +112,53 @@   logDebug $ displayShow opts    logDebug "Creating instance"-  ghInstance <- createInstanceFromRequirements+  hInstance <- createInstanceFromRequirements     (deviceProps : debugUtils : headlessReqs)     mempty     zero    logDebug "Creating physical device"-  (ghPhysicalDeviceInfo, ghPhysicalDevice) <- allocatePhysical-    ghInstance+  (hPhysicalDeviceInfo, hPhysicalDevice) <- allocatePhysical+    hInstance     Nothing     pdiTotalMemory    logDebug "Creating logical device"-  ghDevice <- allocateLogical ghPhysicalDeviceInfo ghPhysicalDevice+  hDevice <- allocateLogical hPhysicalDeviceInfo hPhysicalDevice    logDebug "Creating VMA"   let     allocatorCI :: VMA.AllocatorCreateInfo     allocatorCI = zero-      { VMA.physicalDevice  = Vk.physicalDeviceHandle ghPhysicalDevice-      , VMA.device          = Vk.deviceHandle ghDevice-      , VMA.instance'       = Vk.instanceHandle ghInstance-      , VMA.vulkanFunctions = Just $ vmaVulkanFunctions ghDevice ghInstance+      { VMA.physicalDevice  = Vk.physicalDeviceHandle hPhysicalDevice+      , VMA.device          = Vk.deviceHandle hDevice+      , VMA.instance'       = Vk.instanceHandle hInstance+      , VMA.vulkanFunctions = Just $ vmaVulkanFunctions hDevice hInstance       }-  (_vmaKey, ghAllocator) <- VMA.withAllocator allocatorCI Resource.allocate+  (_vmaKey, hAllocator) <- VMA.withAllocator allocatorCI Resource.allocate   toIO (logDebug "Releasing VMA") >>= Resource.register -  ghQueues <- liftIO $ pdiGetQueues ghPhysicalDeviceInfo ghDevice-  logDebug $ "Got command queues: " <> displayShow (fmap (unQueueFamilyIndex . fst) ghQueues)+  hQueues <- liftIO $ pdiGetQueues hPhysicalDeviceInfo hDevice+  logDebug $ "Got command queues: " <> displayShow (fmap (unQueueFamilyIndex . fst) hQueues) -  pure (ghInstance, ghPhysicalDeviceInfo, ghPhysicalDevice, ghDevice, ghAllocator, ghQueues)+  pure Headless{..} -type Headless =-  ( Vk.Instance-  , PhysicalDeviceInfo-  , Vk.PhysicalDevice-  , Vk.Device-  , VMA.Allocator-  , Queues (QueueFamilyIndex, Vk.Queue)-  )+data Headless = Headless+  { hInstance           :: Vk.Instance+  , hPhysicalDeviceInfo :: Vulkan.PhysicalDeviceInfo+  , hPhysicalDevice     :: Vk.PhysicalDevice+  , hDevice             :: Vk.Device+  , hAllocator          :: VMA.Allocator+  , hQueues             :: Vulkan.Queues (QueueFamilyIndex, Vk.Queue)+  }++instance Vulkan.HasVulkan Headless where+  getInstance           = hInstance+  getQueues             = hQueues+  getPhysicalDevice     = hPhysicalDevice+  getPhysicalDeviceInfo = hPhysicalDeviceInfo+  getDevice             = hDevice+  getAllocator          = hAllocator  deviceProps :: InstanceRequirement deviceProps = RequireInstanceExtension

@@ -49,16 +49,17 @@      , MonadResource m      )   => Bool+  -> Maybe (Int, Int)   -> Natural   -> SizePicker   -> Text   -> m ([InstanceRequirement], GLFW.Window)-allocate fullscreen displayNum sizePicker title = do+allocate fullscreen size displayNum sizePicker title = do   UnliftIO unliftIO <- askUnliftIO    let     create = unliftIO $-      createWindow fullscreen displayNum sizePicker title+      createWindow fullscreen size displayNum sizePicker title      destroy (_exts, window) = unliftIO $       destroyWindow window@@ -68,11 +69,12 @@ createWindow   :: (MonadIO m, MonadReader env m, HasLogFunc env)   => Bool+  -> Maybe (Int, Int)   -> Natural   -> SizePicker   -> Text   -> m ([InstanceRequirement], GLFW.Window)-createWindow fullScreen displayNum sizePicker title = do+createWindow fullScreen size displayNum sizePicker title = do   runGlfwIO_ InitError GLFW.init   runGlfwIO_ VulkanError GLFW.vulkanSupported @@ -93,7 +95,7 @@     else do       pure $ Just (monitor, mode) -  (monitor, mode) <-+  (monitor, modeBase) <-     case catMaybes modes of       [] ->         liftIO . throwIO $ MonitorError GLFW.Error'PlatformError "Selected display number not available"@@ -101,7 +103,23 @@         pure $ sizePicker (so :| me)    let-    GLFW.VideoMode{videoModeWidth=width, videoModeHeight=height} = mode+    (mode, (width, height)) =+      case size of+        Just (w, h) ->+          ( modeBase+              { GLFW.videoModeWidth = w+              , GLFW.videoModeHeight = h+              }+          , (w, h)+          )+        Nothing ->+          let+            GLFW.VideoMode{videoModeWidth=w, videoModeHeight=h} = mode+          in+            ( modeBase+            , (w, h)+            )+     fsMonitor =       if fullScreen then         Just monitor

@@ -13,8 +13,10 @@ -- | Command line arguments data Options = Options   { optionsVerbose      :: Bool+  , optionsMaxFPS       :: Maybe Int   , optionsFullscreen   :: Bool   , optionsDisplay      :: Natural+  , optionsSize         :: Maybe (Int, Int)   , optionsRecyclerWait :: Maybe Int   }   deriving (Show)@@ -43,12 +45,24 @@     , Opt.help "Show more and more detailed messages"     ] +  optionsMaxFPS <- Opt.optional . Opt.option Opt.auto $ mconcat+    [ Opt.long "max-fps"+    , Opt.help "Limit the FPS"+    , Opt.metavar "FPS"+    ]+   optionsFullscreen <- Opt.switch $ mconcat     [ Opt.long "fullscreen"     , Opt.short 'f'     , Opt.help "Run in fullscreen mode"     ] +  optionsSize <- Opt.optional . Opt.option readSize $ mconcat+    [ Opt.long "size"+    , Opt.help "Initial window size"+    , Opt.metavar "WIDTHxHEIGHT"+    ]+   optionsDisplay <- Opt.option Opt.auto $ mconcat     [ Opt.long "display"     , Opt.help "Select display number"@@ -61,3 +75,11 @@     ]    pure Options{..}++readSize :: Opt.ReadM (Int, Int)+readSize = do+  o <- Opt.str+  let (w,h) = break (== 'x') o+  case (readMaybe w, readMaybe (drop 1 h)) of+    (Just w', Just h') -> pure (w', h')+    _ -> fail "Can't read window size"

@@ -149,31 +149,28 @@     throwM $ Texture.ArrayError (textureLayers @a) numLayers    VMA.withBuffer vma (Texture.stageBufferCI totalSize) Texture.stageAllocationCI bracket \(staging, stage, stageInfo) -> do-    let ixMipImages = Vector.zip3 (Vector.fromList [0..]) offsets images-    Vector.forM_ ixMipImages \(mipIx, offset, Ktx1.MipLevel{imageSize, arrayElements}) -> do-      let ixArrayElements = Vector.zip (Vector.fromList [0..]) arrayElements-      Vector.forM_ ixArrayElements \(arrayIx, Ktx1.ArrayElement{faces}) -> do-        let ixFaces = Vector.zip (Vector.fromList [0..]) faces-        Vector.forM_ ixFaces \(faceIx, Ktx1.Face{zSlices}) -> do-          let ixSlices = Vector.zip (Vector.fromList [0..]) zSlices-          Vector.forM_ ixSlices \(sliceIx, Ktx1.ZSlice{block}) -> do+    let mipImages = Vector.zip offsets images+    Vector.iforM_ mipImages \mipIx (offset, Ktx1.MipLevel{imageSize, arrayElements}) -> do+      Vector.iforM_ arrayElements \arrayIx Ktx1.ArrayElement{faces} -> do+        Vector.iforM_ faces \faceIx Ktx1.Face{zSlices} -> do+          Vector.iforM_ zSlices \sliceIx Ktx1.ZSlice{block} -> do             let               indices = mconcat                 [ "["-                , " mip:" <> display @Word32 mipIx-                , " arr:" <> display @Word32 arrayIx-                , " fac:" <> display @Word32 faceIx-                , " slc:" <> display @Word32 sliceIx+                , " mip:" <> display mipIx+                , " arr:" <> display arrayIx+                , " fac:" <> display faceIx+                , " slc:" <> display sliceIx                 , " ]"                 ]-            let blockOffset = offset + faceIx * imageSize+            let blockOffset = offset + fromIntegral faceIx * imageSize             let sectionPtr = Foreign.plusPtr (VMA.mappedData stageInfo) (fromIntegral blockOffset)             logDebug $ mconcat               [ indices               , " base offset = "               , display offset               , " image offset = "-              , display $ faceIx * imageSize+              , display $ fromIntegral faceIx * imageSize               , " image size = "               , display imageSize               ]