From 97ee704c9281df74cce02bb95886687a11189433 Mon Sep 17 00:00:00 2001 From: Tristan Cacqueray Date: Sun, 20 Jun 2021 17:17:00 +0000 Subject: [PATCH] Add initial Toy example --- .../apps/FIR/Examples/Toy/Application.hs | 410 ++++++++++++++++++ fir-examples/examples/exes/Toy/Main.hs | 8 + .../shaders/FIR/Examples/Toy/Shaders.hs | 221 ++++++++++ fir-examples/fir-examples.cabal | 27 ++ 4 files changed, 666 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/examples/apps/FIR/Examples/Toy/Application.hs b/fir-examples/examples/apps/FIR/Examples/Toy/Application.hs new file mode 100644 index 00000000..17923e82 --- /dev/null +++ b/fir-examples/examples/apps/FIR/Examples/Toy/Application.hs @@ -0,0 +1,410 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# 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 + +-- lens +import Control.Lens + ( assign, + use, + ) +import Control.Monad + ( void, + when, + ) +-- logging-effect + +-- sdl2 + +-- text-short + +-- transformers +import Control.Monad.IO.Class + ( liftIO, + ) +import Control.Monad.Log + ( logDebug, + logInfo, + ) +import Data.String + ( IsString, + ) +import Data.Text.Short + ( ShortText, + ) +import qualified Data.Text.Short as ShortText + ( pack, + unpack, + ) +import Data.Traversable + ( for, + ) +-- vector +import qualified Data.Vector as Boxed.Vector + ( singleton, + ) +-- vector-sized +import qualified Data.Vector.Sized as V + ( index, + zip, + zip3, + ) +import Data.Word + ( Word32, + ) +-- vulkan + +-- fir +import FIR + ( ModuleRequirements (..), + Struct (End, (:&)), + runCompilationsTH, + ) +-- fir-examples +import FIR.Examples.Common +import FIR.Examples.Paths +import FIR.Examples.Reload +import FIR.Examples.RenderState +import FIR.Examples.Toy.Shaders +import GHC.Generics + ( Generic, + ) +import Math.Linear + ( V, + (*^), + (^+^), + pattern V2, + pattern V3, + ) +import qualified SDL +import qualified SDL.Event +import qualified SDL.Raw.Event as SDL +import qualified Vulkan +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 - 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..56acab42 --- /dev/null +++ b/fir-examples/examples/exes/Toy/Main.hs @@ -0,0 +1,8 @@ +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..95d2770e --- /dev/null +++ b/fir-examples/examples/shaders/FIR/Examples/Toy/Shaders.hs @@ -0,0 +1,221 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE NamedWildCards #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# OPTIONS_GHC -Wno-missing-local-signatures #-} + +module FIR.Examples.Toy.Shaders where + +-- base +import Data.Foldable + ( sequence_, + ) +import Data.Maybe + ( fromJust, + ) +-- filepath + +-- text-short +import Data.Text.Short + ( ShortText, + ) +-- vector-sized +import qualified Data.Vector.Sized as Vector + ( fromList, + ) +-- fir +import FIR +-- fir-examples +import FIR.Examples.Paths + ( shaderDir, + ) +import FIR.Syntax.Labels +import GHC.TypeNats + ( KnownNat, + ) +import Math.Linear +import System.FilePath + ( (), + ) + +------------------------------------------------ +-- 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 + ] + +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 + ] + +pixel2Coord :: Code (V 4 Float) -> Code (V 2 Float) +pixel2Coord (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 +seed :: Code (V 2 Float) + +inverseCoord = True + +(screenX, screenY) = (500, 500) + +range = 50.7 + +(centerX, centerY) = (0, 0) + +grad_freq = 0.6 + +max_iter' = 100 + +seed = Vec2 (-0.7477055835083013) (-2.692868835794263) + +-- Params ends +fragment :: ShaderModule "main" FragmentShader FragmentDefs _ +fragment = shader do + gl_FragCoord <- #gl_FragCoord + ~(Vec2 mx my) <- use @(Name "ubo" :.: Name "mousePos") + + let escape = 4242 + let max_iter = max_iter' + #modulus #= (0 :: Code Float) + #mean #= (0 :: Code Float) + + #iter #= (0 :: Code Word32) + + #z #= pixel2Coord gl_FragCoord + #depth #= (0 :: Code Word32) + + let Vec2 mouseX mouseY = pixel2Coord (Vec4 mx my 0 0) + + 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 + + newZLog = complexLog (CodeComplex newZ) + + newModulus = magnitude newZLog + + #modulus .= newModulus + + mean <- #mean + #mean .= (mean + newModulus) + + #iter .= (iter + 1) + #z .= codeComplex newZLog + + iter <- #iter + mean <- #mean + modulus <- #modulus + let iterF = fromIntegral iter + + t <- + let' @(Code Float) $ + if iter == (max_iter + 1) + then 1 - (0.3 * mean / iterF) + else + let ml = iterF - log (log (grad_freq * modulus)) / log 2 + log (log escape) / log 2 + res = ml / fromIntegral max_iter + in res + let col = gradient t (Lit sunset) + + let col' = Vec4 t 0.2 0.1 0.5 + + #out_colour .= col + +------------------------------------------------ +-- compiling + +vertPath, fragPath :: FilePath +vertPath = shaderDir "juliaset_vert.spv" +fragPath = shaderDir "juliaset_frag.spv" + +compileVertexShader :: IO (Either ShortText ModuleRequirements) +compileVertexShader = compileTo vertPath [] 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..504fe585 100644 --- a/fir-examples/fir-examples.cabal +++ b/fir-examples/fir-examples.cabal @@ -327,6 +327,33 @@ executable JuliaSet juliaset-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 + + ----------------------------------- -- Kerr -- GitLab