keid-core 0.1.0.1 → 0.1.1.0

raw patch · 6 files changed

+68/−29 lines, 6 files

Files

• ChangeLog.md +7/−0
• keid-core.cabal +1/−1
• src/Engine/Setup.hs +2/−1
• src/Engine/Setup/Window.hs +30/−13
• src/Engine/Types/Options.hs +8/−1
• src/Engine/Worker.hs +20/−13

@@ -1,5 +1,12 @@ # Changelog for keid-core +## 0.1.1.0++- Added `--display NUM` to application arguments.+- Allow `Timed` workers to skip output update.+- `spawnTimed` and `spawnTimed_` changed args: active/dt moved to front.+- `spawnTimed` now uses initialization function instead of deriving initial output from initial state.+ ## 0.1.0.1  - Inter-stage resource release waits for render job to finish.

@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           keid-core-version:        0.1.0.1+version:        0.1.1.0 synopsis:       Core parts of Keid engine. category:       Game Engine author:         IC Rainbow

@@ -17,7 +17,7 @@ import Engine.Setup.Device (allocatePhysical, allocateLogical) import Engine.Setup.Window qualified as Window import Engine.Types (GlobalHandles(..))-import Engine.Types.Options (Options, optionsFullscreen)+import Engine.Types.Options (Options(..)) import Engine.Vulkan.Swapchain (SwapchainResources) import Engine.Vulkan.Types (PhysicalDeviceInfo(..)) import Engine.Worker qualified as Worker@@ -33,6 +33,7 @@    (windowReqs, ghWindow) <- Window.allocate     (optionsFullscreen opts)+    (optionsDisplay opts)     Window.pickLargest     "Keid Engine" 

@@ -49,15 +49,16 @@      , MonadResource m      )   => Bool+  -> Natural   -> SizePicker   -> Text   -> m ([InstanceRequirement], GLFW.Window)-allocate fullscreen sizePicker title = do+allocate fullscreen displayNum sizePicker title = do   UnliftIO unliftIO <- askUnliftIO    let     create = unliftIO $-      createWindow fullscreen sizePicker title+      createWindow fullscreen displayNum sizePicker title      destroy (_exts, window) = unliftIO $       destroyWindow window@@ -66,24 +67,40 @@  createWindow   :: (MonadIO m, MonadReader env m, HasLogFunc env)-  => Bool -> SizePicker -> Text -> m ([InstanceRequirement], GLFW.Window)-createWindow fullScreen sizePicker title = do+  => Bool+  -> Natural+  -> SizePicker+  -> Text+  -> m ([InstanceRequirement], GLFW.Window)+createWindow fullScreen displayNum sizePicker title = do   runGlfwIO_ InitError GLFW.init   runGlfwIO_ VulkanError GLFW.vulkanSupported    liftIO . GLFW.windowHint $ GLFW.WindowHint'ClientAPI GLFW.ClientAPI'NoAPI -  sizes <- runGlfwIO MonitorError GLFW.getMonitors >>= \case-    [] ->-      liftIO . throwIO $ MonitorError GLFW.Error'PlatformError "No monitors returned"-    some ->-      fmap NonEmpty.fromList $-        for some \monitor -> do-          mode <- runGlfwIO VideoModeError $ GLFW.getVideoMode monitor-          pure (monitor, mode)+  monitors <- runGlfwIO MonitorError GLFW.getMonitors+  when (null monitors) $+    liftIO . throwIO $ MonitorError GLFW.Error'PlatformError "No monitors returned" +  modes <- for (zip [1..] monitors) \(ix, monitor) -> do+    mode <- runGlfwIO VideoModeError $ GLFW.getVideoMode monitor+    logDebug $ mconcat+      [ "[display ", displayShow ix, "] "+      , displayShow mode+      ]+    if displayNum /= 0 && displayNum /= ix then+      pure Nothing+    else do+      pure $ Just (monitor, mode)++  (monitor, mode) <-+    case catMaybes modes of+      [] ->+        liftIO . throwIO $ MonitorError GLFW.Error'PlatformError "Selected display number not available"+      so : me ->+        pure $ sizePicker (so :| me)+   let-    (monitor, mode) = sizePicker sizes     GLFW.VideoMode{videoModeWidth=width, videoModeHeight=height} = mode     fsMonitor =       if fullScreen then

@@ -12,8 +12,9 @@  -- | Command line arguments data Options = Options-  { optionsVerbose :: Bool+  { optionsVerbose    :: Bool   , optionsFullscreen :: Bool+  , optionsDisplay    :: Natural   }   deriving (Show) @@ -45,6 +46,12 @@     [ Opt.long "fullscreen"     , Opt.short 'f'     , Opt.help "Run in fullscreen mode"+    ]++  optionsDisplay <- Opt.option Opt.auto $ mconcat+    [ Opt.long "display"+    , Opt.help "Select display number"+    , Opt.value 0     ]    pure Options{..}

@@ -19,6 +19,8 @@   , modifyConfigSTM    , HasOutput(..)+  , pushOutput+  , pushOutputSTM   , updateOutput   , updateOutputSTM   , getOutputData@@ -333,32 +335,37 @@  spawnTimed_   :: MonadUnliftIO m-  => Int-  -> Bool+  => Bool+  -> Int+  -> output   -> m output   -> m (Timed () output)-spawnTimed_ dt startActive stepF =+spawnTimed_ startActive dt initialOutput stepF =   spawnTimed-    (\_old () -> fmap (,()) stepF)-    (Left dt)     startActive-    (error "assert: spawnTimed_ ignores old")+    (Left dt)+    (\() -> pure (initialOutput, ()))+    (\_old () ->+        stepF >>= \res ->+          pure (Just res, ())+    )     ()  spawnTimed   :: MonadUnliftIO m-  => (state -> config -> m (output, state))+  => Bool   -> Either Int (config -> Int)-  -> Bool-  -> state+  -> (config -> m (output, state))+  -> (state -> config -> m (Maybe output, state))   -> config   -> m (Timed config output)-spawnTimed stepF dtF startActive initialState initialConfig = do+spawnTimed startActive dtF initF stepF initialConfig = do   tActive <- newTVarIO startActive   tConfig <- newTVarIO initialConfig-  (initialOutput, nextState) <- stepF initialState initialConfig+  (initialOutput, initialState) <- initF initialConfig   tOutput <- newVar initialOutput-  tWorker <- forkIO $ step tActive tConfig tOutput nextState+  tWorker <- forkIO $+    step tActive tConfig tOutput initialState   pure Timed{..}   where     step activeVar configVar output curState = do@@ -373,7 +380,7 @@       if active then do         config <- readTVarIO configVar         (nextOutput, nextState) <- stepF curState config-        pushOutput output $ const nextOutput+        updateOutput output $ const nextOutput         step activeVar configVar output nextState       else         step activeVar configVar output curState