From 21eedd5e4d3776bcc711dd585f7594409eec0373 Mon Sep 17 00:00:00 2001 From: sheaf Date: Tue, 17 Oct 2023 19:26:27 +0200 Subject: [PATCH 1/4] WIP: brush stroking --- .../apps/FIR/Examples/Brush/Application.hs | 380 ++++++++++++++++++ fir-examples/examples/exes/Brush/Main.hs | 7 + .../shaders/FIR/Examples/Brush/Shaders.hs | 300 ++++++++++++++ 3 files changed, 687 insertions(+) create mode 100644 fir-examples/examples/apps/FIR/Examples/Brush/Application.hs create mode 100644 fir-examples/examples/exes/Brush/Main.hs create mode 100644 fir-examples/examples/shaders/FIR/Examples/Brush/Shaders.hs diff --git a/fir-examples/examples/apps/FIR/Examples/Brush/Application.hs b/fir-examples/examples/apps/FIR/Examples/Brush/Application.hs new file mode 100644 index 00000000..2b035310 --- /dev/null +++ b/fir-examples/examples/apps/FIR/Examples/Brush/Application.hs @@ -0,0 +1,380 @@ +{-# 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.Brush.Application ( brush ) 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 +import qualified Vulkan as Vulkan.Extent2D + ( Extent2D(..) ) +import qualified Vulkan as Vulkan.Surface + ( SurfaceFormatKHR(..) ) +import qualified Vulkan.Zero as 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.JuliaSet.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 - Brush stroking" +shortName :: String +shortName = "brush" -- 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. + +juliaSet :: IO () +juliaSet = 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 = 800 + , height = 600 + , 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.Extent2D.width swapchainExtent + height = fromIntegral $ Vulkan.Extent2D.height swapchainExtent + + extent3D :: Vulkan.Extent3D + extent3D + = Vulkan.Extent3D + { Vulkan.width = width + , Vulkan.height = height + , Vulkan.depth = 1 + } + + colFmt :: Vulkan.Format + colFmt = Vulkan.Surface.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" *> createCommandPool device Vulkan.zero ( fromIntegral 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 + + logDebug "Starting main loop" + + mainLoop do + + ---------------- + -- shader reloading + + ( updatedCommands, updatedScreenshotCommands ) + <- statelessly ( snd . fst <$> readDynResources resourcesTVar ) + + ---------------- + -- input + + inputEvents <- map SDL.Event.eventPayload <$> SDL.pollEvents + prevInput <- use _input + let + prevAction = interpretInput 1 prevInput + newInput = foldl (onSDLInput window) 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/Brush/Main.hs b/fir-examples/examples/exes/Brush/Main.hs new file mode 100644 index 00000000..aff4c7b3 --- /dev/null +++ b/fir-examples/examples/exes/Brush/Main.hs @@ -0,0 +1,7 @@ +module Main where + +import FIR.Examples.Brush.Application + ( brush ) + +main :: IO () +main = brush diff --git a/fir-examples/examples/shaders/FIR/Examples/Brush/Shaders.hs b/fir-examples/examples/shaders/FIR/Examples/Brush/Shaders.hs new file mode 100644 index 00000000..3d683f4b --- /dev/null +++ b/fir-examples/examples/shaders/FIR/Examples/Brush/Shaders.hs @@ -0,0 +1,300 @@ +{-# OPTIONS_GHC -Wno-missing-local-signatures #-} + +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE NamedWildCards #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} + +module FIR.Examples.Brush.Shaders where + +-- base +import Data.Foldable + ( sequence_ ) +import GHC.TypeNats + ( KnownNat ) + +-- filepath +import System.FilePath + ( () ) + +-- text-short +import Data.Text.Short + ( ShortText ) + +-- fir +import FIR +import Math.Linear + +-- fir-examples +import FIR.Examples.Paths + ( shaderDir ) + +------------------------------------------------ +-- pipeline input + +type VertexInput + = '[ Slot 0 0 ':-> V 3 Float + , Slot 1 0 ':-> GlyphIndex + ] + +------------------------------------- +-- vertex shader + +type VertexDefs = + '[ "in_position" ':-> Input '[ Location 0 ] ( V 3 Float ) + , "in_index" ':-> Input '[ Location 1 ] GlyphIndex + , "out_index" ':-> Output '[ Location 0 ] GlyphIndex + , "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 + put @"out_index" =<< get @"in_index" + +------------------------------------------------ +-- fragment shader + +-- | A single point in a glyph, specified as +-- +-- - the coordinates of the point, +-- - the brush parameters of the point (assumed to be a 4-vector for now). +-- +-- A glyph is a cubic Bézier spline in the space of glyph points. +type GlyphPoint = + Struct '[ "params" ':-> V 4 Float + , "coords" ':-> V 2 Float + ] + +type BrushType = Word64 + + +-- | An index into the glyph array: +-- +-- - the index of the first point of the glyph in the glyph array, +-- - how many points the glyph consists of (cubic Bézier spline), +-- - which brush to use for the glyph. +type GlyphIndex = V 3 Word64 + +type FragmentDefs = + '[ "main" ':-> EntryPoint '[ OriginUpperLeft ] Fragment + , "out" ':-> Output '[ Location 0 ] Float + + , "index" ':-> Input '[ Location 0 ] GlyphIndex + + -- Viewport + , "ubo" ':-> Uniform '[ Binding 0, DescriptorSet 0 ] + ( Struct '[ "viewport" ':-> V 4 Float + , "mousePos" ':-> V 2 Float + ] ) + + -- Glyphs + , "glyphs" ':-> StorageBuffer '[ Binding 0, DescriptorSet 1 ] + ( Struct '[ "array" ':-> RuntimeArray GlyphPoint ] ) + ] + + +fragment :: ShaderModule "main" FragmentShader FragmentDefs _ +fragment = shader do + + ~( Vec4 frag_x frag_y _ _ ) <- use @( Name "gl_FragCoord" ) + ~( Vec4 l r d u ) <- use @( Name "ubo" :.: Name "viewport" ) + + -- Compute the canvas coordinates from the fragment coordinates + -- and the viewport. + let + x, y :: Code Float + x = l + 0.5 * ( frag_x + 1 ) * ( r - l ) + y = d + 0.5 * ( frag_y + 1 ) * ( u - d ) + + -- Look up which glyph we are currently rendering. + ~( Vec3 i0 nbPoints brushType ) <- use @( Name "index" ) + + -- Main loop over sets of 4 consecutive points in the cubic Bézier spline + _ <- def @"signedDist" @RW @Float ( Lit $ 1 / 0 ) + pt00 <- use @( Name "glyphs" :.: Name "array" :.: AnIndex Word64 ) i0 + _ <- def @"startPt" @RW @GlyphPoint pt00 + _ <- def @"i" @RW @Word64 ( i0 + 1 ) + loop do + i <- get @"i" + if i + 2 >= i0 + nbPoints + then break @1 + else do + pt0 <- get @"startPt" + pt1 <- use @( Name "glyphs" :.: Name "array" :.: AnIndex Word64 ) i + pt2 <- use @( Name "glyphs" :.: Name "array" :.: AnIndex Word64 ) ( i + 1 ) + pt3 <- use @( Name "glyphs" :.: Name "array" :.: AnIndex Word64 ) ( i + 2 ) + dist <- signedDistanceToBrushStroke ( Vec2 x y ) brushType pt0 pt1 pt2 pt3 + modifying @( Name "signedDist" ) ( min dist ) + put @"i" ( i + 3 ) + put @"startPt" pt3 + + put @"out" =<< get @"signedDist" + +signedDistanceToBrushStroke + :: Code ( V 2 Float ) + -> Code BrushType + -> Code GlyphPoint -> Code GlyphPoint -> Code GlyphPoint -> Code GlyphPoint + -> Program s s ( Code Float ) +signedDistanceToBrushStroke + q + brushType + pt0 pt1 pt2 pt3 = + switchM ( return brushType ) + [ brushNb :-> signedDistanceFromSignedDistFn brushDistFn q pt0 pt1 pt2 pt3 + | ( brushNb, brushDistFn ) <- brushes + ] + ( signedDistanceFromSignedDistFn ellipseSignedDistFn q pt0 pt1 pt2 pt3 ) + +type BrushStrokeSignedDistance i j + = SignedDistFn j + -> Code ( V 2 Float ) + -> Code GlyphPoint -> Code GlyphPoint -> Code GlyphPoint -> Code GlyphPoint + -> Program i i ( Code Float ) + +brushes :: [ ( Word64, SignedDistFn s ) ] +brushes = [ ( 0, ellipseSignedDistFn ) ] + +type SignedDistFn j + = Code ( V 2 Float ) -> Code ( V 2 Float ) -> Code ( V 4 Float ) + -> Program j j ( Code Float ) + +signedDistanceFromSignedDistFn + :: SignedDistFn _j + -> Code ( V 2 Float ) + -> Code GlyphPoint -> Code GlyphPoint -> Code GlyphPoint -> Code GlyphPoint + -> Program i i ( Code Float ) +signedDistanceFromSignedDistFn signedDistFn q pt0 pt1 pt2 pt3 = purely do + _ <- def @"d" @RW @Float ( Lit $ 1 / 0 ) + _ <- def @"t" @RW @Float ( Lit 0 ) + loop do + t <- get @"t" + if t > 1 + then break @1 + else do + cd0 <- let' $ view @( Name "coords" ) pt0 + cd1 <- let' $ view @( Name "coords" ) pt1 + cd2 <- let' $ view @( Name "coords" ) pt2 + cd3 <- let' $ view @( Name "coords" ) pt3 + cd <- let' $ bezier3 ( lerpVec @2 ) t cd0 cd1 cd2 cd3 + params0 <- let' $ view @( Name "params" ) pt0 + params1 <- let' $ view @( Name "params" ) pt1 + params2 <- let' $ view @( Name "params" ) pt2 + params3 <- let' $ view @( Name "params" ) pt3 + params <- let' $ bezier3 ( lerpVec @4 ) t params0 params1 params2 params3 + d <- signedDistFn q cd params + modifying @( Name "d" ) ( min d ) + put @"t" ( t + 0.099 ) + get @"d" + +ellipseSignedDistFn :: Code ( V 2 Float ) -> Code ( V 2 Float ) -> Code ( V 4 Float ) + -> Program s s ( Code Float ) +ellipseSignedDistFn q p ( Vec4 a b theta _ ) = do + q' <- rotate (-theta) ( q ^-^ p ) + ~( Vec2 x y ) <- let' ( abs <$$> q' ) + if x > y + then ellipseSignedDist ( Vec2 y x ) b a + else ellipseSignedDist ( Vec2 x y ) a b + +ellipseSignedDist :: forall s + . Code ( V 2 Float ) -> Code Float -> Code Float + -> Program s s ( Code Float ) +ellipseSignedDist p@( Vec2 x y ) a b = purely do + l <- let' $ b * b - a * a + m <- let' $ a * x / l + n <- let' $ b * y / l + m2 <- let' $ m * m + n2 <- let' $ n * n + c <- let' $ ( m2 + n2 - 1 ) / 3 + c3 <- let' $ c * c * c + d <- let' $ c3 + m2 * n2 + q <- let' $ d + m2 * n2 + g <- let' $ m + m * n2 + co0 <- + if d < 0 + then do + h <- let' $ acos ( q / c3 ) / 3 + s <- let' $ cos h + 2 + t <- let' $ sin h + sqrt 3 + rx <- let' $ sqrt ( m2 - c * ( s + t ) ) + ry <- let' $ sqrt ( m2 - c * ( s - t ) ) + let' $ ry + signum l * rx + ( abs g ) / ( rx * ry ) + else do + h <- let' $ 2 * m * n * sqrt d + s <- let' $ msign ( q + h ) * ( abs ( q + h ) ** ( 1 / 3 ) ) + t <- let' $ msign ( q - h ) * ( abs ( q - h ) ** ( 1 / 3 ) ) + rx <- let' $ 2 * m2 - s - t - 4 * c + ry <- let' $ ( s - t ) * sqrt 3 + rm <- let' $ sqrt ( rx * rx + ry * ry ) + let' $ 2 * g / rm + ry / sqrt ( rm - rx ) + co <- let' $ ( co0 - m ) / 2 + si <- let' $ sqrt ( max 0 $ 1 - co * co ) + r <- let' $ Vec2 ( a * co ) ( b * si ) + + let' $ norm ( r ^-^ p ) * msign ( y - b * si ) + +rotate :: Code Float -> Code ( V 2 Float ) -> Program s s ( Code ( V 2 Float ) ) +rotate theta ( Vec2 x y ) = do + c <- let' $ cos theta + s <- let' $ sin theta + let' $ Vec2 ( c * x - s * y ) ( c * y + s * x ) + +msign :: Code Float -> Code Float +msign x = + if x < 0 + then Lit (-1) + else Lit (1) + +bezier3 :: ( Code Float -> Code a -> Code a -> Code a ) + -> Code Float -> Code a -> Code a -> Code a -> Code a + -> Code a +bezier3 lerp t p0 p1 p2 p3 + = lerp t ( bezier2 lerp t p0 p1 p2 ) ( bezier2 lerp t p1 p2 p3 ) + +bezier2 :: ( Code Float -> Code a -> Code a -> Code a ) + -> Code Float -> Code a -> Code a -> Code a + -> Code a +bezier2 lerp t p0 p1 p2 + = lerp t ( lerp t p0 p1 ) ( lerp t p1 p2 ) + +lerpVec :: KnownNat n + => Code Float + -> Code ( V n Float ) -> Code ( V n Float ) + -> Code ( V n Float ) +lerpVec t v1 v2 = v1 ^+^ ( t *^ ( v2 ^-^ v1) ) + +------------------------------------------------ +-- compiling + +vertPath, fragPath :: FilePath +vertPath = shaderDir "brush_vert.spv" +fragPath = shaderDir "brush_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) -- GitLab From 421a013f5f9a78297369a408261267e019f56f69 Mon Sep 17 00:00:00 2001 From: sheaf Date: Wed, 18 Oct 2023 11:51:54 +0200 Subject: [PATCH 2/4] progress on brush stroking --- .../apps/FIR/Examples/Brush/Application.hs | 229 +++++++++++++----- .../shaders/FIR/Examples/Brush/Shaders.hs | 49 ++-- fir-examples/fir-examples.cabal | 30 ++- 3 files changed, 226 insertions(+), 82 deletions(-) diff --git a/fir-examples/examples/apps/FIR/Examples/Brush/Application.hs b/fir-examples/examples/apps/FIR/Examples/Brush/Application.hs index 2b035310..c3101a4c 100644 --- a/fir-examples/examples/apps/FIR/Examples/Brush/Application.hs +++ b/fir-examples/examples/apps/FIR/Examples/Brush/Application.hs @@ -5,6 +5,7 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LexicalNegation #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} @@ -20,7 +21,9 @@ module FIR.Examples.Brush.Application ( brush ) where -- base import Control.Monad - ( when, void ) + ( when ) +import Data.Bits + ( (.|.) ) import Data.String ( IsString ) import Data.Traversable @@ -30,9 +33,9 @@ import Data.Word import GHC.Generics ( Generic ) --- lens -import Control.Lens - ( use, assign ) +-- mtl +import Control.Monad.State + ( get, put ) -- logging-effect import Control.Monad.Log @@ -41,7 +44,6 @@ import Control.Monad.Log -- sdl2 import qualified SDL import qualified SDL.Event -import qualified SDL.Raw.Event as SDL -- text-short import Data.Text.Short @@ -77,13 +79,13 @@ import FIR ) import Math.Linear ( V - , pattern V2, pattern V3 - , (^+^), (*^) + , pattern V2, pattern V3, pattern V4 + , (^+^), (^-^), (*^) ) -- fir-examples import FIR.Examples.Common -import FIR.Examples.JuliaSet.Shaders +import FIR.Examples.Brush.Shaders import FIR.Examples.Paths import FIR.Examples.Reload import FIR.Examples.RenderState @@ -115,46 +117,121 @@ 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 + { viewportUBO :: UniformBuffer Viewport i st + , glyphBuffer :: StorageBuffer GlyphPoint 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 - ] +initialViewport :: Viewport +initialViewport + = V4 -400 400 -300 300 + :& V2 0 0 + :& End -viewportIndices :: [ Word32 ] -viewportIndices - = [ 0, 1, 2 - , 2, 1, 3 - ] +vertices :: [ VertexData ] +indices :: [ Word32 ] +( vertices, indices ) = go 0 0 glyphs + where + go :: Word32 -> Word32 -> [ ( [ GlyphPoint ], BrushType ) ] -> ( [ VertexData ], [ Word32 ] ) + go _ _ [] = ( [], [] ) + go i_g i_tri ( ( pts, brushTy ) : gs ) + = let ( vs, is ) = buffersFromGlyph pts brushTy i_g i_tri + ( vss, iss ) = go ( i_g + fromIntegral ( length pts ) ) ( i_tri + 4 ) gs + in ( vs ++ vss, is ++ iss ) + +buffersFromGlyph :: [ GlyphPoint ] -> BrushType + -> Word32 -> Word32 + -> ( [ VertexData ], [ Word32 ] ) +buffersFromGlyph pts brushTy i_g i_tri + = ( [ V3 l b 0 :& V3 i_g nbPts brushTy :& End + , V3 l t 0 :& V3 i_g nbPts brushTy :& End + , V3 r b 0 :& V3 i_g nbPts brushTy :& End + , V3 r t 0 :& V3 i_g nbPts brushTy :& End + ] + , [ i_tri, i_tri + 1, i_tri + 2 , i_tri + 2, i_tri + 1, i_tri + 3 ] ) + where + l, r, b, t :: Float + V4 l r b t = glyphBoundingBox pts brushTy + nbPts :: Word32 + nbPts = fromIntegral $ length pts nbIndices :: Word32 -nbIndices = 6 +nbIndices = fromIntegral $ length indices + +glyphs :: [ ( [ GlyphPoint ], BrushType ) ] +glyphs = [ ( glyph1, 0 ), ( glyph2, 0 ) ] + where + glyph1, glyph2 :: [ GlyphPoint ] + glyph1 = + [ V4 10 5 0 0 :& V2 -100 -100 :& End + , V4 10 5 0 0 :& V2 -100 0 :& End + , V4 10 5 (pi/6) 0 :& V2 0 0 :& End + , V4 10 5 (pi/3) 0 :& V2 -100 100 :& End + ] + + glyph2 = + [ V4 5 5 0 0 :& V2 300 300 :& End + , V4 10 10 0 0 :& V2 400 400 :& End + , V4 15 15 0 0 :& V2 200 200 :& End + , V4 20 20 0 0 :& V2 300 300 :& End + ] + +glyphBoundingBox :: [ GlyphPoint ] -> BrushType -> V 4 Float +glyphBoundingBox pts brushTy + = case brushTy of + 0 -> let q = maximumEllipseRadius pts + in V4 ( l - q ) ( r + q ) ( b - q ) ( t + q ) + _ -> error $ "unsupported brush type " ++ show brushTy + where + l, r, b, t :: Float + V4 l r b t = pointsBoundingBox pts + +-- | Naive bounding box of a Cubic Bézier spline, +-- computed by taking a convex hull of all control points. +pointsBoundingBox :: [ GlyphPoint ] -> V 4 Float +pointsBoundingBox [] = V4 ( -1 / 0 ) ( 1 / 0 ) ( -1 / 0 ) ( 1 / 0 ) +pointsBoundingBox ( ( _params :& V2 x y :& End ) : pts ) + = let V4 l r b t = pointsBoundingBox pts + in V4 ( min l x ) ( max r x ) ( min b y ) ( max t y ) + +maximumEllipseRadius :: [ GlyphPoint ] -> Float +maximumEllipseRadius [] = 0 +maximumEllipseRadius ( ( V4 a b _ _ :& _coords :& End ) : pts ) + = max a $ max b $ maximumEllipseRadius pts initialResourceSet :: ResourceSet numImages Pre initialResourceSet = ResourceSet - ( BufferData ( V2 0 0 ) ) - ( BufferData viewportVertices ) - ( BufferData viewportIndices ) + ( BufferData initialViewport ) + ( BufferData $ concatMap fst glyphs ) + ( BufferData vertices ) + ( BufferData indices ) clearValue :: Vulkan.ClearValue -clearValue = Vulkan.Color black +clearValue = Vulkan.Color white where - black :: Vulkan.ClearColorValue - black = Vulkan.Float32 0 0 0 0 + white :: Vulkan.ClearColorValue + white = Vulkan.Float32 1 1 1 1 + +data BrushAppState + = BrushAppState + { viewportCentre :: V 2 Float + , zoomLevel :: Float + } + +initialBrushAppState :: BrushAppState +initialBrushAppState + = BrushAppState + { viewportCentre = V2 0 0 + , zoomLevel = 1 + } ---------------------------------------------------------------------------- -- Application. -juliaSet :: IO () -juliaSet = runVulkan initialState do +brush :: IO () +brush = runVulkan initialBrushAppState do ------------------------------------------- -- Obtain requirements from shaders. @@ -253,9 +330,13 @@ juliaSet = runVulkan initialState do resourceFlags :: ResourceSet numImages Named resourceFlags = ResourceSet - ( StageFlags Vulkan.SHADER_STAGE_FRAGMENT_BIT ) - GeneralResource - GeneralResource + { viewportUBO = StageFlags $ Vulkan.SHADER_STAGE_VERTEX_BIT + .|. + Vulkan.SHADER_STAGE_FRAGMENT_BIT + , glyphBuffer = StageFlags Vulkan.SHADER_STAGE_FRAGMENT_BIT + , vertexBuffer = GeneralResource + , indexBuffer = GeneralResource + } PostInitialisationResult descriptorSetLayout descriptorSets cmdBindBuffers resources @@ -318,37 +399,59 @@ juliaSet = runVulkan initialState do -- input inputEvents <- map SDL.Event.eventPayload <$> SDL.pollEvents - prevInput <- use _input let - prevAction = interpretInput 1 prevInput - newInput = foldl (onSDLInput window) 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 } ) + input = foldl ( onSDLInput window ) nullInput inputEvents + mouse = mousePos input + scroll = mouseWheel input + takeScreenshot = + SDL.ScancodeF12 `elem` keysPressed input ---------------- -- simulation - -- update UBO - let - BufferResource _ updateMousePos = mousePosUBO resources + BrushAppState + { viewportCentre = oldCentre + , zoomLevel = oldZoom + } + <- get - liftIO ( updateMousePos pos ) + let + newCentre :: V 2 Float + newZoom :: Float + ( newCentre@( V2 c_x c_y ), newZoom ) + -- Scrolling vertically + -- | ... TODO + -- Scrolling horizontally + -- | ... TODO + -- Zooming + | otherwise + = let zoom + | scroll > 0 + = max 0.0078125 ( oldZoom / sqrt 2 ) ^ scroll + | otherwise + = min 4096 ( oldZoom * sqrt 2 ) ^ ( negate scroll ) + centre + = oldCentre + ^+^ ( ( 1 - oldZoom / newZoom ) *^ ( mouse ^-^ oldCentre ) ) + in ( centre, zoom ) + newViewport :: V 4 Float + newViewport = + V4 ( c_x - 400 * newZoom ) ( c_x + 400 * newZoom ) + ( c_y - 300 * newZoom ) ( c_y + 300 * newZoom ) + newViewportStruct :: Viewport + newViewportStruct + = newViewport + :& mouse + :& End + + put $ BrushAppState { viewportCentre = newCentre + , zoomLevel = newZoom + } + -- update UBO + let + BufferResource _ updateViewport = viewportUBO resources + liftIO ( updateViewport newViewportStruct ) ---------------- -- rendering @@ -357,8 +460,8 @@ juliaSet = runVulkan initialState do let commandBuffer - | takeScreenshot action = updatedScreenshotCommands `V.index` nextImageIndex - | otherwise = updatedCommands `V.index` nextImageIndex + | takeScreenshot = updatedScreenshotCommands `V.index` nextImageIndex + | otherwise = updatedCommands `V.index` nextImageIndex submitCommandBuffer queue @@ -371,10 +474,10 @@ juliaSet = runVulkan initialState do Vulkan.queueWaitIdle queue - when ( takeScreenshot action ) $ + when takeScreenshot $ writeScreenshotData shortName device swapchainExtent ( snd ( screenshotImagesAndMemories `V.index` nextImageIndex ) ) ---------------- - pure ( shouldQuit action ) + pure ( quitEvent input ) diff --git a/fir-examples/examples/shaders/FIR/Examples/Brush/Shaders.hs b/fir-examples/examples/shaders/FIR/Examples/Brush/Shaders.hs index 3d683f4b..6985671f 100644 --- a/fir-examples/examples/shaders/FIR/Examples/Brush/Shaders.hs +++ b/fir-examples/examples/shaders/FIR/Examples/Brush/Shaders.hs @@ -54,12 +54,26 @@ type VertexDefs = , "in_index" ':-> Input '[ Location 1 ] GlyphIndex , "out_index" ':-> Output '[ Location 0 ] GlyphIndex , "main" ':-> EntryPoint '[ ] Vertex + + , "ubo" ':-> Uniform '[ Binding 0, DescriptorSet 0 ] Viewport ] vertex :: ShaderModule "main" VertexShader VertexDefs _ vertex = shader do ~( Vec3 x y z ) <- get @"in_position" - put @"gl_Position" $ Vec4 x y z 1 + vp_struct <- get @"ubo" + vp <- let' $ view @( Name "viewport" ) vp_struct + l <- let' $ view @( Index 0 ) vp + r <- let' $ view @( Index 1 ) vp + b <- let' $ view @( Index 2 ) vp + t <- let' $ view @( Index 3 ) vp + ortho <- let' $ + Mat44 + ( 2 / ( r - l ) ) 0 0 0 + 0 ( 2 / ( t - b ) ) 0 0 + 0 0 1 0 + ( ( r + l ) / ( l - r ) ) ( ( t + b ) / ( b - t ) ) 0 1 + put @"gl_Position" $ Vec4 x y z 1 ^*! ortho put @"out_index" =<< get @"in_index" ------------------------------------------------ @@ -76,15 +90,19 @@ type GlyphPoint = , "coords" ':-> V 2 Float ] -type BrushType = Word64 +type BrushType = Word32 +type Viewport = + Struct '[ "viewport" ':-> V 4 Float + , "mousePos" ':-> V 2 Float + ] -- | An index into the glyph array: -- -- - the index of the first point of the glyph in the glyph array, -- - how many points the glyph consists of (cubic Bézier spline), -- - which brush to use for the glyph. -type GlyphIndex = V 3 Word64 +type GlyphIndex = V 3 Word32 type FragmentDefs = '[ "main" ':-> EntryPoint '[ OriginUpperLeft ] Fragment @@ -93,13 +111,10 @@ type FragmentDefs = , "index" ':-> Input '[ Location 0 ] GlyphIndex -- Viewport - , "ubo" ':-> Uniform '[ Binding 0, DescriptorSet 0 ] - ( Struct '[ "viewport" ':-> V 4 Float - , "mousePos" ':-> V 2 Float - ] ) + , "ubo" ':-> Uniform '[ Binding 0, DescriptorSet 0 ] Viewport -- Glyphs - , "glyphs" ':-> StorageBuffer '[ Binding 0, DescriptorSet 1 ] + , "glyphs" ':-> StorageBuffer '[ Binding 1, DescriptorSet 0 ] ( Struct '[ "array" ':-> RuntimeArray GlyphPoint ] ) ] @@ -108,32 +123,32 @@ fragment :: ShaderModule "main" FragmentShader FragmentDefs _ fragment = shader do ~( Vec4 frag_x frag_y _ _ ) <- use @( Name "gl_FragCoord" ) - ~( Vec4 l r d u ) <- use @( Name "ubo" :.: Name "viewport" ) + ~( Vec4 l r b t ) <- use @( Name "ubo" :.: Name "viewport" ) -- Compute the canvas coordinates from the fragment coordinates -- and the viewport. let x, y :: Code Float - x = l + 0.5 * ( frag_x + 1 ) * ( r - l ) - y = d + 0.5 * ( frag_y + 1 ) * ( u - d ) + x = l + ( r - l ) * ( frag_x + 0 ) / 800 + y = b + ( t - b ) * ( frag_y + 0 ) / 600 -- Look up which glyph we are currently rendering. ~( Vec3 i0 nbPoints brushType ) <- use @( Name "index" ) -- Main loop over sets of 4 consecutive points in the cubic Bézier spline _ <- def @"signedDist" @RW @Float ( Lit $ 1 / 0 ) - pt00 <- use @( Name "glyphs" :.: Name "array" :.: AnIndex Word64 ) i0 + pt00 <- use @( Name "glyphs" :.: Name "array" :.: AnIndex Word32 ) i0 _ <- def @"startPt" @RW @GlyphPoint pt00 - _ <- def @"i" @RW @Word64 ( i0 + 1 ) + _ <- def @"i" @RW @Word32 ( i0 + 1 ) loop do i <- get @"i" if i + 2 >= i0 + nbPoints then break @1 else do pt0 <- get @"startPt" - pt1 <- use @( Name "glyphs" :.: Name "array" :.: AnIndex Word64 ) i - pt2 <- use @( Name "glyphs" :.: Name "array" :.: AnIndex Word64 ) ( i + 1 ) - pt3 <- use @( Name "glyphs" :.: Name "array" :.: AnIndex Word64 ) ( i + 2 ) + pt1 <- use @( Name "glyphs" :.: Name "array" :.: AnIndex Word32 ) i + pt2 <- use @( Name "glyphs" :.: Name "array" :.: AnIndex Word32 ) ( i + 1 ) + pt3 <- use @( Name "glyphs" :.: Name "array" :.: AnIndex Word32 ) ( i + 2 ) dist <- signedDistanceToBrushStroke ( Vec2 x y ) brushType pt0 pt1 pt2 pt3 modifying @( Name "signedDist" ) ( min dist ) put @"i" ( i + 3 ) @@ -162,7 +177,7 @@ type BrushStrokeSignedDistance i j -> Code GlyphPoint -> Code GlyphPoint -> Code GlyphPoint -> Code GlyphPoint -> Program i i ( Code Float ) -brushes :: [ ( Word64, SignedDistFn s ) ] +brushes :: [ ( Word32, SignedDistFn s ) ] brushes = [ ( 0, ellipseSignedDistFn ) ] type SignedDistFn j diff --git a/fir-examples/fir-examples.cabal b/fir-examples/fir-examples.cabal index 409fce3a..f316d9ac 100644 --- a/fir-examples/fir-examples.cabal +++ b/fir-examples/fir-examples.cabal @@ -71,6 +71,8 @@ common vulkan-common >= 4.18 && < 5.3 , logging-effect ^>= 1.3.6 + , mtl + >= 2.2.2 && < 2.4 , resourcet ^>= 1.2.2 , sdl2 @@ -187,8 +189,6 @@ library , fir-examples-paths , fsnotify ^>= 0.3.0.1 - , mtl - >= 2.2.2 && < 2.4 , stm ^>= 2.5.0.0 , unliftio-core @@ -238,6 +238,32 @@ executable Bezier build-depends: bezier-shaders +----------------------------------- +-- Brush + +library brush-shaders + + import: shaders-common + + exposed-modules: + -- Shader module needs to be first. + FIR.Examples.Brush.Shaders + +executable Brush + + import: apps-common + + main-is: + Main.hs + + other-modules: + FIR.Examples.Brush.Application + + hs-source-dirs: + examples/exes/Brush + + build-depends: + brush-shaders ----------------------------------- -- FullPipeline -- GitLab From a5070569960508bbae719baa948cd60b6f64554c Mon Sep 17 00:00:00 2001 From: sheaf Date: Wed, 18 Oct 2023 19:38:24 +0200 Subject: [PATCH 3/4] further work on brush stroking --- .../apps/FIR/Examples/Brush/Application.hs | 64 +++++++++++++------ .../shaders/FIR/Examples/Brush/Shaders.hs | 15 +++-- fir-examples/src/Vulkan/Attachment.hs | 17 +++++ fir-examples/src/Vulkan/Pipeline.hs | 20 ++++-- 4 files changed, 85 insertions(+), 31 deletions(-) diff --git a/fir-examples/examples/apps/FIR/Examples/Brush/Application.hs b/fir-examples/examples/apps/FIR/Examples/Brush/Application.hs index c3101a4c..45ecba5c 100644 --- a/fir-examples/examples/apps/FIR/Examples/Brush/Application.hs +++ b/fir-examples/examples/apps/FIR/Examples/Brush/Application.hs @@ -57,7 +57,7 @@ import Control.Monad.IO.Class -- vector import qualified Data.Vector as Boxed.Vector - ( singleton ) + ( fromList ) -- vector-sized import qualified Data.Vector.Sized as V @@ -150,7 +150,7 @@ buffersFromGlyph pts brushTy i_g i_tri , V3 r b 0 :& V3 i_g nbPts brushTy :& End , V3 r t 0 :& V3 i_g nbPts brushTy :& End ] - , [ i_tri, i_tri + 1, i_tri + 2 , i_tri + 2, i_tri + 1, i_tri + 3 ] ) + , [ i_tri, i_tri + 1, i_tri + 2, i_tri + 2, i_tri + 1, i_tri + 3 ] ) where l, r, b, t :: Float V4 l r b t = glyphBoundingBox pts brushTy @@ -165,17 +165,17 @@ glyphs = [ ( glyph1, 0 ), ( glyph2, 0 ) ] where glyph1, glyph2 :: [ GlyphPoint ] glyph1 = - [ V4 10 5 0 0 :& V2 -100 -100 :& End - , V4 10 5 0 0 :& V2 -100 0 :& End - , V4 10 5 (pi/6) 0 :& V2 0 0 :& End - , V4 10 5 (pi/3) 0 :& V2 -100 100 :& End + [ V4 10 5 (pi/4) 0 :& V2 -100 -100 :& End + , V4 10 5 0 0 :& V2 -100 0 :& End + , V4 10 5 (pi/6) 0 :& V2 50 0 :& End + , V4 10 20 (pi/2) 0 :& V2 -200 300 :& End ] glyph2 = - [ V4 5 5 0 0 :& V2 300 300 :& End - , V4 10 10 0 0 :& V2 400 400 :& End - , V4 15 15 0 0 :& V2 200 200 :& End - , V4 20 20 0 0 :& V2 300 300 :& End + [ V4 10 5 (pi/4) 0 :& V2 100 -150 :& End + , V4 10 5 0 0 :& V2 -250 50 :& End + , V4 10 5 (pi/6) 0 :& V2 -50 50 :& End + , V4 10 20 (pi/2) 0 :& V2 50 150 :& End ] glyphBoundingBox :: [ GlyphPoint ] -> BrushType -> V 4 Float @@ -191,7 +191,7 @@ glyphBoundingBox pts brushTy -- | Naive bounding box of a Cubic Bézier spline, -- computed by taking a convex hull of all control points. pointsBoundingBox :: [ GlyphPoint ] -> V 4 Float -pointsBoundingBox [] = V4 ( -1 / 0 ) ( 1 / 0 ) ( -1 / 0 ) ( 1 / 0 ) +pointsBoundingBox [] = V4 ( 1 / 0 ) ( -1 / 0 ) ( 1 / 0 ) ( -1 / 0 ) pointsBoundingBox ( ( _params :& V2 x y :& End ) : pts ) = let V4 l r b t = pointsBoundingBox pts in V4 ( min l x ) ( max r x ) ( min b y ) ( max t y ) @@ -202,11 +202,13 @@ maximumEllipseRadius ( ( V4 a b _ _ :& _coords :& End ) : pts ) = max a $ max b $ maximumEllipseRadius pts initialResourceSet :: ResourceSet numImages Pre -initialResourceSet = ResourceSet - ( BufferData initialViewport ) - ( BufferData $ concatMap fst glyphs ) - ( BufferData vertices ) - ( BufferData indices ) +initialResourceSet = + ResourceSet + { viewportUBO = BufferData initialViewport + , glyphBuffer = BufferData $ concatMap fst glyphs + , vertexBuffer = BufferData vertices + , indexBuffer = BufferData indices + } clearValue :: Vulkan.ClearValue clearValue = Vulkan.Color white @@ -297,10 +299,17 @@ brush = runVulkan initialBrushAppState do colFmt :: Vulkan.Format colFmt = Vulkan.Surface.format surfaceFormat + -- signedDistFmt :: Vulkan.Format + -- signedDistFmt = Vulkan.FORMAT_R32_UNORM + renderPass <- logDebug "Creating a render pass" *> simpleRenderPass device ( noAttachments - { colorAttachments = Boxed.Vector.singleton $ presentableColorAttachmentDescription colFmt } + { colorAttachments = Boxed.Vector.fromList + [ presentableColorAttachmentDescription colFmt + --, simpleColorAttachmentDescription signedDistFmt + ] + } ) framebuffersWithAttachments @@ -378,7 +387,13 @@ brush = runVulkan initialBrushAppState do pipelineLayout pipe recordAllCommandsFromShaders = record2CommandBuffersFromShaders - ( createGraphicsPipeline device renderPass pipelineInfo ) + ( createGraphicsPipelineBlendOp device renderPass + Vulkan.BLEND_OP_MIN + -- Use "minimum" blend operation to combine signed distances + -- computed across multiple overlapping fragments. + False -- Disable depth tests. + pipelineInfo + ) recordCommandBuffers recordScreenshotCommandBuffers @@ -425,11 +440,18 @@ brush = runVulkan initialBrushAppState do -- | ... TODO -- Zooming | otherwise - = let zoom + = let zoom0 + | scroll == 0 + = oldZoom | scroll > 0 - = max 0.0078125 ( oldZoom / sqrt 2 ) ^ scroll + = oldZoom / ( sqrt 2 ) ^ scroll + | otherwise + = oldZoom * ( sqrt 2 ) ^ ( negate scroll ) + zoom + | isNaN zoom0 || isInfinite zoom0 + = 1 | otherwise - = min 4096 ( oldZoom * sqrt 2 ) ^ ( negate scroll ) + = max 0.0078125 $ min 4096 $ zoom0 centre = oldCentre ^+^ ( ( 1 - oldZoom / newZoom ) *^ ( mouse ^-^ oldCentre ) ) diff --git a/fir-examples/examples/shaders/FIR/Examples/Brush/Shaders.hs b/fir-examples/examples/shaders/FIR/Examples/Brush/Shaders.hs index 6985671f..271a15d1 100644 --- a/fir-examples/examples/shaders/FIR/Examples/Brush/Shaders.hs +++ b/fir-examples/examples/shaders/FIR/Examples/Brush/Shaders.hs @@ -52,8 +52,8 @@ type VertexInput type VertexDefs = '[ "in_position" ':-> Input '[ Location 0 ] ( V 3 Float ) , "in_index" ':-> Input '[ Location 1 ] GlyphIndex - , "out_index" ':-> Output '[ Location 0 ] GlyphIndex - , "main" ':-> EntryPoint '[ ] Vertex + , "out_index" ':-> Output '[ Location 0, Flat ] GlyphIndex + , "main" ':-> EntryPoint '[ ] Vertex , "ubo" ':-> Uniform '[ Binding 0, DescriptorSet 0 ] Viewport ] @@ -106,9 +106,9 @@ type GlyphIndex = V 3 Word32 type FragmentDefs = '[ "main" ':-> EntryPoint '[ OriginUpperLeft ] Fragment - , "out" ':-> Output '[ Location 0 ] Float + , "out" ':-> Output '[ Location 0 ] ( V 4 Float ) --Float - , "index" ':-> Input '[ Location 0 ] GlyphIndex + , "index" ':-> Input '[ Location 0, Flat ] GlyphIndex -- Viewport , "ubo" ':-> Uniform '[ Binding 0, DescriptorSet 0 ] Viewport @@ -154,7 +154,10 @@ fragment = shader do put @"i" ( i + 3 ) put @"startPt" pt3 - put @"out" =<< get @"signedDist" + dist <- get @"signedDist" + if dist > 0 + then put @"out" $ Vec4 dist dist dist 1 + else put @"out" $ Vec4 0 0 0 0 signedDistanceToBrushStroke :: Code ( V 2 Float ) @@ -209,7 +212,7 @@ signedDistanceFromSignedDistFn signedDistFn q pt0 pt1 pt2 pt3 = purely do params <- let' $ bezier3 ( lerpVec @4 ) t params0 params1 params2 params3 d <- signedDistFn q cd params modifying @( Name "d" ) ( min d ) - put @"t" ( t + 0.099 ) + put @"t" ( t + 0.001 ) -- 0.001 ) get @"d" ellipseSignedDistFn :: Code ( V 2 Float ) -> Code ( V 2 Float ) -> Code ( V 4 Float ) diff --git a/fir-examples/src/Vulkan/Attachment.hs b/fir-examples/src/Vulkan/Attachment.hs index f71c4c6a..693cd0f6 100644 --- a/fir-examples/src/Vulkan/Attachment.hs +++ b/fir-examples/src/Vulkan/Attachment.hs @@ -134,6 +134,23 @@ presentableColorAttachmentDescription colorFormat = , finalLayout = Vulkan.IMAGE_LAYOUT_PRESENT_SRC_KHR } +simpleColorAttachmentDescription :: Vulkan.Format -> ( Vulkan.AttachmentDescription, AttachmentType ) +simpleColorAttachmentDescription colorFormat = + ( description, ColorAttachment ) + where + description = + Vulkan.AttachmentDescription + { flags = Vulkan.zero + , format = colorFormat + , samples = Vulkan.SAMPLE_COUNT_1_BIT + , loadOp = Vulkan.ATTACHMENT_LOAD_OP_CLEAR + , 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_COLOR_ATTACHMENT_OPTIMAL + } + preservedColorAttachmentDescription :: Vulkan.Format -> ( Vulkan.AttachmentDescription, AttachmentType ) preservedColorAttachmentDescription colorFormat = ( description, ColorAttachment ) diff --git a/fir-examples/src/Vulkan/Pipeline.hs b/fir-examples/src/Vulkan/Pipeline.hs index 500e96bf..c7c41f9f 100644 --- a/fir-examples/src/Vulkan/Pipeline.hs +++ b/fir-examples/src/Vulkan/Pipeline.hs @@ -251,7 +251,19 @@ createGraphicsPipeline -> VkPipelineInfo -> ShaderPipeline Vulkan.ShaderModule -> m ( ReleaseKey, VkPipeline ) -createGraphicsPipeline device renderPass +createGraphicsPipeline dev pass pipe shaderPipe + = createGraphicsPipelineBlendOp dev pass Vulkan.BLEND_OP_ADD True pipe shaderPipe + +createGraphicsPipelineBlendOp + :: MonadVulkan m + => Vulkan.Device + -> Vulkan.RenderPass + -> Vulkan.BlendOp + -> Bool + -> VkPipelineInfo + -> ShaderPipeline Vulkan.ShaderModule + -> m ( ReleaseKey, VkPipeline ) +createGraphicsPipelineBlendOp device renderPass blendOp doDepthTest ( VkPipelineInfo extent sampleCount pipelineLayout ) ( ShaderPipeline ( shaderModules :: PipelineStages info Vulkan.ShaderModule ) @@ -351,7 +363,7 @@ createGraphicsPipeline device renderPass , Vulkan.alphaBlendOp = Vulkan.BLEND_OP_ADD , Vulkan.srcColorBlendFactor = Vulkan.BLEND_FACTOR_SRC_ALPHA , Vulkan.dstColorBlendFactor = Vulkan.BLEND_FACTOR_ONE_MINUS_SRC_ALPHA - , Vulkan.colorBlendOp = Vulkan.BLEND_OP_ADD + , Vulkan.colorBlendOp = blendOp , Vulkan.srcAlphaBlendFactor = Vulkan.BLEND_FACTOR_ONE , Vulkan.dstAlphaBlendFactor = Vulkan.BLEND_FACTOR_ZERO , Vulkan.colorWriteMask = @@ -391,8 +403,8 @@ createGraphicsPipeline device renderPass depthStencilState = Vulkan.PipelineDepthStencilStateCreateInfo { Vulkan.flags = Vulkan.zero - , Vulkan.depthTestEnable = True - , Vulkan.depthWriteEnable = True + , Vulkan.depthTestEnable = doDepthTest + , Vulkan.depthWriteEnable = doDepthTest , Vulkan.depthCompareOp = Vulkan.COMPARE_OP_LESS_OR_EQUAL , Vulkan.depthBoundsTestEnable = False , Vulkan.maxDepthBounds = 1 -- GitLab From c0c4fae8d56a2149b1f42abd55ab873545a90655 Mon Sep 17 00:00:00 2001 From: Rodrigo Mesquita Date: Wed, 18 Oct 2023 12:53:40 +0200 Subject: [PATCH 4/4] Support for MacOS --- fir-examples/src/Vulkan/Backend.hs | 14 ++++++++++++-- fir-examples/src/Vulkan/Context.hs | 7 ++++++- 2 files changed, 18 insertions(+), 3 deletions(-) diff --git a/fir-examples/src/Vulkan/Backend.hs b/fir-examples/src/Vulkan/Backend.hs index dc78456b..486cc135 100644 --- a/fir-examples/src/Vulkan/Backend.hs +++ b/fir-examples/src/Vulkan/Backend.hs @@ -1,5 +1,6 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE BlockArguments #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DuplicateRecordFields #-} @@ -26,7 +27,7 @@ import Control.Category import Control.Monad ( guard, unless, void ) import Data.Bits - ( Bits((.&.)) ) + ( Bits((.&.),(.|.)) ) import Data.Coerce ( coerce ) import Data.Foldable @@ -149,10 +150,19 @@ vulkanInstanceInfo appName = do Vulkan.InstanceCreateInfo { Vulkan.next = () , Vulkan.flags = Vulkan.zero +#if defined(darwin_HOST_OS) && defined(aarch64_HOST_ARCH) + .|. Vulkan.INSTANCE_CREATE_ENUMERATE_PORTABILITY_BIT_KHR +#endif , Vulkan.applicationInfo = Just appInfo , Vulkan.enabledLayerNames = Boxed.Vector.fromList enabledLayers - , Vulkan.enabledExtensionNames = mempty + , Vulkan.enabledExtensionNames = enabledExtensions } + enabledExtensions = Boxed.Vector.fromList [ + -- Apple silicon requires this extension at least from 1.3 with MoltenVk +#if defined(darwin_HOST_OS) && defined(aarch64_HOST_ARCH) + Vulkan.KHR_PORTABILITY_ENUMERATION_EXTENSION_NAME +#endif + ] case validationLayer of Nothing -> logInfo "Validation layer unavailable. Is the Vulkan SDK installed?" diff --git a/fir-examples/src/Vulkan/Context.hs b/fir-examples/src/Vulkan/Context.hs index 6fef56cc..1b225e2b 100644 --- a/fir-examples/src/Vulkan/Context.hs +++ b/fir-examples/src/Vulkan/Context.hs @@ -1,4 +1,5 @@ {-# LANGUAGE BlockArguments #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DuplicateRecordFields #-} @@ -257,7 +258,11 @@ initialiseContext instanceType appName ( VulkanRequirements { instanceRequiremen SWithSwapchain -> do let swapchainDeviceRequirements :: [ Vulkan.DeviceRequirement ] - swapchainDeviceRequirements = Vulkan.RequireDeviceExtension Nothing Vulkan.KHR_SWAPCHAIN_EXTENSION_NAME 0 : deviceRequirements + swapchainDeviceRequirements = Vulkan.RequireDeviceExtension Nothing Vulkan.KHR_SWAPCHAIN_EXTENSION_NAME 0 : +#if defined(darwin_HOST_OS) && defined(aarch64_HOST_ARCH) + Vulkan.RequireDeviceExtension Nothing Vulkan.KHR_PORTABILITY_SUBSET_EXTENSION_NAME 0 : +#endif + deviceRequirements device <- logDebug "Creating logical device" *> Vulkan.Utils.createDeviceFromRequirements swapchainDeviceRequirements [] physicalDevice logicalDeviceCreateInfo let SurfaceInfo {..} = surfaceInfo -- GitLab