diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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`. diff --git a/keid-core.cabal b/keid-core.cabal --- a/keid-core.cabal +++ b/keid-core.cabal @@ -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 diff --git a/src/Engine/Run.hs b/src/Engine/Run.hs --- a/src/Engine/Run.hs +++ b/src/Engine/Run.hs @@ -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 -> diff --git a/src/Engine/Setup.hs b/src/Engine/Setup.hs --- a/src/Engine/Setup.hs +++ b/src/Engine/Setup.hs @@ -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 diff --git a/src/Engine/Setup/Window.hs b/src/Engine/Setup/Window.hs --- a/src/Engine/Setup/Window.hs +++ b/src/Engine/Setup/Window.hs @@ -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 diff --git a/src/Engine/Types/Options.hs b/src/Engine/Types/Options.hs --- a/src/Engine/Types/Options.hs +++ b/src/Engine/Types/Options.hs @@ -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" diff --git a/src/Resource/Texture/Ktx1.hs b/src/Resource/Texture/Ktx1.hs --- a/src/Resource/Texture/Ktx1.hs +++ b/src/Resource/Texture/Ktx1.hs @@ -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 ]