From cedb76356ea440e9e552f99fcccd5bfa92da56c5 Mon Sep 17 00:00:00 2001 From: sheaf Date: Sun, 20 Jun 2021 19:17:14 +0200 Subject: [PATCH 1/5] Add Toy shader example (stub) --- fir-examples/cabal.project | 3 + .../apps/FIR/Examples/Toy/Application.hs | 373 ++++++++++++++++++ fir-examples/examples/exes/Toy/Main.hs | 7 + .../shaders/FIR/Examples/Toy/Shaders.hs | 201 ++++++++++ fir-examples/fir-examples.cabal | 28 ++ fir-examples/readme.md | 20 + 6 files changed, 632 insertions(+) create mode 100644 fir-examples/examples/apps/FIR/Examples/Toy/Application.hs create mode 100644 fir-examples/examples/exes/Toy/Main.hs create mode 100644 fir-examples/examples/shaders/FIR/Examples/Toy/Shaders.hs diff --git a/fir-examples/cabal.project b/fir-examples/cabal.project index 45eb2825..e65a31d2 100644 --- a/fir-examples/cabal.project +++ b/fir-examples/cabal.project @@ -43,3 +43,6 @@ source-repository-package type: git location: https://github.com/sheaf/generic-lens tag: e2b4e7d77beaa094c8137b9f7a1f860a6469d837 + +package dear-imgui + flags: +sdl2 -glfw -opengl2 -opengl3 +vulkan -examples diff --git a/fir-examples/examples/apps/FIR/Examples/Toy/Application.hs b/fir-examples/examples/apps/FIR/Examples/Toy/Application.hs new file mode 100644 index 00000000..419a892a --- /dev/null +++ b/fir-examples/examples/apps/FIR/Examples/Toy/Application.hs @@ -0,0 +1,373 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +module FIR.Examples.Toy.Application ( toy ) where + +-- base +import Control.Monad + ( when, void ) +import Data.String + ( IsString ) +import Data.Traversable + ( for ) +import Data.Word + ( Word32 ) +import GHC.Generics + ( Generic ) + +-- lens +import Control.Lens + ( use, assign ) + +-- logging-effect +import Control.Monad.Log + ( logDebug, logInfo ) + +-- sdl2 +import qualified SDL +import qualified SDL.Event +import qualified SDL.Raw.Event as SDL + +-- text-short +import Data.Text.Short + ( ShortText ) +import qualified Data.Text.Short as ShortText + ( pack, unpack ) + +-- transformers +import Control.Monad.IO.Class + ( liftIO ) + +-- vector +import qualified Data.Vector as Boxed.Vector + ( singleton ) + +-- vector-sized +import qualified Data.Vector.Sized as V + ( zip, zip3, index ) + +-- vulkan +import qualified Vulkan + +-- fir +import FIR + ( runCompilationsTH + , Struct((:&),End) + , ModuleRequirements(..) + ) +import Math.Linear + ( V + , pattern V2, pattern V3 + , (^+^), (*^) + ) + +-- fir-examples +import FIR.Examples.Common +import FIR.Examples.Toy.Shaders +import FIR.Examples.Paths +import FIR.Examples.Reload +import FIR.Examples.RenderState +import Vulkan.Attachment +import Vulkan.Backend +import Vulkan.Context +import Vulkan.Monad +import Vulkan.Pipeline +import Vulkan.Resource +import Vulkan.Screenshot + +---------------------------------------------------------------------------- +-- Shaders and resources. + +shaderCompilationResult :: Either ShortText ModuleRequirements +shaderCompilationResult + = $( runCompilationsTH + [ ("Vertex shader" , compileVertexShader ) + , ("Fragment shader", compileFragmentShader ) + ] + ) + +appName :: IsString a => a +appName = "fir-examples - Shader toy" +shortName :: String +shortName = "toy" -- name for screenshots + +type VertexData = Struct VertexInput + +data ResourceSet i st + = ResourceSet + { mousePosUBO :: UniformBuffer (V 2 Float) i st + , vertexBuffer :: VertexBuffer VertexData i st + , indexBuffer :: IndexBuffer Word32 i st + } + deriving Generic + +viewportVertices :: [ Struct VertexInput ] +viewportVertices = + [ V3 (-1) (-1) 0 :& End + , V3 (-1) 1 0 :& End + , V3 1 (-1) 0 :& End + , V3 1 1 0 :& End + ] + +viewportIndices :: [ Word32 ] +viewportIndices + = [ 0, 1, 2 + , 2, 1, 3 + ] + +nbIndices :: Word32 +nbIndices = 6 + +initialResourceSet :: ResourceSet numImages Pre +initialResourceSet = ResourceSet + ( BufferData ( V2 0 0 ) ) + ( BufferData viewportVertices ) + ( BufferData viewportIndices ) + +clearValue :: Vulkan.ClearValue +clearValue = Vulkan.Color black + where + black :: Vulkan.ClearColorValue + black = Vulkan.Float32 0 0 0 0 + +---------------------------------------------------------------------------- +-- Application. + +toy :: IO () +toy = runVulkan initialState do + + ------------------------------------------- + -- Obtain requirements from shaders. + + ( reqs :: ModuleRequirements ) <- + case shaderCompilationResult of + Left err -> error $ "Shader compilation was unsuccessful:\n" <> ShortText.unpack err + Right reqs -> do + logInfo ( "Shaders were successfully compiled.\nShader directory:\n" <> ShortText.pack shaderDir ) + pure reqs + + ------------------------------------------- + -- Initialise window and Vulkan context. + + ( window, windowExtensions ) <- + initialiseWindow + WindowInfo + { width = 1920 + , height = 1080 + , windowName = appName + , mouseMode = SDL.AbsoluteLocation + } + let + vulkanReqs = ignoreMinVersion . addInstanceExtensions windowExtensions $ vulkanRequirements reqs + surfaceInfo = + SurfaceInfo + { surfaceWindow = window + , preferredFormat = + Vulkan.SurfaceFormatKHR + Vulkan.FORMAT_B8G8R8A8_UNORM + Vulkan.COLOR_SPACE_SRGB_NONLINEAR_KHR + , surfaceUsage = + [ Vulkan.IMAGE_USAGE_TRANSFER_SRC_BIT + , Vulkan.IMAGE_USAGE_COLOR_ATTACHMENT_BIT + ] + } + + VulkanContext{..} <- + initialiseContext @WithSwapchain Normal appName vulkanReqs + RenderInfo + { queueType = Vulkan.QUEUE_GRAPHICS_BIT + , surfaceInfo = surfaceInfo + } + + withSwapchainInfo aSwapchainInfo \ ( swapchainInfo@(SwapchainInfo {..}) :: SwapchainInfo numImages ) -> do + + ------------------------------------------- + -- Create framebuffer attachments. + + let + width, height :: Num a => a + width = fromIntegral $ ( Vulkan.width :: Vulkan.Extent2D -> Word32 ) swapchainExtent + height = fromIntegral $ ( Vulkan.height :: Vulkan.Extent2D -> Word32 ) swapchainExtent + + extent3D :: Vulkan.Extent3D + extent3D + = Vulkan.Extent3D + { Vulkan.width = width + , Vulkan.height = height + , Vulkan.depth = 1 + } + + colFmt :: Vulkan.Format + colFmt = ( Vulkan.format :: Vulkan.SurfaceFormatKHR -> Vulkan.Format ) surfaceFormat + + renderPass <- logDebug "Creating a render pass" *> + simpleRenderPass device + ( noAttachments + { colorAttachments = Boxed.Vector.singleton $ presentableColorAttachmentDescription colFmt } + ) + + framebuffersWithAttachments + <- logDebug "Creating frame buffers" + *> ( for swapchainImages $ \swapchainImage -> do + + colorImageView + <- createImageView + device swapchainImage + Vulkan.IMAGE_VIEW_TYPE_2D + colFmt + Vulkan.IMAGE_ASPECT_COLOR_BIT + let attachment = (swapchainImage, colorImageView) + framebuffer <- createFramebuffer device renderPass swapchainExtent [colorImageView] + pure (framebuffer, attachment) + ) + + screenshotImagesAndMemories <- + for swapchainImages $ \ _ -> + createScreenshotImage physicalDevice device + ( screenshotImageInfo extent3D colFmt ) + + ------------------------------------------- + -- Manage resources. + + let + + resourceFlags :: ResourceSet numImages Named + resourceFlags = ResourceSet + ( StageFlags Vulkan.SHADER_STAGE_FRAGMENT_BIT ) + GeneralResource + GeneralResource + + PostInitialisationResult + descriptorSetLayout descriptorSets cmdBindBuffers resources + <- initialiseResources physicalDevice device resourceFlags initialResourceSet + + ------------------------------------------- + -- Create command buffers and record commands into them. + + commandPool <- logDebug "Creating command pool" *> ( snd <$> createCommandPool device queueFamilyIndex ) + queue <- getQueue device 0 + + (_, nextImageSem ) <- createSemaphore device + (_, submitted ) <- createSemaphore device + + pipelineLayout <- logDebug "Creating pipeline layout" *> createPipelineLayout device [descriptorSetLayout] + let pipelineInfo = VkPipelineInfo swapchainExtent Vulkan.SAMPLE_COUNT_1_BIT pipelineLayout + + shaders <- logDebug "Loading shaders" *> traverse (\path -> (path, ) <$> loadShader device path) shaderPipeline + + let + recordCommandBuffers pipe = + for (V.zip descriptorSets framebuffersWithAttachments) $ \ ( descriptorSet, (framebuffer, attachment ) ) -> + recordSimpleIndexedDrawCall + device commandPool framebuffer (renderPass, [clearValue]) + descriptorSet cmdBindBuffers + ( fst attachment, swapchainExtent ) + Nothing + nbIndices + pipelineLayout pipe + recordScreenshotCommandBuffers pipe = + for (V.zip3 descriptorSets framebuffersWithAttachments screenshotImagesAndMemories) + \ ( descriptorSet, (framebuffer, attachment), (screenshotImage, _) ) -> + recordSimpleIndexedDrawCall + device commandPool framebuffer (renderPass, [clearValue]) + descriptorSet cmdBindBuffers + ( fst attachment, swapchainExtent ) + ( Just ( screenshotImage, extent3D ) ) + nbIndices + pipelineLayout pipe + + recordAllCommandsFromShaders = record2CommandBuffersFromShaders + ( createGraphicsPipeline device renderPass pipelineInfo ) + recordCommandBuffers + recordScreenshotCommandBuffers + + -- launch shader reload watcher, which writes command buffers to use to a TVar + resourcesTVar <- statelessly $ shaderReloadWatcher device shaders recordAllCommandsFromShaders + + mainLoop do + + ---------------- + -- shader reloading + + ( updatedCommands, updatedScreenshotCommands ) + <- statelessly ( snd <$> readTVarWithCleanup resourcesTVar ) + + ---------------- + -- input + + inputEvents <- map SDL.Event.eventPayload <$> SDL.pollEvents + prevInput <- use _input + let + prevAction = interpretInput 1 prevInput + newInput = foldl onSDLInput prevInput inputEvents + action = interpretInput 1 newInput + + pos <- + if locate action + then do void $ SDL.setMouseLocationMode SDL.RelativeLocation + -- precision mode + pure ( mousePos prevInput ^+^ ( 20 *^ mouseRel newInput ) ) + else do void $ SDL.setMouseLocationMode SDL.AbsoluteLocation + -- smooth out mouse movement slightly + let pos@(V2 px py) = 0.5 *^ ( mousePos prevInput ^+^ mousePos newInput ) + when (locate prevAction) do + ( SDL.warpMouse SDL.WarpCurrentFocus (SDL.P (SDL.V2 (round px) (round py))) ) + _ <- SDL.captureMouse True + pure () + + pure pos + assign _input ( newInput { mousePos = pos, mouseRel = pure 0 } ) + + ---------------- + -- simulation + + -- update UBO + let + BufferResource _ updateMousePos = mousePosUBO resources + + liftIO ( updateMousePos pos ) + + + ---------------- + -- rendering + + nextImageIndex <- acquireNextImage device swapchainInfo nextImageSem + + let + commandBuffer + | takeScreenshot action = updatedScreenshotCommands `V.index` nextImageIndex + | otherwise = updatedCommands `V.index` nextImageIndex + + submitCommandBuffer + queue + commandBuffer + [(nextImageSem, Vulkan.PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT)] + [submitted] + Nothing + + present queue swapchain nextImageIndex [submitted] + + Vulkan.queueWaitIdle queue + + when ( takeScreenshot action ) $ + writeScreenshotData shortName device swapchainExtent + ( snd ( screenshotImagesAndMemories `V.index` nextImageIndex ) ) + + ---------------- + + pure ( shouldQuit action ) diff --git a/fir-examples/examples/exes/Toy/Main.hs b/fir-examples/examples/exes/Toy/Main.hs new file mode 100644 index 00000000..79b66b1e --- /dev/null +++ b/fir-examples/examples/exes/Toy/Main.hs @@ -0,0 +1,7 @@ +module Main where + +import FIR.Examples.Toy.Application + ( toy ) + +main :: IO () +main = toy diff --git a/fir-examples/examples/shaders/FIR/Examples/Toy/Shaders.hs b/fir-examples/examples/shaders/FIR/Examples/Toy/Shaders.hs new file mode 100644 index 00000000..e772c2c5 --- /dev/null +++ b/fir-examples/examples/shaders/FIR/Examples/Toy/Shaders.hs @@ -0,0 +1,201 @@ +{-# OPTIONS_GHC -Wno-missing-local-signatures #-} + +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE NamedWildCards #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} + +module FIR.Examples.Toy.Shaders where + +-- base +import Data.Foldable + ( sequence_ ) +import Data.Maybe + ( fromJust ) +import GHC.TypeNats + ( KnownNat ) + +-- filepath +import System.FilePath + ( () ) + +-- text-short +import Data.Text.Short + ( ShortText ) + +-- vector-sized +import qualified Data.Vector.Sized as Vector + ( fromList ) + +-- fir +import FIR +import FIR.Syntax.Labels +import Math.Linear + +-- fir-examples +import FIR.Examples.Paths + ( shaderDir ) + +------------------------------------------------ +-- pipeline input + +type VertexInput + = '[ Slot 0 0 ':-> V 3 Float ] + +------------------------------------- +-- vertex shader + +type VertexDefs = + '[ "in_position" ':-> Input '[ Location 0 ] (V 3 Float) + , "main" ':-> EntryPoint '[ ] Vertex + ] + +vertex :: ShaderModule "main" VertexShader VertexDefs _ +vertex = shader do + ~(Vec3 x y z) <- get @"in_position" + put @"gl_Position" (Vec4 x y z 1) + +------------------------------------------------ +-- fragment shader + +type FragmentDefs = + '[ "out_colour" ':-> Output '[ Location 0 ] (V 4 Float) + , "ubo" ':-> Uniform '[ Binding 0, DescriptorSet 0 ] + ( Struct '[ "mousePos" ':-> V 2 Float ] ) + , "main" ':-> EntryPoint '[ OriginUpperLeft ] 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 + +fragment :: ShaderModule "main" FragmentShader FragmentDefs _ +fragment = shader do + + ~( Vec4 x y _ _ ) <- #gl_FragCoord + ( mkRescaledComplex -> c ) <- use @(Name "ubo" :.: Name "mousePos") + + #mag #= ( 0 :: Code Float ) + + supersamplingLoop \ xNo yNo -> locally do + + let + dx, dy :: Code Float + dx = ( fromIntegral xNo + 0.5 ) * xWidth - 0.5 + dy = ( fromIntegral yNo + 0.5 ) * xWidth - 0.5 + + #z #= codeComplex ( mkRescaledComplex ( Vec2 (x + dx) (y + dy) ) ) + #depth #= ( 0 :: Code Word32 ) + + loop do + ( CodeComplex -> z ) <- #z + depth <- #depth + if magnitude z > 10 || depth > maxDepth + then break @1 + else do + ~(Vec2 zr zi) <- #z + z' <- let' $ zr :+: abs zi + #z .= codeComplex ( complexLog z' + c ) + #depth .= depth + 1 + + ( CodeComplex -> z ) <- #z + #mag %= ( + magnitude z ) + + pure () + + mag <- #mag + let t = log ( mag * xWidth * yWidth ) + / log ( fromIntegral maxDepth ) + + let col = gradient t (Lit sunset) + + #out_colour .= col + +mkRescaledComplex :: Code (V 2 Float) -> CodeComplex Float +mkRescaledComplex (Vec2 x y) = + ( (x - 960) / 250 ) :+: ( (y - 540) / 250 ) + +supersamplingLoop + :: ( Code Word32 -> Code Word32 -> Program _s _s () ) + -> Program _s _s () +supersamplingLoop prog = locally do + #ssX #= 0 + #ssY #= 0 + while ( ( xSamples > ) <<$>> #ssX ) do + ssX <- #ssX + #ssY .= 0 + while ( ( ySamples > ) <<$>> #ssY ) do + ssY <- #ssY + embed $ prog ssX ssY + #ssY %= (+1) + #ssX %= (+1) + pure () + +gradient :: forall n. KnownNat n + => Code Float + -> Code (Array n (V 4 Float)) + -> Code (V 4 Float) +gradient t colors + = ( (1-s) *^ ( view @(AnIndex _) i colors ) ) + ^+^ ( s *^ ( view @(AnIndex _) (i+1) colors ) ) + where n :: Code Float + n = Lit . fromIntegral $ knownValue @n + i :: Code Word32 + i = floor ( (n-1) * t ) + s :: Code Float + s = (n-1) * t - fromIntegral i + + +sunset :: Array 9 (V 4 Float) +sunset = MkArray . fromJust . Vector.fromList $ + [ V4 0 0 0 0 + , V4 0.28 0.1 0.38 1 + , V4 0.58 0.2 0.38 1 + , V4 0.83 0.3 0.22 1 + , V4 0.98 0.45 0.05 1 + , V4 0.99 0.62 0.2 1 + , V4 1 0.78 0.31 1 + , V4 1 0.91 0.6 1 + , V4 1 1 1 1 + ] + +------------------------------------------------ +-- compiling + +vertPath, fragPath :: FilePath +vertPath = shaderDir "toy_vert.spv" +fragPath = shaderDir "toy_frag.spv" + +compileVertexShader :: IO ( Either ShortText ModuleRequirements ) +compileVertexShader = compileTo vertPath [SPIRV $ Version 1 0] vertex + +compileFragmentShader :: IO ( Either ShortText ModuleRequirements ) +compileFragmentShader = compileTo fragPath [SPIRV $ Version 1 0] fragment + +compileAllShaders :: IO () +compileAllShaders = sequence_ + [ compileVertexShader + , compileFragmentShader + ] + +shaderPipeline :: ShaderPipeline FilePath +shaderPipeline + = ShaderPipeline + $ StructInput @VertexInput @(Triangle List) + :>-> (vertex , vertPath) + :>-> (fragment, fragPath) diff --git a/fir-examples/fir-examples.cabal b/fir-examples/fir-examples.cabal index 56ab1ca6..9bd91c25 100644 --- a/fir-examples/fir-examples.cabal +++ b/fir-examples/fir-examples.cabal @@ -508,3 +508,31 @@ executable Texture build-depends: texture-shaders + +----------------------------------- +-- Toy + +library toy-shaders + + import: shaders-common + + exposed-modules: + FIR.Examples.Toy.Shaders + +executable Toy + + import: apps-common + + main-is: + Main.hs + + other-modules: + FIR.Examples.Toy.Application + + hs-source-dirs: + examples/exes/Toy + + build-depends: + toy-shaders, + dear-imgui + >= 1.0.0 && < 1.1 diff --git a/fir-examples/readme.md b/fir-examples/readme.md index 8e8fca20..83731bc2 100644 --- a/fir-examples/readme.md +++ b/fir-examples/readme.md @@ -15,6 +15,7 @@ - [Texture sampling](#texture) - [Ising model](#ising) - [Julia set](#julia) + - [Shader toy](#toy) - [Offscreen rendering](#offscreen) - [Bézier curves](#bezier) @@ -211,6 +212,25 @@ Demonstrates usage of shared local memory in a compute shader, synchronised usin Interactive Julia set rendering, computed within a fragment shader. + +### Shader toy +
+[Application](examples/apps/FIR/Examples/Toy/Application.hs) • [Shaders](examples/shaders/FIR/Examples/Toy/Shaders.hs) +
+ +Shader toy example using Dear ImGui to provide interactive sliders whose values are passed on to the shader. + +__Note:__ this requires a manual installation of the Haskell `dear-imgui` package, +because the `dear-imgui` package is not yet available on Hackage and contains an external submodule which +isn't fetched by `extra-src-repository` in `cabal`. + +To allow `cabal` to use `Dear ImGui`, clone the [Dear ImGui](https://github.com/haskell-game/dear-imgui.hs) +repository manually and then add it to the `cabal.project.local` file in the `fir-examples` subdirectory: + +``` +packages: path/to/your/DearImGui/package +``` + ### Offscreen rendering
-- GitLab From a6d35799d740777725748bbfd4c6ab427ddac63f Mon Sep 17 00:00:00 2001 From: sheaf Date: Sun, 20 Jun 2021 21:27:13 +0200 Subject: [PATCH 2/5] Functional Dear ImGui integration --- .../apps/FIR/Examples/Bezier/Application.hs | 3 +- .../FIR/Examples/FullPipeline/Application.hs | 2 +- .../apps/FIR/Examples/Hopf/Application.hs | 3 +- .../apps/FIR/Examples/Ising/Application.hs | 2 +- .../apps/FIR/Examples/JuliaSet/Application.hs | 3 +- .../apps/FIR/Examples/Kerr/Application.hs | 4 +- .../apps/FIR/Examples/Logo/Application.hs | 3 +- .../FIR/Examples/Offscreen/Application.hs | 3 +- .../FIR/Examples/RayTracing/Application.hs | 3 +- .../apps/FIR/Examples/Texture/Application.hs | 3 +- .../apps/FIR/Examples/Toy/Application.hs | 156 ++++++++++++++++-- fir-examples/src/FIR/Examples/Common.hs | 1 + fir-examples/src/Vulkan/Attachment.hs | 18 +- fir-examples/src/Vulkan/Backend.hs | 27 ++- fir-examples/src/Vulkan/Context.hs | 9 +- fir-examples/src/Vulkan/Resource.hs | 26 +-- 16 files changed, 219 insertions(+), 47 deletions(-) diff --git a/fir-examples/examples/apps/FIR/Examples/Bezier/Application.hs b/fir-examples/examples/apps/FIR/Examples/Bezier/Application.hs index d736c26a..b9d0c7f1 100644 --- a/fir-examples/examples/apps/FIR/Examples/Bezier/Application.hs +++ b/fir-examples/examples/apps/FIR/Examples/Bezier/Application.hs @@ -328,8 +328,7 @@ bezier = runVulkan bezierInitialState do ------------------------------------------- -- Create command buffers and record commands into them. - commandPool <- logDebug "Creating command pool" *> ( snd <$> createCommandPool device queueFamilyIndex ) - queue <- getQueue device 0 + commandPool <- logDebug "Creating command pool" *> createCommandPool device Vulkan.zero ( fromIntegral queueFamilyIndex ) (_, nextImageSem ) <- createSemaphore device (_, submitted ) <- createSemaphore device diff --git a/fir-examples/examples/apps/FIR/Examples/FullPipeline/Application.hs b/fir-examples/examples/apps/FIR/Examples/FullPipeline/Application.hs index b4f2022c..d960eaee 100644 --- a/fir-examples/examples/apps/FIR/Examples/FullPipeline/Application.hs +++ b/fir-examples/examples/apps/FIR/Examples/FullPipeline/Application.hs @@ -334,7 +334,7 @@ fullPipeline = runVulkan initialState do ------------------------------------------- -- Create command buffers and record commands into them. - commandPool <- logDebug "Creating command pool" *> ( snd <$> createCommandPool device queueFamilyIndex ) + commandPool <- logDebug "Creating command pool" *> createCommandPool device Vulkan.zero ( fromIntegral queueFamilyIndex ) queue <- getQueue device 0 (_, nextImageSem ) <- createSemaphore device diff --git a/fir-examples/examples/apps/FIR/Examples/Hopf/Application.hs b/fir-examples/examples/apps/FIR/Examples/Hopf/Application.hs index 776ecfa3..43449caf 100644 --- a/fir-examples/examples/apps/FIR/Examples/Hopf/Application.hs +++ b/fir-examples/examples/apps/FIR/Examples/Hopf/Application.hs @@ -323,8 +323,7 @@ hopf = runVulkan initialState do ------------------------------------------- -- Create command buffers and record commands into them. - commandPool <- logDebug "Creating command pool" *> ( snd <$> createCommandPool device queueFamilyIndex ) - queue <- getQueue device 0 + commandPool <- logDebug "Creating command pool" *> createCommandPool device Vulkan.zero ( fromIntegral queueFamilyIndex ) (_, nextImageSem ) <- createSemaphore device (_, submitted ) <- createSemaphore device diff --git a/fir-examples/examples/apps/FIR/Examples/Ising/Application.hs b/fir-examples/examples/apps/FIR/Examples/Ising/Application.hs index 029cfa14..bae52049 100644 --- a/fir-examples/examples/apps/FIR/Examples/Ising/Application.hs +++ b/fir-examples/examples/apps/FIR/Examples/Ising/Application.hs @@ -178,7 +178,7 @@ ising = runVulkan initialState do withSwapchainInfo aSwapchainInfo \ ( swapchainInfo@(SwapchainInfo {..}) :: SwapchainInfo numImages ) -> do - commandPool <- logDebug "Creating command pool" *> ( snd <$> createCommandPool device queueFamilyIndex ) + commandPool <- logDebug "Creating command pool" *> createCommandPool device Vulkan.zero ( fromIntegral queueFamilyIndex ) queue <- getQueue device 0 ------------------------------------------- diff --git a/fir-examples/examples/apps/FIR/Examples/JuliaSet/Application.hs b/fir-examples/examples/apps/FIR/Examples/JuliaSet/Application.hs index 7702c6cf..c792af5a 100644 --- a/fir-examples/examples/apps/FIR/Examples/JuliaSet/Application.hs +++ b/fir-examples/examples/apps/FIR/Examples/JuliaSet/Application.hs @@ -63,6 +63,7 @@ import qualified Data.Vector.Sized as V -- vulkan import qualified Vulkan +import qualified Vulkan.Zero as Vulkan -- fir import FIR @@ -259,7 +260,7 @@ juliaSet = runVulkan initialState do ------------------------------------------- -- Create command buffers and record commands into them. - commandPool <- logDebug "Creating command pool" *> ( snd <$> createCommandPool device queueFamilyIndex ) + commandPool <- logDebug "Creating command pool" *> createCommandPool device Vulkan.zero ( fromIntegral queueFamilyIndex ) queue <- getQueue device 0 (_, nextImageSem ) <- createSemaphore device diff --git a/fir-examples/examples/apps/FIR/Examples/Kerr/Application.hs b/fir-examples/examples/apps/FIR/Examples/Kerr/Application.hs index 423a7d1f..a5167662 100644 --- a/fir-examples/examples/apps/FIR/Examples/Kerr/Application.hs +++ b/fir-examples/examples/apps/FIR/Examples/Kerr/Application.hs @@ -64,6 +64,7 @@ import qualified Data.Vector.Sized as V -- vulkan import qualified Vulkan +import qualified Vulkan.Zero as Vulkan -- fir import FIR @@ -281,8 +282,7 @@ kerr = runVulkan initialStateKerr do ------------------------------------------- -- Create command buffers and record commands into them. - commandPool <- logDebug "Creating command pool" *> ( snd <$> createCommandPool device queueFamilyIndex ) - queue <- getQueue device 0 + commandPool <- logDebug "Creating command pool" *> createCommandPool device Vulkan.zero ( fromIntegral queueFamilyIndex ) (_, nextImageSem ) <- createSemaphore device (_, submitted ) <- createSemaphore device diff --git a/fir-examples/examples/apps/FIR/Examples/Logo/Application.hs b/fir-examples/examples/apps/FIR/Examples/Logo/Application.hs index 6b2adf16..56fa9781 100644 --- a/fir-examples/examples/apps/FIR/Examples/Logo/Application.hs +++ b/fir-examples/examples/apps/FIR/Examples/Logo/Application.hs @@ -63,6 +63,7 @@ import qualified Data.Vector.Sized as V -- vulkan import qualified Vulkan +import qualified Vulkan.Zero as Vulkan -- fir import FIR @@ -253,7 +254,7 @@ logo = runVulkan initialStateLogo do ------------------------------------------- -- Create a command buffer and record the commands into it. - commandPool <- logDebug "Creating command pool" *> ( snd <$> createCommandPool device queueFamilyIndex ) + commandPool <- logDebug "Creating command pool" *> createCommandPool device Vulkan.zero ( fromIntegral queueFamilyIndex ) queue <- getQueue device 0 (_, nextImageSem ) <- createSemaphore device diff --git a/fir-examples/examples/apps/FIR/Examples/Offscreen/Application.hs b/fir-examples/examples/apps/FIR/Examples/Offscreen/Application.hs index 4f4a32ea..9945f220 100644 --- a/fir-examples/examples/apps/FIR/Examples/Offscreen/Application.hs +++ b/fir-examples/examples/apps/FIR/Examples/Offscreen/Application.hs @@ -289,8 +289,7 @@ offscreen = runVulkan () do -- Create command buffers and record commands into them. - commandPool <- logDebug "Creating command pool" *> ( snd <$> createCommandPool device queueFamilyIndex ) - queue <- getQueue device 0 + commandPool <- logDebug "Creating command pool" *> createCommandPool device Vulkan.zero ( fromIntegral queueFamilyIndex ) pipelineLayout <- logDebug "Creating pipeline layout" *> createPipelineLayout device [descriptorSetLayout] let pipelineInfo = VkPipelineInfo extent Vulkan.SAMPLE_COUNT_1_BIT pipelineLayout diff --git a/fir-examples/examples/apps/FIR/Examples/RayTracing/Application.hs b/fir-examples/examples/apps/FIR/Examples/RayTracing/Application.hs index e770897a..dc6d80b1 100644 --- a/fir-examples/examples/apps/FIR/Examples/RayTracing/Application.hs +++ b/fir-examples/examples/apps/FIR/Examples/RayTracing/Application.hs @@ -349,8 +349,7 @@ rayTracing = runVulkan ( initialState, CameraIsLocked False ) do withSwapchainInfo aSwapchainInfo \ ( swapchainInfo@(SwapchainInfo {..}) :: SwapchainInfo numImages ) -> do - commandPool <- logDebug "Creating command pool" *> ( snd <$> createCommandPool device queueFamilyIndex ) - queue <- getQueue device 0 + commandPool <- logDebug "Creating command pool" *> createCommandPool device Vulkan.zero ( fromIntegral queueFamilyIndex ) ( topLevelAS , SceneData diff --git a/fir-examples/examples/apps/FIR/Examples/Texture/Application.hs b/fir-examples/examples/apps/FIR/Examples/Texture/Application.hs index 389d83a6..1034e654 100644 --- a/fir-examples/examples/apps/FIR/Examples/Texture/Application.hs +++ b/fir-examples/examples/apps/FIR/Examples/Texture/Application.hs @@ -328,8 +328,7 @@ texture = runVulkan initialState do logoSampler <- createSampler device - commandPool <- logDebug "Creating command pool" *> ( snd <$> createCommandPool device queueFamilyIndex ) - queue <- getQueue device 0 + commandPool <- logDebug "Creating command pool" *> createCommandPool device Vulkan.zero ( fromIntegral queueFamilyIndex ) ( _copyCommandBufferKey, logoCopyCommandBuffer ) <- allocateCommandBuffer device commandPool diff --git a/fir-examples/examples/apps/FIR/Examples/Toy/Application.hs b/fir-examples/examples/apps/FIR/Examples/Toy/Application.hs index 419a892a..3951e484 100644 --- a/fir-examples/examples/apps/FIR/Examples/Toy/Application.hs +++ b/fir-examples/examples/apps/FIR/Examples/Toy/Application.hs @@ -5,6 +5,7 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} @@ -19,8 +20,12 @@ module FIR.Examples.Toy.Application ( toy ) where -- base +import Control.Exception + ( throw ) import Control.Monad ( when, void ) +import Data.Foldable + ( traverse_ ) import Data.String ( IsString ) import Data.Traversable @@ -30,6 +35,14 @@ import Data.Word import GHC.Generics ( Generic ) +-- dear-imgui +import qualified DearImGui as ImGui +import qualified DearImGui.Vulkan as ImGui.Vulkan +import DearImGui.Vulkan + ( InitInfo(..) ) +import qualified DearImGui.SDL as ImGui.SDL +import qualified DearImGui.SDL.Vulkan as ImGui.SDL.Vulkan + -- lens import Control.Lens ( use, assign ) @@ -38,9 +51,11 @@ import Control.Lens import Control.Monad.Log ( logDebug, logInfo ) +-- resourcet +import qualified Control.Monad.Trans.Resource as ResourceT + -- sdl2 import qualified SDL -import qualified SDL.Event import qualified SDL.Raw.Event as SDL -- text-short @@ -55,7 +70,7 @@ import Control.Monad.IO.Class -- vector import qualified Data.Vector as Boxed.Vector - ( singleton ) + ( (!), singleton ) -- vector-sized import qualified Data.Vector.Sized as V @@ -63,6 +78,8 @@ import qualified Data.Vector.Sized as V -- vulkan import qualified Vulkan +import qualified Vulkan.Exception as Vulkan +import qualified Vulkan.Zero as Vulkan -- fir import FIR @@ -139,11 +156,15 @@ initialResourceSet = ResourceSet ( BufferData viewportVertices ) ( BufferData viewportIndices ) -clearValue :: Vulkan.ClearValue -clearValue = Vulkan.Color black +clearValue1, clearValue2 :: Vulkan.ClearValue +clearValue1 = Vulkan.Color black where black :: Vulkan.ClearColorValue black = Vulkan.Float32 0 0 0 0 +clearValue2 = Vulkan.Color yellow + where + yellow :: Vulkan.ClearColorValue + yellow = Vulkan.Float32 1 1 0 1 ---------------------------------------------------------------------------- -- Application. @@ -194,6 +215,26 @@ toy = runVulkan initialState do , surfaceInfo = surfaceInfo } + _ <- ResourceT.allocate ImGui.createContext ImGui.destroyContext + + let + imGuiDescriptorTypes :: [ ( Vulkan.DescriptorType, Int ) ] + imGuiDescriptorTypes = map (, 1000) + [ Vulkan.DESCRIPTOR_TYPE_SAMPLER + , Vulkan.DESCRIPTOR_TYPE_COMBINED_IMAGE_SAMPLER + , Vulkan.DESCRIPTOR_TYPE_SAMPLED_IMAGE + , Vulkan.DESCRIPTOR_TYPE_STORAGE_IMAGE + , Vulkan.DESCRIPTOR_TYPE_UNIFORM_TEXEL_BUFFER + , Vulkan.DESCRIPTOR_TYPE_STORAGE_TEXEL_BUFFER + , Vulkan.DESCRIPTOR_TYPE_UNIFORM_BUFFER + , Vulkan.DESCRIPTOR_TYPE_STORAGE_BUFFER + , Vulkan.DESCRIPTOR_TYPE_UNIFORM_BUFFER_DYNAMIC + , Vulkan.DESCRIPTOR_TYPE_STORAGE_BUFFER_DYNAMIC + , Vulkan.DESCRIPTOR_TYPE_INPUT_ATTACHMENT + ] + imGuiCommandPool <- createCommandPool device Vulkan.COMMAND_POOL_CREATE_RESET_COMMAND_BUFFER_BIT ( fromIntegral queueFamilyIndex ) + ( _imGuiPoolKey, imGuiDescriptorPool ) <- createDescriptorPool device 1000 imGuiDescriptorTypes + withSwapchainInfo aSwapchainInfo \ ( swapchainInfo@(SwapchainInfo {..}) :: SwapchainInfo numImages ) -> do ------------------------------------------- @@ -221,6 +262,12 @@ toy = runVulkan initialState do { colorAttachments = Boxed.Vector.singleton $ presentableColorAttachmentDescription colFmt } ) + imGuiRenderPass <- + simpleRenderPass device + ( noAttachments + { colorAttachments = Boxed.Vector.singleton $ preservedColorAttachmentDescription colFmt } + ) + framebuffersWithAttachments <- logDebug "Creating frame buffers" *> ( for swapchainImages $ \swapchainImage -> do @@ -241,6 +288,62 @@ toy = runVulkan initialState do createScreenshotImage physicalDevice device ( screenshotImageInfo extent3D colFmt ) + ------------------------------------------- + -- Initialise Dear ImGui + + let + imageCount :: Word32 + imageCount = fromIntegral $ length swapchainImages + initInfo :: ImGui.Vulkan.InitInfo + initInfo = ImGui.Vulkan.InitInfo + { instance' = vkInstance + , physicalDevice + , device + , queueFamily = fromIntegral queueFamilyIndex + , queue + , pipelineCache = Vulkan.NULL_HANDLE + , descriptorPool = imGuiDescriptorPool + , subpass = 0 + , minImageCount = max 1 (imageCount - 1) + , imageCount = imageCount + , msaaSamples = Vulkan.SAMPLE_COUNT_1_BIT + , mbAllocator = Nothing + , checkResult = \case { Vulkan.SUCCESS -> pure (); e -> throw $ Vulkan.VulkanException e } + } + + logDebug "Allocating Dear ImGui command buffers" + imGuiCommandBuffers <- snd <$> allocatePrimaryCommandBuffers device imGuiCommandPool imageCount + + logDebug "Initialising ImGui SDL2 for Vulkan" + _ <- ResourceT.allocate + ( ImGui.SDL.Vulkan.sdl2InitForVulkan window ) + ( const ImGui.SDL.sdl2Shutdown ) + + _ <- ResourceT.allocate + ( ImGui.Vulkan.vulkanInit initInfo imGuiRenderPass ) + ( ImGui.Vulkan.vulkanShutdown ) + + logDebug "Running one-shot commands to upload ImGui textures" + logDebug "Creating fence" + ( fenceKey, fence ) <- createFence device + logDebug "Allocating one-shot command buffer" + ( fontUploadCommandBufferKey, fontUploadCommandBuffer ) <- + allocateCommandBuffer device imGuiCommandPool + + logDebug "Recording one-shot commands" + beginCommandBuffer fontUploadCommandBuffer + _ <- ImGui.Vulkan.vulkanCreateFontsTexture fontUploadCommandBuffer + endCommandBuffer fontUploadCommandBuffer + + logDebug "Submitting one-shot commands" + submitCommandBuffer queue fontUploadCommandBuffer [] [] ( Just fence ) + waitForFences device ( WaitAll [ fence ] ) + + logDebug "Finished uploading font objects" + logDebug "Cleaning up one-shot commands" + ImGui.Vulkan.vulkanDestroyFontUploadObjects + traverse_ ResourceT.release [ fenceKey, fontUploadCommandBufferKey ] + ------------------------------------------- -- Manage resources. @@ -259,8 +362,7 @@ toy = runVulkan initialState do ------------------------------------------- -- Create command buffers and record commands into them. - commandPool <- logDebug "Creating command pool" *> ( snd <$> createCommandPool device queueFamilyIndex ) - queue <- getQueue device 0 + commandPool <- logDebug "Creating command pool" *> createCommandPool device Vulkan.zero ( fromIntegral queueFamilyIndex ) (_, nextImageSem ) <- createSemaphore device (_, submitted ) <- createSemaphore device @@ -274,7 +376,7 @@ toy = runVulkan initialState do recordCommandBuffers pipe = for (V.zip descriptorSets framebuffersWithAttachments) $ \ ( descriptorSet, (framebuffer, attachment ) ) -> recordSimpleIndexedDrawCall - device commandPool framebuffer (renderPass, [clearValue]) + device commandPool framebuffer (renderPass, [clearValue1]) descriptorSet cmdBindBuffers ( fst attachment, swapchainExtent ) Nothing @@ -284,7 +386,7 @@ toy = runVulkan initialState do for (V.zip3 descriptorSets framebuffersWithAttachments screenshotImagesAndMemories) \ ( descriptorSet, (framebuffer, attachment), (screenshotImage, _) ) -> recordSimpleIndexedDrawCall - device commandPool framebuffer (renderPass, [clearValue]) + device commandPool framebuffer (renderPass, [clearValue1]) descriptorSet cmdBindBuffers ( fst attachment, swapchainExtent ) ( Just ( screenshotImage, extent3D ) ) @@ -310,7 +412,7 @@ toy = runVulkan initialState do ---------------- -- input - inputEvents <- map SDL.Event.eventPayload <$> SDL.pollEvents + inputEvents <- map SDL.eventPayload <$> pollEventsWithImGui prevInput <- use _input let prevAction = interpretInput 1 prevInput @@ -348,6 +450,18 @@ toy = runVulkan initialState do nextImageIndex <- acquireNextImage device swapchainInfo nextImageSem + ImGui.Vulkan.vulkanNewFrame + ImGui.SDL.sdl2NewFrame window + ImGui.newFrame + ImGui.showDemoWindow + ImGui.render + drawData <- ImGui.getDrawData + let + imGuiCommandBuffer :: Vulkan.CommandBuffer + imGuiCommandBuffer = imGuiCommandBuffers Boxed.Vector.! fromIntegral nextImageIndex + framebuffer :: Vulkan.Framebuffer + framebuffer = fst $ framebuffersWithAttachments `V.index` nextImageIndex + let commandBuffer | takeScreenshot action = updatedScreenshotCommands `V.index` nextImageIndex @@ -356,8 +470,20 @@ toy = runVulkan initialState do submitCommandBuffer queue commandBuffer - [(nextImageSem, Vulkan.PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT)] - [submitted] + [] + [] + Nothing + + beginCommandBuffer imGuiCommandBuffer + cmdBeginRenderPass imGuiCommandBuffer imGuiRenderPass framebuffer [clearValue2] swapchainExtent + ImGui.Vulkan.vulkanRenderDrawData drawData imGuiCommandBuffer Nothing + cmdEndRenderPass imGuiCommandBuffer + endCommandBuffer imGuiCommandBuffer + submitCommandBuffer + queue + imGuiCommandBuffer + [ ( nextImageSem, Vulkan.PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT ) ] + [ submitted ] Nothing present queue swapchain nextImageIndex [submitted] @@ -371,3 +497,11 @@ toy = runVulkan initialState do ---------------- pure ( shouldQuit action ) + + +pollEventsWithImGui :: MonadVulkan m => m [ SDL.Event ] +pollEventsWithImGui = do + e <- ImGui.SDL.pollEventWithImGui + case e of + Nothing -> pure [] + Just e' -> ( e' : ) <$> pollEventsWithImGui diff --git a/fir-examples/src/FIR/Examples/Common.hs b/fir-examples/src/FIR/Examples/Common.hs index 1c9033dd..c93bcf11 100644 --- a/fir-examples/src/FIR/Examples/Common.hs +++ b/fir-examples/src/FIR/Examples/Common.hs @@ -2,6 +2,7 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} module FIR.Examples.Common where diff --git a/fir-examples/src/Vulkan/Attachment.hs b/fir-examples/src/Vulkan/Attachment.hs index a3403357..3af582e0 100644 --- a/fir-examples/src/Vulkan/Attachment.hs +++ b/fir-examples/src/Vulkan/Attachment.hs @@ -133,7 +133,23 @@ presentableColorAttachmentDescription colorFormat = , initialLayout = Vulkan.IMAGE_LAYOUT_UNDEFINED , finalLayout = Vulkan.IMAGE_LAYOUT_PRESENT_SRC_KHR } - + +preservedColorAttachmentDescription :: Vulkan.Format -> ( Vulkan.AttachmentDescription, AttachmentType ) +preservedColorAttachmentDescription colorFormat = + ( description, ColorAttachment ) + where + description = + Vulkan.AttachmentDescription + { flags = Vulkan.zero + , format = colorFormat + , samples = Vulkan.SAMPLE_COUNT_1_BIT + , loadOp = Vulkan.ATTACHMENT_LOAD_OP_LOAD + , storeOp = Vulkan.ATTACHMENT_STORE_OP_STORE + , stencilLoadOp = Vulkan.ATTACHMENT_LOAD_OP_DONT_CARE + , stencilStoreOp = Vulkan.ATTACHMENT_STORE_OP_DONT_CARE + , initialLayout = Vulkan.IMAGE_LAYOUT_UNDEFINED + , finalLayout = Vulkan.IMAGE_LAYOUT_PRESENT_SRC_KHR + } depthAttachmentDescription :: Vulkan.Format -> ( Vulkan.AttachmentDescription, AttachmentType ) depthAttachmentDescription depthFormat = diff --git a/fir-examples/src/Vulkan/Backend.hs b/fir-examples/src/Vulkan/Backend.hs index afa0590c..1ec1b52b 100644 --- a/fir-examples/src/Vulkan/Backend.hs +++ b/fir-examples/src/Vulkan/Backend.hs @@ -492,15 +492,16 @@ createSampler dev = snd <$> Vulkan.withSampler dev createInfo Nothing allocate createCommandPool :: MonadVulkan m => Vulkan.Device - -> Int - -> m ( ReleaseKey, Vulkan.CommandPool ) -createCommandPool dev queueFamilyIndex = Vulkan.withCommandPool dev createInfo Nothing allocate + -> Vulkan.CommandPoolCreateFlagBits + -> Word32 + -> m Vulkan.CommandPool +createCommandPool dev flags queueFamilyIndex = snd <$> Vulkan.withCommandPool dev createInfo Nothing allocate where createInfo :: Vulkan.CommandPoolCreateInfo createInfo = Vulkan.CommandPoolCreateInfo - { Vulkan.flags = Vulkan.zero - , Vulkan.queueFamilyIndex = fromIntegral queueFamilyIndex + { Vulkan.flags = flags + , Vulkan.queueFamilyIndex = queueFamilyIndex } @@ -519,6 +520,22 @@ allocateCommandBuffer dev commandPool = second Boxed.Vector.head <$> Vulkan.with , Vulkan.commandBufferCount = 1 } +allocatePrimaryCommandBuffers + :: MonadVulkan m + => Vulkan.Device + -> Vulkan.CommandPool + -> Word32 + -> m ( ReleaseKey, Boxed.Vector Vulkan.CommandBuffer ) +allocatePrimaryCommandBuffers dev commandPool count = Vulkan.withCommandBuffers dev allocInfo allocate + where + allocInfo :: Vulkan.CommandBufferAllocateInfo + allocInfo = + Vulkan.CommandBufferAllocateInfo + { Vulkan.commandPool = commandPool + , Vulkan.level = Vulkan.COMMAND_BUFFER_LEVEL_PRIMARY + , Vulkan.commandBufferCount = count + } + cmdBeginRenderPass :: MonadIO m diff --git a/fir-examples/src/Vulkan/Context.hs b/fir-examples/src/Vulkan/Context.hs index cafa0026..6fef56cc 100644 --- a/fir-examples/src/Vulkan/Context.hs +++ b/fir-examples/src/Vulkan/Context.hs @@ -20,10 +20,10 @@ import Data.Bits ( (.|.) ) import Data.Foldable ( toList ) -import Data.Maybe - ( fromMaybe, mapMaybe ) import Data.Kind ( Type ) +import Data.Maybe + ( fromMaybe, mapMaybe ) import Foreign.C.String ( CString ) import Foreign.C.Types @@ -199,9 +199,11 @@ data instance ContextSwapchainInfo WithSwapchain where data VulkanContext ( ctx :: RenderingContext ) = VulkanContext - { physicalDevice :: Vulkan.PhysicalDevice + { vkInstance :: Vulkan.Instance + , physicalDevice :: Vulkan.PhysicalDevice , device :: Vulkan.Device , queueFamilyIndex :: Int + , queue :: Vulkan.Queue , aSwapchainInfo :: ContextSwapchainInfo ctx } @@ -273,4 +275,5 @@ initialiseContext instanceType appName ( VulkanRequirements { instanceRequiremen V.withSized swapchainImageVec \ swapchainImages -> do let swapchainInfo = SwapchainInfo {..} pure ( device, ASwapchainInfo swapchainInfo ) + queue <- Vulkan.getDeviceQueue device ( fromIntegral queueFamilyIndex ) 0 pure ( VulkanContext {..} ) diff --git a/fir-examples/src/Vulkan/Resource.hs b/fir-examples/src/Vulkan/Resource.hs index cf03593e..b3abdb4d 100644 --- a/fir-examples/src/Vulkan/Resource.hs +++ b/fir-examples/src/Vulkan/Resource.hs @@ -34,9 +34,13 @@ module Vulkan.Resource , SampledImage, SampledImages , TopLevelAS, TopLevelASes , initialiseResources + + , createDescriptorPool ) where -- base +import Control.Arrow + ( first ) import Data.Bits ( (.|.) ) import Data.Coerce @@ -80,7 +84,7 @@ import Control.Monad.Log -- resourcet import Control.Monad.Trans.Resource - ( allocate ) + ( ResourceT, ReleaseKey, allocate ) -- text-short import Data.Text.Short @@ -251,8 +255,8 @@ initialiseResources physicalDevice device resourceFlags resourcesPre = do resourceFlags [] - descriptorTypes :: [ Vulkan.DescriptorType ] - descriptorTypes = map fst descriptorTypesAndFlags + descriptorTypes :: [ ( Vulkan.DescriptorType, Int ) ] + descriptorTypes = map ( \ ( ty, _ ) -> ( ty, 1 ) ) descriptorTypesAndFlags n :: Int n = fromIntegral ( natVal' @n proxy# ) nb :: ShortText @@ -260,13 +264,13 @@ initialiseResources physicalDevice device resourceFlags resourcesPre = do descriptorPool <- logDebug ( "Creating descriptor pool for " <> nb <> " sets of descriptors, each with types:\n" <> ShortText.pack ( show descriptorTypes ) ) - *> createDescriptorPool device n descriptorTypes + *> ( snd <$> createDescriptorPool device n descriptorTypes ) descriptorSetLayout <- logDebug "Creating descriptor set layout" *> createDescriptorSetLayout device descriptorTypesAndFlags descriptorSets <- logDebug ( "Allocating " <> nb <> " descriptor sets" ) - *> allocateDescriptorSets @n device descriptorPool descriptorSetLayout + *> allocateDescriptorSets @n device descriptorPool descriptorSetLayout ( resourcesPost :: resources n Post ) <- logDebug "Initialising resources" *> @@ -339,9 +343,9 @@ createDescriptorPool :: MonadVulkan m => Vulkan.Device -> Int - -> [ Vulkan.DescriptorType ] - -> m Vulkan.DescriptorPool -createDescriptorPool device maxSets descTypes = snd <$> Vulkan.withDescriptorPool device createInfo Nothing allocate + -> [ ( Vulkan.DescriptorType, Int ) ] + -> m ( ReleaseKey, Vulkan.DescriptorPool ) +createDescriptorPool device maxSets descTypes = Vulkan.withDescriptorPool device createInfo Nothing allocate where poolSizes :: [ Vulkan.DescriptorPoolSize ] @@ -349,7 +353,7 @@ createDescriptorPool device maxSets descTypes = snd <$> Vulkan.withDescriptorPoo counts descTypes <&> \ ( descType, descCount ) -> Vulkan.DescriptorPoolSize { Vulkan.type' = descType - , Vulkan.descriptorCount = fromIntegral maxSets * descCount + , Vulkan.descriptorCount = fromIntegral $ maxSets * descCount } createInfo :: Vulkan.DescriptorPoolCreateInfo '[] createInfo = @@ -379,8 +383,8 @@ allocateDescriptorSets dev descriptorPool layout0 = Boxed.Vector.toList . snd <$ , Vulkan.setLayouts = Boxed.Vector.replicate count layout0 } -counts :: (Ord a, Num i) => [ a ] -> [ (a, i) ] -counts = Map.toList . foldr ( \ a -> Map.insertWith (+) a 1 ) Map.empty +counts :: ( Ord a, Num i ) => [ ( a, i ) ] -> [ ( a, i ) ] +counts = Map.toList . foldr ( uncurry $ Map.insertWith (+) ) Map.empty updateDescriptorSets -- GitLab From 6be9bb4eda6d90f841c088adfe6a45259901a9d9 Mon Sep 17 00:00:00 2001 From: sheaf Date: Sun, 20 Jun 2021 21:32:05 +0200 Subject: [PATCH 3/5] ignore imgui.ini --- .gitignore | 1 + 1 file changed, 1 insertion(+) diff --git a/.gitignore b/.gitignore index 717d6c85..d5f45540 100644 --- a/.gitignore +++ b/.gitignore @@ -11,3 +11,4 @@ docs/ *.spv-asm *.glsl *.yaml +*.ini -- GitLab From e2b5fc0f746ac9b1af1c5ef51e69e057e7218130 Mon Sep 17 00:00:00 2001 From: sheaf Date: Sun, 20 Jun 2021 22:20:35 +0200 Subject: [PATCH 4/5] Stub user data in shader toy example --- .../apps/FIR/Examples/Toy/Application.hs | 20 ++++++++------- .../shaders/FIR/Examples/Toy/Shaders.hs | 25 ++++++++++++++++--- 2 files changed, 33 insertions(+), 12 deletions(-) diff --git a/fir-examples/examples/apps/FIR/Examples/Toy/Application.hs b/fir-examples/examples/apps/FIR/Examples/Toy/Application.hs index 3951e484..9c63c025 100644 --- a/fir-examples/examples/apps/FIR/Examples/Toy/Application.hs +++ b/fir-examples/examples/apps/FIR/Examples/Toy/Application.hs @@ -88,8 +88,7 @@ import FIR , ModuleRequirements(..) ) import Math.Linear - ( V - , pattern V2, pattern V3 + ( pattern V2, pattern V3 , (^+^), (*^) ) @@ -127,9 +126,9 @@ type VertexData = Struct VertexInput data ResourceSet i st = ResourceSet - { mousePosUBO :: UniformBuffer (V 2 Float) i st - , vertexBuffer :: VertexBuffer VertexData i st - , indexBuffer :: IndexBuffer Word32 i st + { inputDataUBO :: UniformBuffer InputData i st + , vertexBuffer :: VertexBuffer VertexData i st + , indexBuffer :: IndexBuffer Word32 i st } deriving Generic @@ -152,7 +151,7 @@ nbIndices = 6 initialResourceSet :: ResourceSet numImages Pre initialResourceSet = ResourceSet - ( BufferData ( V2 0 0 ) ) + ( BufferData zeroInputData ) ( BufferData viewportVertices ) ( BufferData viewportIndices ) @@ -440,10 +439,13 @@ toy = runVulkan initialState do -- update UBO let - BufferResource _ updateMousePos = mousePosUBO resources - - liftIO ( updateMousePos pos ) + BufferResource _ updateInputData = inputDataUBO resources + + currentInput :: InputData + currentInput = pos :& 0 :& 0 :& 0 :& 0 :& Prelude.pure 0 :& End + + liftIO ( updateInputData currentInput ) ---------------- -- rendering diff --git a/fir-examples/examples/shaders/FIR/Examples/Toy/Shaders.hs b/fir-examples/examples/shaders/FIR/Examples/Toy/Shaders.hs index e772c2c5..0fabbb39 100644 --- a/fir-examples/examples/shaders/FIR/Examples/Toy/Shaders.hs +++ b/fir-examples/examples/shaders/FIR/Examples/Toy/Shaders.hs @@ -22,6 +22,7 @@ import Data.Maybe ( fromJust ) import GHC.TypeNats ( KnownNat ) +import qualified Prelude -- filepath import System.FilePath @@ -44,6 +45,22 @@ import Math.Linear import FIR.Examples.Paths ( shaderDir ) +------------------------------------------------ +-- user data + +type InputData = + Struct + '[ "mousePos" ':-> V 2 Float + , "slider1" ':-> Float + , "slider2" ':-> Float + , "button1" ':-> Int32 + , "button2" ':-> Int32 + , "scancodes" ':-> Array 512 Word32 + ] + +zeroInputData :: InputData +zeroInputData = V2 0 0 :& 0 :& 0 :& 0 :& 0 :& Prelude.pure 0 :& End + ------------------------------------------------ -- pipeline input @@ -67,10 +84,12 @@ vertex = shader do -- fragment shader type FragmentDefs = - '[ "out_colour" ':-> Output '[ Location 0 ] (V 4 Float) + '[ "out_colour" ':-> Output '[ Location 0 ] + ( V 4 Float ) , "ubo" ':-> Uniform '[ Binding 0, DescriptorSet 0 ] - ( Struct '[ "mousePos" ':-> V 2 Float ] ) - , "main" ':-> EntryPoint '[ OriginUpperLeft ] Fragment + InputData + , "main" ':-> EntryPoint '[ OriginUpperLeft ] + Fragment ] maxDepth :: Code Word32 -- GitLab From 0ddd3f2924a44ecd76fcf0d8e865b59dbc941a1d Mon Sep 17 00:00:00 2001 From: sheaf Date: Mon, 21 Jun 2021 02:54:03 +0200 Subject: [PATCH 5/5] Add controllers to Toy example --- .../apps/FIR/Examples/Toy/Application.hs | 33 ++-- .../shaders/FIR/Examples/Toy/Shaders.hs | 179 +++++++++++------- fir-examples/fir-examples.cabal | 23 ++- fir-examples/src/FIR/Examples/DearImGui.hs | 119 ++++++++++++ 4 files changed, 276 insertions(+), 78 deletions(-) create mode 100644 fir-examples/src/FIR/Examples/DearImGui.hs diff --git a/fir-examples/examples/apps/FIR/Examples/Toy/Application.hs b/fir-examples/examples/apps/FIR/Examples/Toy/Application.hs index 9c63c025..62566742 100644 --- a/fir-examples/examples/apps/FIR/Examples/Toy/Application.hs +++ b/fir-examples/examples/apps/FIR/Examples/Toy/Application.hs @@ -106,6 +106,12 @@ import Vulkan.Pipeline import Vulkan.Resource import Vulkan.Screenshot +-- fir-examples-dear-imgui +import FIR.Examples.DearImGui + ( ControllerRef(Value) + , createControllers, createControllerRefs, readControllers + ) + ---------------------------------------------------------------------------- -- Shaders and resources. @@ -126,9 +132,9 @@ type VertexData = Struct VertexInput data ResourceSet i st = ResourceSet - { inputDataUBO :: UniformBuffer InputData i st - , vertexBuffer :: VertexBuffer VertexData i st - , indexBuffer :: IndexBuffer Word32 i st + { inputDataUBO :: UniformBuffer ( InputData Value ) i st + , vertexBuffer :: VertexBuffer VertexData i st + , indexBuffer :: IndexBuffer Word32 i st } deriving Generic @@ -151,9 +157,9 @@ nbIndices = 6 initialResourceSet :: ResourceSet numImages Pre initialResourceSet = ResourceSet - ( BufferData zeroInputData ) - ( BufferData viewportVertices ) - ( BufferData viewportIndices ) + ( BufferData initInputData ) + ( BufferData viewportVertices ) + ( BufferData viewportIndices ) clearValue1, clearValue2 :: Vulkan.ClearValue clearValue1 = Vulkan.Color black @@ -354,6 +360,8 @@ toy = runVulkan initialState do GeneralResource GeneralResource + imGuiControllerRefs <- liftIO $ createControllerRefs initImGuiData + PostInitialisationResult descriptorSetLayout descriptorSets cmdBindBuffers resources <- initialiseResources physicalDevice device resourceFlags initialResourceSet @@ -438,12 +446,12 @@ toy = runVulkan initialState do -- simulation -- update UBO + controllerValues <- readControllers imGuiControllerRefs + let BufferResource _ updateInputData = inputDataUBO resources - - - currentInput :: InputData - currentInput = pos :& 0 :& 0 :& 0 :& 0 :& Prelude.pure 0 :& End + currentInput :: InputData Value + currentInput = pos :& Prelude.pure 0 :& controllerValues :& End liftIO ( updateInputData currentInput ) @@ -455,7 +463,10 @@ toy = runVulkan initialState do ImGui.Vulkan.vulkanNewFrame ImGui.SDL.sdl2NewFrame window ImGui.newFrame - ImGui.showDemoWindow + began <- ImGui.begin "Shader toy!" + when began do + createControllers imGuiControllerRefs + ImGui.end ImGui.render drawData <- ImGui.getDrawData let diff --git a/fir-examples/examples/shaders/FIR/Examples/Toy/Shaders.hs b/fir-examples/examples/shaders/FIR/Examples/Toy/Shaders.hs index 0fabbb39..9f342013 100644 --- a/fir-examples/examples/shaders/FIR/Examples/Toy/Shaders.hs +++ b/fir-examples/examples/shaders/FIR/Examples/Toy/Shaders.hs @@ -1,23 +1,26 @@ {-# OPTIONS_GHC -Wno-missing-local-signatures #-} -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE PartialTypeSignatures #-} -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE RebindableSyntax #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE NamedWildCards #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE NamedWildCards #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} module FIR.Examples.Toy.Shaders where -- base import Data.Foldable ( sequence_ ) +import Data.Kind + ( Type ) import Data.Maybe ( fromJust ) import GHC.TypeNats @@ -42,24 +45,39 @@ import FIR.Syntax.Labels import Math.Linear -- fir-examples +import FIR.Examples.DearImGui + ( Controller(..), ControllerRef(..), ControllerData + , controllerInitValues + ) import FIR.Examples.Paths ( shaderDir ) ------------------------------------------------ -- user data -type InputData = +type InputData :: ControllerRef -> Type +type InputData ref = Struct '[ "mousePos" ':-> V 2 Float - , "slider1" ':-> Float - , "slider2" ':-> Float - , "button1" ':-> Int32 - , "button2" ':-> Int32 , "scancodes" ':-> Array 512 Word32 + , "imGuiData" ':-> ImGuiData ref ] -zeroInputData :: InputData -zeroInputData = V2 0 0 :& 0 :& 0 :& 0 :& 0 :& Prelude.pure 0 :& End +type ImGuiData :: ControllerRef -> Type +type ImGuiData ref = + Struct + '[ "slider1" ':-> ControllerData ref Float + , "slider2" ':-> ControllerData ref Float + ] + +initImGuiData :: ImGuiData InitValue +initImGuiData + = ( "Slider 1", Slider, 0 ) + :& ( "Slider 2", Slider, 0 ) + :& End + +initInputData :: InputData Value +initInputData = V2 0 0 :& Prelude.pure 0 :& controllerInitValues initImGuiData :& End ------------------------------------------------ -- pipeline input @@ -87,7 +105,7 @@ type FragmentDefs = '[ "out_colour" ':-> Output '[ Location 0 ] ( V 4 Float ) , "ubo" ':-> Uniform '[ Binding 0, DescriptorSet 0 ] - InputData + ( InputData Value ) , "main" ':-> EntryPoint '[ OriginUpperLeft ] Fragment ] @@ -103,68 +121,101 @@ xWidth, yWidth :: Code Float xWidth = recip . fromIntegral $ xSamples yWidth = recip . fromIntegral $ ySamples +pixel2Coord :: Code Float -> Code (V 4 Float) -> Code (V 2 Float) +pixel2Coord range (Vec4 pixX' pixY' _ _) = + let (pixX, pixY) = if inverseCoord then (pixY', pixX') else (pixX', pixY') + (uvX, uvY) = (pixX / screenX, pixY / screenY) + x = uvX * range - centerX + y = uvY * range - centerY + in Vec2 x y + +-- Params begins + +inverseCoord :: Bool +inverseCoord = True + +screenX, screenY :: Code Float +(screenX, screenY) = (500, 500) + +centerX, centerY :: Code Float +(centerX, centerY) = (0, 0) + +grad_freq :: Code Float +grad_freq = 0.6 + +max_iter' :: Word32 +max_iter' = 100 + +seed :: Code (V 2 Float) +seed = Vec2 (-0.7477055835083013) (-2.692868835794263) + +-- Params ends fragment :: ShaderModule "main" FragmentShader FragmentDefs _ fragment = shader do + gl_FragCoord <- #gl_FragCoord + range' <- use @(Name "ubo" :.: Name "imGuiData" :.: Name "slider1") + + let range = 1000 * range' + let escape = 4242 + let max_iter = 100 - ~( Vec4 x y _ _ ) <- #gl_FragCoord - ( mkRescaledComplex -> c ) <- use @(Name "ubo" :.: Name "mousePos") + #modulus #= (0 :: Code Float) + #mean #= (0 :: Code Float) - #mag #= ( 0 :: Code Float ) + #iter #= (0 :: Code Word32) - supersamplingLoop \ xNo yNo -> locally do + #z #= pixel2Coord range gl_FragCoord + #depth #= (0 :: Code Word32) - let - dx, dy :: Code Float - dx = ( fromIntegral xNo + 0.5 ) * xWidth - 0.5 - dy = ( fromIntegral yNo + 0.5 ) * xWidth - 0.5 + -- let Vec2 mouseX mouseY = pixel2Coord (Vec4 mx my 0 0) - #z #= codeComplex ( mkRescaledComplex ( Vec2 (x + dx) (y + dy) ) ) - #depth #= ( 0 :: Code Word32 ) + -- let Vec2 x y = seed + let c = seed -- Vec2 (x + mouseX) (y + mouseY) + loop do + iter <- #iter + modulus <- #modulus + z <- #z + if iter > max_iter || modulus > escape + then break @1 + else do + let Vec2 zR zI = z + newZ = Vec2 zR (abs zI) ^+^ c - loop do - ( CodeComplex -> z ) <- #z - depth <- #depth - if magnitude z > 10 || depth > maxDepth - then break @1 - else do - ~(Vec2 zr zi) <- #z - z' <- let' $ zr :+: abs zi - #z .= codeComplex ( complexLog z' + c ) - #depth .= depth + 1 + newZLog = complexLog (CodeComplex newZ) - ( CodeComplex -> z ) <- #z - #mag %= ( + magnitude z ) + newModulus = magnitude newZLog - pure () + #modulus .= newModulus - mag <- #mag - let t = log ( mag * xWidth * yWidth ) - / log ( fromIntegral maxDepth ) + mean <- #mean + #mean .= (mean + newModulus) - let col = gradient t (Lit sunset) + #iter .= (iter + 1) + #z .= codeComplex newZLog - #out_colour .= col + 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 = gradient t (Lit sunset) + + --let col' = Vec4 t 0.2 0.1 0.5 + + #out_colour .= col mkRescaledComplex :: Code (V 2 Float) -> CodeComplex Float mkRescaledComplex (Vec2 x y) = ( (x - 960) / 250 ) :+: ( (y - 540) / 250 ) -supersamplingLoop - :: ( Code Word32 -> Code Word32 -> Program _s _s () ) - -> Program _s _s () -supersamplingLoop prog = locally do - #ssX #= 0 - #ssY #= 0 - while ( ( xSamples > ) <<$>> #ssX ) do - ssX <- #ssX - #ssY .= 0 - while ( ( ySamples > ) <<$>> #ssY ) do - ssY <- #ssY - embed $ prog ssX ssY - #ssY %= (+1) - #ssX %= (+1) - pure () - gradient :: forall n. KnownNat n => Code Float -> Code (Array n (V 4 Float)) diff --git a/fir-examples/fir-examples.cabal b/fir-examples/fir-examples.cabal index 9bd91c25..23317c57 100644 --- a/fir-examples/fir-examples.cabal +++ b/fir-examples/fir-examples.cabal @@ -188,6 +188,21 @@ library , vulkan-utils >= 0.4 && < 0.5 +library fir-examples-dear-imgui + + import: base-common + + hs-source-dirs: + src + + exposed-modules: + FIR.Examples.DearImGui + + build-depends: + fir + , dear-imgui + ^>= 1.0.0 + ---------------------------------------------------------------- -- Examples. @@ -519,6 +534,9 @@ library toy-shaders exposed-modules: FIR.Examples.Toy.Shaders + build-depends: + fir-examples-dear-imgui + executable Toy import: apps-common @@ -533,6 +551,5 @@ executable Toy examples/exes/Toy build-depends: - toy-shaders, - dear-imgui - >= 1.0.0 && < 1.1 + fir-examples-dear-imgui + , toy-shaders diff --git a/fir-examples/src/FIR/Examples/DearImGui.hs b/fir-examples/src/FIR/Examples/DearImGui.hs new file mode 100644 index 00000000..051bca01 --- /dev/null +++ b/fir-examples/src/FIR/Examples/DearImGui.hs @@ -0,0 +1,119 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +module FIR.Examples.DearImGui where + +-- base +import Control.Monad + ( void ) +import Data.Int + ( Int32 ) +import Data.IORef + ( IORef, readIORef, newIORef ) +import Data.Kind + ( Constraint, Type ) +import GHC.TypeLits + ( Symbol ) + +-- dear-imgui +import qualified DearImGui + +-- transformers +import Control.Monad.IO.Class + ( MonadIO(liftIO) ) + +-- fir +import FIR + ( Struct(..), (:->)(..) ) + +-------------------------------------------------------------------------------- + +data Controller a where + Slider :: Controller Float + Toggle :: Controller Int32 + +createController :: MonadIO m => String -> Controller a -> IORef a -> m () +createController controllerName controllerType ref = + case controllerType of + Slider -> + void $ DearImGui.sliderFloat controllerName ref 0.0 1.0 + Toggle -> pure () -- TODO + +-------------------------------------------------------------------------------- + +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 + +type ControllerInitValues :: [ Symbol :-> Type ] -> [ Symbol :-> Type ] -> Constraint +class ControllerInitValues as bs | as -> bs, bs -> as where + controllerInitValues :: Struct as -> Struct bs +instance ControllerInitValues '[] '[] where + controllerInitValues _ = End +instance ( ControllerInitValues as bs + , k1 ~ k2 + , v ~ ( String, Controller a, a ) + , r ~ a + ) + => ControllerInitValues ( ( k1 ':-> v ) ': as ) ( ( k2 ':-> r ) ': bs ) + where + controllerInitValues ( ( _, _, a ) :& as ) = + a :& controllerInitValues as + +type CreateControllerRefs :: [ Symbol :-> Type ] -> [ Symbol :-> Type ] -> Constraint +class CreateControllerRefs as bs | as -> bs, bs -> as where + createControllerRefs :: MonadIO m => Struct as -> m ( Struct bs ) +instance CreateControllerRefs '[] '[] where + createControllerRefs _ = pure End +instance ( CreateControllerRefs as bs + , k1 ~ k2 + , v ~ ( String, Controller a, a ) + , r ~ ( String, Controller a, IORef a ) + ) + => CreateControllerRefs ( ( k1 ':-> v ) ': as ) ( ( k2 ':-> r ) ': bs ) + where + createControllerRefs ( ( nm, ct, a ) :& as ) = do + ref <- liftIO $ newIORef a + refs <- createControllerRefs as + pure ( ( nm, ct, ref ) :& refs ) + +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 ) + ) + => CreateControllers ( ( k ':-> r ) ': as ) + where + createControllers ( ( nm, ct, r ) :& rs ) = + createController nm ct r *> createControllers rs + +type ReadControllers :: [ Symbol :-> Type ] -> [ Symbol :-> Type ] -> Constraint +class ReadControllers as bs | as -> bs, bs -> as 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 + ) + => ReadControllers ( ( k1 ':-> r ) ': as ) ( ( k2 ':-> b ) ': bs ) + where + readControllers ( ( _, _, r ) :& rs ) = do + a <- liftIO $ readIORef r + as <- readControllers rs + pure ( a :& as ) + -- GitLab