From 22ad3cd2b75012536c30d28a5ea2227e56bf6894 Mon Sep 17 00:00:00 2001 From: Tristan Cacqueray Date: Fri, 22 Oct 2021 18:31:35 +0200 Subject: [PATCH] Improvements to shader reloading & Toy example - adjust Toy example window positions to make them both visible on startup - make the dynamic resource reloading a bit more understandable by using a custom datatype, and specifically track newness of resources as this can be useful in application logic --- .../apps/FIR/Examples/Bezier/Application.hs | 2 +- .../FIR/Examples/FullPipeline/Application.hs | 2 +- .../apps/FIR/Examples/Hopf/Application.hs | 2 +- .../apps/FIR/Examples/Ising/Application.hs | 2 +- .../apps/FIR/Examples/JuliaSet/Application.hs | 2 +- .../apps/FIR/Examples/Kerr/Application.hs | 2 +- .../apps/FIR/Examples/Logo/Application.hs | 2 +- .../FIR/Examples/RayTracing/Application.hs | 2 +- .../apps/FIR/Examples/Texture/Application.hs | 2 +- .../apps/FIR/Examples/Toy/Application.hs | 103 +++++++++-- .../shaders/FIR/Examples/Toy/Shaders.hs | 170 ++++++++---------- fir-examples/src/FIR/Examples/DearImGui.hs | 89 +++++---- fir-examples/src/FIR/Examples/Reload.hs | 77 ++++++-- fir-examples/src/FIR/Examples/RenderState.hs | 11 +- 14 files changed, 293 insertions(+), 175 deletions(-) diff --git a/fir-examples/examples/apps/FIR/Examples/Bezier/Application.hs b/fir-examples/examples/apps/FIR/Examples/Bezier/Application.hs index 2c40ddc..36befa9 100644 --- a/fir-examples/examples/apps/FIR/Examples/Bezier/Application.hs +++ b/fir-examples/examples/apps/FIR/Examples/Bezier/Application.hs @@ -373,7 +373,7 @@ bezier = runVulkan bezierInitialState do -- shader reloading ( updatedCommands, updatedScreenshotCommands ) - <- statelessly ( snd <$> readTVarWithCleanup resourcesTVar ) + <- statelessly ( snd . fst <$> readDynResources resourcesTVar ) ---------------- -- input diff --git a/fir-examples/examples/apps/FIR/Examples/FullPipeline/Application.hs b/fir-examples/examples/apps/FIR/Examples/FullPipeline/Application.hs index 0ef512e..d863a00 100644 --- a/fir-examples/examples/apps/FIR/Examples/FullPipeline/Application.hs +++ b/fir-examples/examples/apps/FIR/Examples/FullPipeline/Application.hs @@ -380,7 +380,7 @@ fullPipeline = runVulkan initialState do -- shader reloading ( updatedCommands, updatedScreenshotCommands ) - <- statelessly ( snd <$> readTVarWithCleanup resourcesTVar ) + <- statelessly ( snd . fst <$> readDynResources resourcesTVar ) ---------------- -- input diff --git a/fir-examples/examples/apps/FIR/Examples/Hopf/Application.hs b/fir-examples/examples/apps/FIR/Examples/Hopf/Application.hs index a2075cc..8695fe1 100644 --- a/fir-examples/examples/apps/FIR/Examples/Hopf/Application.hs +++ b/fir-examples/examples/apps/FIR/Examples/Hopf/Application.hs @@ -368,7 +368,7 @@ hopf = runVulkan initialState do -- shader reloading ( updatedCommands, updatedScreenshotCommands ) - <- statelessly ( snd <$> readTVarWithCleanup resourcesTVar ) + <- statelessly ( snd . fst <$> readDynResources resourcesTVar ) ---------------- -- input diff --git a/fir-examples/examples/apps/FIR/Examples/Ising/Application.hs b/fir-examples/examples/apps/FIR/Examples/Ising/Application.hs index 4d23331..9f10db1 100644 --- a/fir-examples/examples/apps/FIR/Examples/Ising/Application.hs +++ b/fir-examples/examples/apps/FIR/Examples/Ising/Application.hs @@ -437,7 +437,7 @@ ising = runVulkan initialState do -- shader reloading ( updatedCommands, updatedScreenshotCommands ) - <- statelessly ( snd <$> readTVarWithCleanup resourcesTVar ) + <- statelessly ( snd . fst <$> readDynResources resourcesTVar ) ---------------- -- input diff --git a/fir-examples/examples/apps/FIR/Examples/JuliaSet/Application.hs b/fir-examples/examples/apps/FIR/Examples/JuliaSet/Application.hs index 5e63d65..d439fc8 100644 --- a/fir-examples/examples/apps/FIR/Examples/JuliaSet/Application.hs +++ b/fir-examples/examples/apps/FIR/Examples/JuliaSet/Application.hs @@ -306,7 +306,7 @@ juliaSet = runVulkan initialState do -- shader reloading ( updatedCommands, updatedScreenshotCommands ) - <- statelessly ( snd <$> readTVarWithCleanup resourcesTVar ) + <- statelessly ( snd . fst <$> readDynResources resourcesTVar ) ---------------- -- input diff --git a/fir-examples/examples/apps/FIR/Examples/Kerr/Application.hs b/fir-examples/examples/apps/FIR/Examples/Kerr/Application.hs index 8a926ca..cfc2105 100644 --- a/fir-examples/examples/apps/FIR/Examples/Kerr/Application.hs +++ b/fir-examples/examples/apps/FIR/Examples/Kerr/Application.hs @@ -330,7 +330,7 @@ kerr = runVulkan initialStateKerr do -- shader reloading ( updatedCommands, updatedScreenshotCommands ) - <- statelessly ( snd <$> readTVarWithCleanup resourcesTVar ) + <- statelessly ( snd . fst <$> readDynResources resourcesTVar ) ---------------- -- input diff --git a/fir-examples/examples/apps/FIR/Examples/Logo/Application.hs b/fir-examples/examples/apps/FIR/Examples/Logo/Application.hs index e401d78..c0ab5fd 100644 --- a/fir-examples/examples/apps/FIR/Examples/Logo/Application.hs +++ b/fir-examples/examples/apps/FIR/Examples/Logo/Application.hs @@ -302,7 +302,7 @@ logo = runVulkan initialStateLogo do -- shader reloading ( updatedCommands, updatedScreenshotCommands ) - <- statelessly ( snd <$> readTVarWithCleanup resourcesTVar ) + <- statelessly ( snd . fst <$> readDynResources resourcesTVar ) ---------------- -- input diff --git a/fir-examples/examples/apps/FIR/Examples/RayTracing/Application.hs b/fir-examples/examples/apps/FIR/Examples/RayTracing/Application.hs index d3e12ff..4ea18b0 100644 --- a/fir-examples/examples/apps/FIR/Examples/RayTracing/Application.hs +++ b/fir-examples/examples/apps/FIR/Examples/RayTracing/Application.hs @@ -811,7 +811,7 @@ rayTracing = runVulkan ( initialState, CameraIsLocked False ) do -- shader reloading ( updatedCommands, updatedScreenshotCommands ) - <- statelessly ( snd <$> readTVarWithCleanup resourcesTVar ) + <- statelessly ( snd . fst <$> readDynResources resourcesTVar ) ---------------- -- input diff --git a/fir-examples/examples/apps/FIR/Examples/Texture/Application.hs b/fir-examples/examples/apps/FIR/Examples/Texture/Application.hs index a05355c..3861f55 100644 --- a/fir-examples/examples/apps/FIR/Examples/Texture/Application.hs +++ b/fir-examples/examples/apps/FIR/Examples/Texture/Application.hs @@ -506,7 +506,7 @@ texture = runVulkan initialState do -- shader reloading ( updatedCommands, updatedScreenshotCommands ) - <- statelessly ( snd <$> readTVarWithCleanup resourcesTVar ) + <- statelessly ( snd . fst <$> readDynResources resourcesTVar ) ---------------- -- input diff --git a/fir-examples/examples/apps/FIR/Examples/Toy/Application.hs b/fir-examples/examples/apps/FIR/Examples/Toy/Application.hs index 6b1cee7..e7665be 100644 --- a/fir-examples/examples/apps/FIR/Examples/Toy/Application.hs +++ b/fir-examples/examples/apps/FIR/Examples/Toy/Application.hs @@ -20,6 +20,8 @@ module FIR.Examples.Toy.Application ( toy ) where -- base +import Control.Arrow + ( first ) import Control.Exception ( throw ) import Control.Monad @@ -65,6 +67,8 @@ import qualified Control.Monad.Trans.Resource as ResourceT -- sdl2 import qualified SDL import qualified SDL.Raw.Timer as SDL hiding (delay) +import qualified SDL.Raw.Video as SDL (getWindowDisplayIndex) +import qualified SDL.Internal.Types (Window(..)) -- text-short import Data.Text.Short @@ -96,7 +100,7 @@ import FIR , ModuleRequirements(..) ) import Math.Linear - ( pattern V2, pattern V3 ) + ( V, pattern V2, pattern V3 ) -- fir-examples import FIR.Examples.Common @@ -199,6 +203,56 @@ clearValue2 = Vulkan.Color yellow yellow :: Vulkan.ClearColorValue yellow = Vulkan.Float32 1 1 0 1 +{-| 'moveWindowsSideBySide' positions both windows, side by side, + possibly in the center of the screen, like so: + + ----------------- + | ----- ----- | + | | 1 | | 2 | | + | ----- ----- | + ----------------- +-} +moveWindowsSideBySide :: SDL.Window -> SDL.Window -> IO () +moveWindowsSideBySide win1 win2 = do + -- assume both window are on the same display + (displayX, displayY) <- getDisplaySize win1 + (win1X, win1Y) <- getWinSize win1 + (win2X, win2Y) <- getWinSize win2 + + let + win1PosX = max 0 $ (displayX - win1X - win2X) `div` 2 + win1PosY = max 0 $ (displayY - win1Y) `div` 2 + win2PosX = win1PosX + win1X + win2PosY = max 0 $ (displayY - win2Y) `div` 2 + + setPosition win1 (win1PosX, win1PosY) + setPosition win2 (win2PosX, win2PosY) + + where + getDisplaySize :: SDL.Window -> IO (CInt, CInt) + getDisplaySize (SDL.Internal.Types.Window win) = do + displayIndex <- SDL.getWindowDisplayIndex win + displays <- SDL.getDisplays + let + display = displays !! fromInteger (toInteger displayIndex) + SDL.V2 displayX displayY = SDL.displayBoundsSize display + pure (displayX, displayY) + + getWinSize :: SDL.Window -> IO (CInt, CInt) + getWinSize win = do + -- TODO: take border into account with https://github.com/haskell-game/sdl2/pull/231 + -- We'll have to do the moveWindowsSideBySide call after the first render + -- SDL.V4 winT winL winB winR <- SDL.getWindowBordersSize win + let + borderWidth = 0 -- winL + winR + borderHeight = 0 -- winT + winB + SDL.V2 winX winY <- SDL.get (SDL.windowSize win) + pure (winX + borderWidth, winY + borderHeight) + + setPosition :: SDL.Window -> (CInt, CInt) -> IO () + setPosition win (x, y) = do + SDL.setWindowPosition win (SDL.Absolute (SDL.P (SDL.V2 x y))) + ---------------------------------------------------------------------------- -- Application. @@ -218,6 +272,11 @@ toy = runVulkan (ToyRenderState nullInput nullInput) do ------------------------------------------- -- Initialise window and Vulkan context. + let screenX = 800 + screenY = 600 + screen :: V 2 Float + screen = V2 (fromIntegral screenX) (fromIntegral screenY) + ( window, windowExtensions ) <- initialiseWindow WindowInfo @@ -301,6 +360,8 @@ toy = runVulkan (ToyRenderState nullInput nullInput) do queueFamilyIndexMap = Vulkan.Context.queueFamilyIndex vkContextMap swapchainInfoMap' = Vulkan.Context.aSwapchainInfo vkContextMap + liftIO $ moveWindowsSideBySide window windowMap + let imGuiDescriptorTypes :: [ ( Vulkan.DescriptorType, Int ) ] imGuiDescriptorTypes = map (, 1000) @@ -606,8 +667,8 @@ toy = runVulkan (ToyRenderState nullInput nullInput) do -- keep track of plane position and zoom juliaObserverRef <- liftIO $ newIORef $ initialObserver2D - { zoom = 66, - origin = V2 0 0 + { zoom = 3.8356593, + origin = V2 1.39 0 } juliaInputDataRef <- liftIO $ newIORef Nothing @@ -636,11 +697,21 @@ toy = runVulkan (ToyRenderState nullInput nullInput) do ---------------- -- shader reloading - ( updatedCommands, restoreCommands, updatedScreenshotCommands ) - <- statelessly ( snd <$> readTVarWithCleanup resourcesTVar ) + ( ( updatedCommands, restoreCommands, updatedScreenshotCommands ) + , juliaReloaded ) + <- statelessly ( first snd <$> readDynResources resourcesTVar ) + + ( ( updatedCommandsMap, updatedScreenshotCommandsMap ) + , mapReloaded ) + <- statelessly ( first snd <$> readDynResources resourcesMapTVar ) + + -------------------- + -- controller values - ( updatedCommandsMap, updatedScreenshotCommandsMap ) - <- statelessly ( snd <$> readTVarWithCleanup resourcesMapTVar ) + controllerValues <- readControllers imGuiControllerRefs + let + inversed' :& _ = controllerValues + inversed = inversed' /= 0 ---------------- -- input @@ -663,10 +734,10 @@ toy = runVulkan (ToyRenderState nullInput nullInput) do action = interpretInput 1 newInput newJuliaObserver@(Observer2D juliaZoom juliaOrigin _ _ _ _ _ _ ) = - updateObserver2D prevJuliaObserver (V2 screenX screenY) newInput + updateObserver2D inversed prevJuliaObserver (V2 screenX screenY) newInput newMapObserver@(Observer2D mapZoom mapOrigin _ mapPos _ _ _ mapRightClicked ) = - updateObserver2D prevMapObserver (V2 screenX screenY) newInputMap + updateObserver2D False prevMapObserver (V2 screenX screenY) newInputMap liftIO $ writeIORef juliaObserverRef newJuliaObserver liftIO $ writeIORef mapObserverRef newMapObserver @@ -688,15 +759,13 @@ toy = runVulkan (ToyRenderState nullInput nullInput) do _isPaused <- liftIO $ readIORef paused -- update UBO - controllerValues <- readControllers imGuiControllerRefs - let BufferResource _ updateInputData = inputDataUBO resources BufferResource _ updateInputMapData = inputDataUBO resourcesMap currentInput :: InputData Value - currentInput = 0 :& juliaZoom :& juliaOrigin :& seed :& Prelude.pure 0 :& controllerValues :& End + currentInput = 0 :& screen :& juliaZoom :& juliaOrigin :& seed :& Prelude.pure 0 :& controllerValues :& End currentInputMap :: InputData Value - currentInputMap = 1 :& mapZoom :& mapOrigin :& seed :& Prelude.pure 0 :& controllerValues :& End + currentInputMap = 1 :& screen :& mapZoom :& mapOrigin :& seed :& Prelude.pure 0 :& controllerValues :& End juliaUpdated <- isJuliaUpdated currentInput when juliaUpdated $ liftIO ( updateInputData currentInput ) @@ -731,9 +800,9 @@ toy = runVulkan (ToyRenderState nullInput nullInput) do let commandBuffer - | takeScreenshot action = updatedScreenshotCommands `V.index` nextImageIndex - | juliaUpdated = updatedCommands `V.index` nextImageIndex - | otherwise = restoreCommands `V.index` nextImageIndex + | takeScreenshot action = updatedScreenshotCommands `V.index` nextImageIndex + | juliaUpdated || juliaReloaded = updatedCommands `V.index` nextImageIndex + | otherwise = restoreCommands `V.index` nextImageIndex submitCommandBuffer queueJulia @@ -758,7 +827,7 @@ toy = runVulkan (ToyRenderState nullInput nullInput) do ---------------- -- rendering map - when mapUpdated do + when (mapUpdated || mapReloaded) do nextImageIndexMap <- acquireNextImage deviceMap swapchainInfoMap nextImageSemMap let commandBufferMap diff --git a/fir-examples/examples/shaders/FIR/Examples/Toy/Shaders.hs b/fir-examples/examples/shaders/FIR/Examples/Toy/Shaders.hs index d90e6a0..956878b 100644 --- a/fir-examples/examples/shaders/FIR/Examples/Toy/Shaders.hs +++ b/fir-examples/examples/shaders/FIR/Examples/Toy/Shaders.hs @@ -25,6 +25,8 @@ import Data.Maybe ( fromJust ) import GHC.TypeNats ( KnownNat ) +import Prelude + ( Int ) import qualified Prelude -- filepath @@ -59,6 +61,7 @@ type InputData :: ControllerRef -> Type type InputData ref = Struct '[ "map_mode" ':-> Word32 + , "screen" ':-> V 2 Float , "zoom" ':-> Float , "origin" ':-> V 2 Float , "seed" ':-> V 2 Float @@ -69,18 +72,20 @@ type InputData ref = type ImGuiData :: ControllerRef -> Type type ImGuiData ref = Struct - '[ "color" ':-> ControllerData ref Float - , "max_iter" ':-> ControllerData ref Float + '[ "inverse" ':-> ControllerData ref () Int32 + , "color" ':-> ControllerData ref (Float, Float) Float + , "max_iter" ':-> ControllerData ref (Int, Int) Int32 ] initImGuiData :: ImGuiData InitValue initImGuiData - = ( "Color", Slider, 0 ) - :& ( "Iterations", Slider, 0 ) + = ( "Inverse Axis", Toggle, (), 1 ) + :& ( "Itensity", Slider, (0, 1), 0.5 ) + :& ( "Iterations", DiscreteSlider, (1, 256), 42 ) :& End initInputData :: InputData Value -initInputData = 0 :& 0 :& V2 0 0 :& V2 0 0 :& Prelude.pure 0 :& controllerInitValues initImGuiData :& End +initInputData = 0 :& V2 0 0 :& 0 :& V2 0 0 :& V2 0 0 :& Prelude.pure 0 :& controllerInitValues initImGuiData :& End ------------------------------------------------ -- pipeline input @@ -113,111 +118,82 @@ type FragmentDefs = Fragment ] -maxDepth :: Code Word32 -maxDepth = 256 - -xSamples, ySamples :: Code Word32 -xSamples = 4 -ySamples = 4 - -xWidth, yWidth :: Code Float -xWidth = recip . fromIntegral $ xSamples -yWidth = recip . fromIntegral $ ySamples - -pixel2Coord :: Code Float -> Code (V 2 Float) -> Code (V 4 Float) -> Code (V 2 Float) -pixel2Coord range (Vec2 centerX centerY) (Vec4 pixX' pixY' _ _) = - let (pixX, pixY) = if inverseCoord then (pixY', pixX') else (pixX', pixY') - (uvX, uvY) = (pixX / screenXF, pixY / screenYF) - coordX = (screenXF / screenYF) * (uvX - 0.5) +pixel2Coord :: Code (V 2 Float) -> Code Float -> Code (V 2 Float) -> Code (V 2 Float) -> Code (V 2 Float) +pixel2Coord (Vec2 scrX scrY) range (Vec2 centerX centerY) (Vec2 pixX pixY) = + let + (uvX, uvY) = (pixX / scrX, pixY / scrY) + coordX = (scrX / scrY) * (uvX - 0.5) coordY = (-1) * (uvY - 0.5) x = centerX + coordX * range y = centerY + coordY * range in Vec2 x y --- Params begins - -inverseCoord :: Bool -inverseCoord = False - -screenX, screenY :: Word32 -(screenX, screenY) = (800, 600) - -screenXF, screenYF :: Code Float -screenXF = Lit (fromIntegral screenX) -screenYF = Lit (fromIntegral screenY) - -grad_freq :: Code Float -grad_freq = 0.6 - --- Params ends -fragment :: ShaderModule "main" FragmentShader FragmentDefs _ -fragment = shader do - gl_FragCoord <- #gl_FragCoord - color <- use @(Name "ubo" :.: Name "imGuiData" :.: Name "color") - max_iter' <- use @(Name "ubo" :.: Name "imGuiData" :.: Name "max_iter") - map_mode' <- use @(Name "ubo" :.: Name "map_mode") - seed <- use @(Name "ubo" :.: Name "seed") - range <- use @(Name "ubo" :.: Name "zoom") - origin <- use @(Name "ubo" :.: Name "origin") - - let escape = 4242 - map_mode = map_mode' /= 0 - let max_iter :: Code Word32 - max_iter = 100 + (250 * round max_iter') - - #modulus #= (0 :: Code Float) - #mean #= (0 :: Code Float) - - #iter #= (0 :: Code Word32) - - let pixelCoord = pixel2Coord range origin gl_FragCoord - - #depth #= (0 :: Code Word32) - - #z #= (if map_mode then Lit (V2 0 0) else pixelCoord) - let c = (if map_mode then pixelCoord else seed) +-- | Compute the pixel color using the Duck set fractal: +-- http://www.algorithmic-worlds.net/blog/blog.php?Post=20110227 +quackColor :: Code Word32 -> Code (V 2 Float) -> Code (V 2 Float) -> Program _ _ (Code Float) +quackColor max_iter initZ c = purely do + -- Define stateful variable for the loop + _ <- def @"iter" @RW ( 0 :: Code Word32 ) + _ <- def @"z" @RW initZ + _ <- def @"mean" @RW ( 0 :: Code Float ) loop do - iter <- #iter - modulus <- #modulus - z <- #z - if iter > max_iter || modulus > escape + -- Get the current z value + ~(Vec2 zR zI) <- get @"z" + -- Compute next z value : log( zR+abs(zI)i + c ) + z <- let' $ complexLog $ CodeComplex ( Vec2 zR (abs zI) ^+^ c ) + + modulus <- let' (magnitude z) + mean <- get @"mean" + put @"mean" $ mean + modulus + put @"z" $ codeComplex z + + iter <- get @"iter" + if iter >= max_iter || modulus > escape then break @1 - else do - let Vec2 zR zI = z - newZ = Vec2 zR (abs zI) ^+^ c - - newZLog = complexLog (CodeComplex newZ) - - newModulus = magnitude newZLog + else put @"iter" $ iter + 1 - #modulus .= newModulus + iter <- get @"iter" + mean <- get @"mean" + pure $ + if iter == max_iter + then 1 - (0.3 * mean / fromIntegral iter) + else 0 - mean <- #mean - #mean .= (mean + newModulus) + where + escape = 4242 - #iter .= (iter + 1) - #z .= codeComplex newZLog - iter <- #iter - mean <- #mean - modulus <- #modulus - let iterF = fromIntegral iter - - t <- - let' @(Code Float) $ - if iter == (max_iter + 1) - then 1 - (0.3 * mean / iterF) - else - let ml = iterF - log (log (grad_freq * modulus)) / log 2 + log (log escape) / log 2 - res = ml / fromIntegral max_iter - in res - - let col = if map_mode && nearBy (range / 100) pixelCoord seed +fragment :: ShaderModule "main" FragmentShader FragmentDefs _ +fragment = shader do + -- Get CPU data + ~(Vec4 px py _ _) <- #gl_FragCoord + ~(Vec2 sx sy) <- use @(Name "ubo" :.: Name "screen") + intensity <- use @(Name "ubo" :.: Name "imGuiData" :.: Name "color") + max_iter' <- use @(Name "ubo" :.: Name "imGuiData" :.: Name "max_iter") + inverse_coord <- use @(Name "ubo" :.: Name "imGuiData" :.: Name "inverse") + map_mode' <- use @(Name "ubo" :.: Name "map_mode") + seed <- use @(Name "ubo" :.: Name "seed") + range <- use @(Name "ubo" :.: Name "zoom") + origin <- use @(Name "ubo" :.: Name "origin") + + -- Adapt the values + map_mode <- let' $ map_mode' /= 0 + inversed <- let' $ not map_mode && (inverse_coord /= 0) + pixel <- let' $ if inversed then Vec2 py px else Vec2 px py + screen <- let' $ if inversed then Vec2 sy sx else Vec2 sx sy + coord <- let' $ pixel2Coord screen range origin pixel + + max_iter <- let' $ fromIntegral max_iter' + z <- let' $ if map_mode then Lit (V2 0 0) else coord + c <- let' $ if map_mode then coord else seed + + -- Compute the color + color <- quackColor max_iter z c + + let col = if map_mode && nearBy (range / 100) coord seed then Lit seedColor - else gradient ((1 + 7 * color) * t) (Lit sunset) - - --let col' = Vec4 t 0.2 0.1 0.5 + else gradient (color * intensity) (Lit sunset) #out_colour .= col diff --git a/fir-examples/src/FIR/Examples/DearImGui.hs b/fir-examples/src/FIR/Examples/DearImGui.hs index 279f8d6..4eb9300 100644 --- a/fir-examples/src/FIR/Examples/DearImGui.hs +++ b/fir-examples/src/FIR/Examples/DearImGui.hs @@ -34,15 +34,29 @@ import FIR -------------------------------------------------------------------------------- -data Controller a where - Slider :: Controller Float - Toggle :: Controller Int32 - -createController :: MonadIO m => String -> Controller a -> IORef a -> m () -createController controllerName controllerType ref = +-- | A Controller is parameterized by its static /range/ and its dynamic value /dyn/. +data Controller range dyn where + Slider :: Controller (Float, Float) Float + DiscreteSlider :: Controller (Int, Int) Int32 + Toggle :: Controller () Int32 + +createController :: MonadIO m => String -> Controller range dyn -> range -> IORef dyn -> m () +createController controllerName controllerType range ref = case controllerType of Slider -> - void $ DearImGui.sliderFloat controllerName ref 0.0 1.0 + let (start, end) = range + in void $ DearImGui.sliderFloat controllerName ref start end + DiscreteSlider -> do + pos <- liftIO $ do + -- Create a IORef Int from the original Int32 controller ref + val <- readIORef ref + newIORef (fromIntegral val) + let (start, end) = range + void $ DearImGui.sliderInt controllerName pos start end + liftIO $ do + -- Convert back the Int to the Int32 controller ref value + newPos <- readIORef pos + writeIORef ref (fromIntegral newPos) Toggle -> do bref <- liftIO $ do -- Create a IORef Bool from the original Int32 controller ref @@ -56,29 +70,41 @@ createController controllerName controllerType ref = -------------------------------------------------------------------------------- +-- | ControllerRef defines the three values a controller can be represented in: +-- * 'InitValue' for initialization with concret values (e.g. the shader provide that). +-- * 'Ref' for update through IORef (e.g. the createController use that to call DearImGui). +-- * 'Value' for rendering the actual value (e.g. the shader use that to update the UBO). data ControllerRef = InitValue | Ref | Value -type ControllerData :: ControllerRef -> Type -> Type -type family ControllerData ref a where - ControllerData 'InitValue a = ( String, Controller a, a ) - ControllerData 'Ref a = ( String, Controller a, IORef a ) - ControllerData 'Value a = a - +-- | ControllerData defines the actual types for each ControllerRef +type ControllerData :: ControllerRef -> Type -> Type -> Type +type family ControllerData ref range dyn where + -- | (name, controller, range, initial value) + ControllerData 'InitValue range dyn = ( String, Controller range dyn, range, dyn ) + -- | (name, controller, range, ref value) + ControllerData 'Ref range dyn = ( String, Controller range dyn, range, IORef dyn ) + -- | the value + ControllerData 'Value _ dyn = dyn + +-- | 'controllerInitValues' is used by the Shader to convert a list of controller into the 'InputData' type ControllerInitValues :: [ Symbol :-> Type ] -> [ Symbol :-> Type ] -> Constraint -class ControllerInitValues as bs | as -> bs, bs -> as where +class ControllerInitValues as bs | as -> bs where controllerInitValues :: Struct as -> Struct bs instance ControllerInitValues '[] '[] where controllerInitValues _ = End instance ( ControllerInitValues as bs , k1 ~ k2 - , v ~ ( String, Controller a, a ) - , r ~ a + , v ~ ( String, Controller range dyn, range, dyn ) + , r ~ dyn ) => ControllerInitValues ( ( k1 ':-> v ) ': as ) ( ( k2 ':-> r ) ': bs ) where - controllerInitValues ( ( _, _, a ) :& as ) = - a :& controllerInitValues as + controllerInitValues ( ( _, _, _, dyn ) :& as ) = + dyn :& controllerInitValues as +-- | 'createControllerRefs' is used by the Application to convert the initial values provided by the shader: +-- * This is used to read the values for updating the UBO, and, +-- * To create the DearImGui draw calls. type CreateControllerRefs :: [ Symbol :-> Type ] -> [ Symbol :-> Type ] -> Constraint class CreateControllerRefs as bs | as -> bs, bs -> as where createControllerRefs :: MonadIO m => Struct as -> m ( Struct bs ) @@ -86,43 +112,44 @@ instance CreateControllerRefs '[] '[] where createControllerRefs _ = pure End instance ( CreateControllerRefs as bs , k1 ~ k2 - , v ~ ( String, Controller a, a ) - , r ~ ( String, Controller a, IORef a ) + , v ~ ( String, Controller range dyn, range, dyn ) + , r ~ ( String, Controller range dyn, range, IORef dyn ) ) => CreateControllerRefs ( ( k1 ':-> v ) ': as ) ( ( k2 ':-> r ) ': bs ) where - createControllerRefs ( ( nm, ct, a ) :& as ) = do - ref <- liftIO $ newIORef a + createControllerRefs ( ( nm, ct, range, dyn ) :& as ) = do + ref <- liftIO $ newIORef dyn refs <- createControllerRefs as - pure ( ( nm, ct, ref ) :& refs ) + pure ( ( nm, ct, range, ref ) :& refs ) +-- | 'createControllers' calls the 'createController' for each controller to create all the DearImGui draw calls. type CreateControllers :: [ Symbol :-> Type ] -> Constraint class CreateControllers as where createControllers :: MonadIO m => Struct as -> m () instance CreateControllers '[] where createControllers _ = pure () instance ( CreateControllers as - , r ~ ( String, Controller a, IORef a ) + , r ~ ( String, Controller range dyn, range, IORef dyn ) ) => CreateControllers ( ( k ':-> r ) ': as ) where - createControllers ( ( nm, ct, r ) :& rs ) = - createController nm ct r *> createControllers rs + createControllers ( ( nm, ct, range, dyn ) :& rs ) = + createController nm ct range dyn *> createControllers rs +-- | 'readControllers' convert the controller in their value to update the UBOs. type ReadControllers :: [ Symbol :-> Type ] -> [ Symbol :-> Type ] -> Constraint -class ReadControllers as bs | as -> bs, bs -> as where +class ReadControllers as bs | as -> bs where readControllers :: MonadIO m => Struct as -> m ( Struct bs ) instance ReadControllers '[] '[] where readControllers _ = pure End instance ( ReadControllers as bs , k1 ~ k2 - , r ~ ( String, Controller a, IORef a ) - , b ~ a + , r ~ ( String, Controller range dyn, range, IORef dyn ) + , b ~ dyn ) => ReadControllers ( ( k1 ':-> r ) ': as ) ( ( k2 ':-> b ) ': bs ) where - readControllers ( ( _, _, r ) :& rs ) = do + readControllers ( ( _, _, _, r ) :& rs ) = do a <- liftIO $ readIORef r as <- readControllers rs pure ( a :& as ) - diff --git a/fir-examples/src/FIR/Examples/Reload.hs b/fir-examples/src/FIR/Examples/Reload.hs index c63cf46..67de0ae 100644 --- a/fir-examples/src/FIR/Examples/Reload.hs +++ b/fir-examples/src/FIR/Examples/Reload.hs @@ -2,13 +2,16 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ViewPatterns #-} module FIR.Examples.Reload - ( shaderReloadWatcher, readTVarWithCleanup ) + ( shaderReloadWatcher + , DynResources(..), readDynResources + ) where -- base @@ -84,17 +87,48 @@ import Vulkan.Pipeline ---------------------------------------------------------------------------- --- Read a TVar containing a clean-up action. --- Ensures the clean-up action is run exactly once. -readTVarWithCleanup :: MonadIO m => TVar ( x, m () ) -> m x -readTVarWithCleanup tvar = do - ( x, cleanup ) - <- liftIO $ atomically do - ( x, cleanup ) <- readTVar tvar - writeTVar tvar ( x, pure () ) - pure ( x, cleanup ) +-- | Reads a 'DynResources' 'TVar' and ensures the clean-up action is run exactly once. +-- +-- The returned 'Bool' indicates whether the resources are new. +readDynResources :: MonadIO m => TVar (DynResources m r) -> m (r, Bool) +readDynResources tvar = do + ( res, cleanup ) <- liftIO $ atomically do + DynResources + { currentResources = x + , cleanupPrevious = cleanup + , resourcesAreNew = new + } <- readTVar tvar + writeTVar tvar $ + DynResources + { currentResources = x + , cleanupPrevious = pure () + , resourcesAreNew = False + } + pure ( (x, new), cleanup ) cleanup - pure x + pure res + +newDynResources + :: ( MonadIO m, Applicative t ) + => r -> m ( TVar ( DynResources t r ) ) +newDynResources r + = liftIO $ newTVarIO dynRes + where + dynRes = + DynResources + { currentResources = r + , cleanupPrevious = pure () + , resourcesAreNew = False + } + +data DynResources t r + = DynResources + { currentResources :: r + , cleanupPrevious :: t () + -- | A flag to indicate whether the resources are new, + -- to be reset to 'False' once we start using them. + , resourcesAreNew :: Bool + } shaderReloadWatcher :: forall t l r @@ -102,11 +136,11 @@ shaderReloadWatcher => Vulkan.Device -> t ( FilePath, (ReleaseKey, Vulkan.ShaderModule) ) -> ( t Vulkan.ShaderModule -> l ( l (), r ) ) - -> l ( TVar ( ( l () , r ), l () ) ) + -> l ( TVar (DynResources l ( l (), r )) ) shaderReloadWatcher device shaders createFromShaders = do logDebug "Starting shader reload watcher." originalResources <- createFromShaders $ fmap ( snd . snd ) shaders - resourcesTVar <- liftIO $ newTVarIO ( originalResources, pure () ) + resourcesTVar <- newDynResources originalResources modifiedFilesTMVar <- liftIO $ newEmptyTMVarIO signalStop <- liftIO $ newEmptyTMVarIO let @@ -115,7 +149,7 @@ shaderReloadWatcher device shaders createFromShaders = do shaderNames :: Set FilePath shaderNames = Set.fromList $ toList ( fmap ( takeFileName . fst ) shaders ) liftIO $ startWatchOver signalStop shaderDir shaderNames modifiedFilesTMVar - runInIO <- askRunInIO + runInIO <- askRunInIO void $ allocate ( forkIO ( runInIO reloader ) ) ( \ reloaderThreadId -> do @@ -134,7 +168,7 @@ resourceReloader -> t ( FilePath, (ReleaseKey, Vulkan.ShaderModule) ) -> ( t Vulkan.ShaderModule -> l ( l (), r ) ) -> TMVar (Set FilePath) - -> TVar ( ( l () , r ), l () ) + -> TVar (DynResources l ( l (), r ) ) -> l () resourceReloader device shaders createFromShaders modifiedFilesTMVar resourcesTVar = outerLoop shaders @@ -196,7 +230,9 @@ resourceReloader device shaders createFromShaders modifiedFilesTMVar resourcesTV -- As we don't own the resources currently in use (they are from the main thread), -- we return an action which performs cleanup of current resources before returning the new resources. liftIO $ atomically do - ( ( releaseCurrentResources, _ ), releaseOldResources ) + DynResources + { currentResources = (releaseCurrentResources, _) + , cleanupPrevious = releaseOldResources } <- readTVar resourcesTVar let releasePreviousResources :: l () @@ -204,7 +240,12 @@ resourceReloader device shaders createFromShaders modifiedFilesTMVar resourcesTV releaseOldResources releaseCurrentResources traverse_ release oldShaderKeys - writeTVar resourcesTVar ( ( releaseNewResources, newResources ), releasePreviousResources ) + writeTVar resourcesTVar $ + DynResources + { currentResources = (releaseNewResources, newResources) + , cleanupPrevious = releasePreviousResources + , resourcesAreNew = True + } logDebug ( "New resources ready to be used." ) outerLoop newShaders @@ -226,7 +267,7 @@ loadNewShaders device shaders modifiedPaths = startWatchOver :: TMVar () -> FilePath -> Set FilePath -> TMVar (Set FilePath) -> IO () startWatchOver signalStop dir watchNames modifiedPaths = - void $ forkIO $ + void $ forkIO $ FSNotify.withManager \ watchManager -> do stop <- FSNotify.watchDir watchManager dir ( ( `Set.member` watchNames ) . takeFileName . eventPath ) diff --git a/fir-examples/src/FIR/Examples/RenderState.hs b/fir-examples/src/FIR/Examples/RenderState.hs index 4297987..e0b331e 100644 --- a/fir-examples/src/FIR/Examples/RenderState.hs +++ b/fir-examples/src/FIR/Examples/RenderState.hs @@ -159,8 +159,8 @@ initialObserver2D = mouseRightClicked = False in Observer2D {..} -updateObserver2D :: Observer2D -> V 2 Word32 -> Input -> Observer2D -updateObserver2D Observer2D {..} screen Input {..} = +updateObserver2D :: Bool -> Observer2D -> V 2 Word32 -> Input -> Observer2D +updateObserver2D inversed Observer2D {..} screen Input {..} = let scrolled = mouseWheel - scroll newZoom = @@ -172,7 +172,12 @@ updateObserver2D Observer2D {..} screen Input {..} = else zoom - newMouseCoordPos = pos2Coord screen origin zoom mousePos + inverse :: V 2 a -> V 2 a + inverse (V2 x y) + | inversed = V2 y x + | otherwise = V2 x y + + newMouseCoordPos = pos2Coord (inverse screen) origin zoom (inverse mousePos) newOrigin = if newMouseLeftClicked -- GitLab