it draws, but it's flashy and ugly

This commit is contained in:
nek0 2022-07-14 11:02:12 +02:00
parent 83950010ac
commit c915d028a6
8 changed files with 86 additions and 16 deletions

View File

@ -3,5 +3,16 @@
let let
vulkanTutorial = pkgs.haskellPackages.callCabal2nix "vulkan-tutorial" (gitignore ./.) {}; vulkanTutorial = pkgs.haskellPackages.callCabal2nix "vulkan-tutorial" (gitignore ./.) {};
gitignore = src: pkgs.nix-gitignore.gitignoreSource [] src; gitignore = src: pkgs.nix-gitignore.gitignoreSource [] src;
hpkgs = pkgs.haskellPackages.override {
overrides = final: prev: {
vulkanTutorial = vulkanTutorial;
};
};
in in
vulkanTutorial.env hpkgs.shellFor {
packages = p: [
p.vulkanTutorial
];
buildInputs =
vulkanTutorial.buildInputs ++ [ pkgs.shaderc ];
}

View File

@ -14,6 +14,7 @@ import qualified Vulkan.Zero as Vk
-- internal imports -- internal imports
import Devices import Devices
import GHC.IO.Handle.Text (commitBuffer')
createCommandPool createCommandPool
:: (MonadResource m) :: (MonadResource m)
@ -85,7 +86,7 @@ recordCommandBuffer commandBuffer renderPass frameBuffer (V2 width height) graph
, Vk.height = fromIntegral height , Vk.height = fromIntegral height
} }
} }
, Vk.clearValues = V.singleton (Vk.Color $ Vk.Float32 0 0 0 1) , Vk.clearValues = V.replicate 4 (Vk.Color $ Vk.Float32 0 0 0 1)
} }
Vk.cmdBeginRenderPass commandBuffer renderPassInfo Vk.SUBPASS_CONTENTS_INLINE Vk.cmdBeginRenderPass commandBuffer renderPassInfo Vk.SUBPASS_CONTENTS_INLINE
@ -118,6 +119,7 @@ recordCommandBuffer commandBuffer renderPass frameBuffer (V2 width height) graph
Vk.cmdEndRenderPass commandBuffer Vk.cmdEndRenderPass commandBuffer
Vk.endCommandBuffer commandBuffer
createSyncObjects createSyncObjects
:: (MonadResource m, MonadFail m) :: (MonadResource m, MonadFail m)
@ -138,6 +140,11 @@ createSyncObjects logicalDevice = do
Vk.destroySemaphore logicalDevice semaphore Nothing Vk.destroySemaphore logicalDevice semaphore Nothing
) )
) )
inFlightFence <- Vk.createFence logicalDevice fenceCreateInfo Nothing inFlightFence <- snd <$> allocate
(Vk.createFence logicalDevice fenceCreateInfo Nothing)
(\fence -> do
putStrLn "destroying fence"
Vk.destroyFence logicalDevice fence Nothing
)
return (imageAvailableSemaphore, renderFinishedSemaphore, inFlightFence) return (imageAvailableSemaphore, renderFinishedSemaphore, inFlightFence)

View File

@ -153,7 +153,7 @@ createSwapchain surface surfaceFormats windowDimension logicalDevice = do
(\(V2 w h) -> Vk.Extent2D (fromIntegral w) (fromIntegral h)) windowDimension (\(V2 w h) -> Vk.Extent2D (fromIntegral w) (fromIntegral h)) windowDimension
, Vk.imageArrayLayers = 1 , Vk.imageArrayLayers = 1
, Vk.imageUsage = Vk.IMAGE_USAGE_COLOR_ATTACHMENT_BIT , Vk.imageUsage = Vk.IMAGE_USAGE_COLOR_ATTACHMENT_BIT
, Vk.presentMode = Vk.PRESENT_MODE_MAILBOX_KHR , Vk.presentMode = Vk.PRESENT_MODE_FIFO_KHR
, Vk.preTransform = Vk.SURFACE_TRANSFORM_IDENTITY_BIT_KHR , Vk.preTransform = Vk.SURFACE_TRANSFORM_IDENTITY_BIT_KHR
, Vk.compositeAlpha = Vk.COMPOSITE_ALPHA_OPAQUE_BIT_KHR , Vk.compositeAlpha = Vk.COMPOSITE_ALPHA_OPAQUE_BIT_KHR
, Vk.clipped = True , Vk.clipped = True

View File

@ -5,11 +5,16 @@ module Draw where
import Control.Monad import Control.Monad
import Control.Monad.Trans.Resource import Control.Monad.Trans.Resource
import qualified Data.Vector as V import qualified Data.Vector as V
import Foreign.C.Types (CInt)
import Linear (V2(..))
import qualified Vulkan.Core10 as Vk import qualified Vulkan.Core10 as Vk
import qualified Vulkan.Extensions.VK_KHR_swapchain as Khr import qualified Vulkan.Extensions.VK_KHR_swapchain as Khr
import qualified Vulkan.CStruct.Extends as Vk import qualified Vulkan.CStruct.Extends as Vk
import qualified Vulkan.Zero as Vk import qualified Vulkan.Zero as Vk
-- internal imports
import CommandBuffer
drawFrame drawFrame
:: (MonadResource m) :: (MonadResource m)
@ -17,6 +22,10 @@ drawFrame
-> Khr.SwapchainKHR -> Khr.SwapchainKHR
-> Vk.Queue -> Vk.Queue
-> Vk.CommandBuffer -> Vk.CommandBuffer
-> Vk.RenderPass
-> Vk.Framebuffer
-> V2 CInt
-> Vk.Pipeline
-> Vk.Fence -> Vk.Fence
-> Vk.Semaphore -> Vk.Semaphore
-> Vk.Semaphore -> Vk.Semaphore
@ -26,6 +35,10 @@ drawFrame
swapchain swapchain
graphicsQueue graphicsQueue
commandBuffer commandBuffer
renderPass
framebuffer
dimensions
pipeline
inFlightFence inFlightFence
imageAvailableSemaphore imageAvailableSemaphore
renderFinishedSemaphore renderFinishedSemaphore
@ -37,13 +50,15 @@ drawFrame
Vk.resetFences logicalDevice fences Vk.resetFences logicalDevice fences
(imageResult, index) <- (imageResult, index) <-
Khr.acquireNextImageKHR logicalDevice swapchain maxBound imageAvailableSemaphore inFlightFence Khr.acquireNextImageKHR logicalDevice swapchain maxBound imageAvailableSemaphore Vk.NULL_HANDLE
unless (imageResult == Vk.SUCCESS) $ unless (imageResult == Vk.SUCCESS) $
error "drawFrame: Failed acquiring next image from swapchain" error "drawFrame: Failed acquiring next image from swapchain"
Vk.resetCommandBuffer commandBuffer (Vk.CommandBufferResetFlagBits 0) Vk.resetCommandBuffer commandBuffer (Vk.CommandBufferResetFlagBits 0)
recordCommandBuffer commandBuffer renderPass framebuffer dimensions pipeline
let submitInfo = Vk.zero let submitInfo = Vk.zero
{ Vk.waitSemaphores = V.singleton imageAvailableSemaphore { Vk.waitSemaphores = V.singleton imageAvailableSemaphore
, Vk.waitDstStageMask = V.singleton Vk.PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT , Vk.waitDstStageMask = V.singleton Vk.PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT

View File

@ -8,23 +8,38 @@ import Control.Monad (unless)
import Control.Monad.IO.Class (liftIO) import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Resource import Control.Monad.Trans.Resource
import Data.Bits import Data.Bits
import qualified Data.ByteString as BS -- import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BS
import qualified Data.Vector as V import qualified Data.Vector as V
import Foreign.C.Types (CInt) import Foreign.C.Types (CInt)
import qualified Vulkan.Core10 as Vk import qualified Vulkan.Core10 as Vk
import qualified Vulkan.Zero as Vk import qualified Vulkan.Zero as Vk
import qualified Vulkan.CStruct.Extends as Vk import qualified Vulkan.CStruct.Extends as Vk
import qualified Vulkan.Utils.ShaderQQ.GLSL.Shaderc as Vk
loadShader loadShader
:: (MonadResource m) :: (MonadResource m)
=> Vk.Device => Vk.Device
-> FilePath -> FilePath
-> String
-> m Vk.ShaderModule -> m Vk.ShaderModule
loadShader logicalDevice shaderPath = do loadShader logicalDevice shaderPath stage = do
shaderSource <- liftIO $ BS.readFile shaderPath shaderSource <- liftIO $ BS.readFile shaderPath
(warnings, eShader) <- Vk.compileShader Nothing Nothing stage (BS.unpack shaderSource)
unless (null warnings) $ liftIO $ do
putStrLn "loadShader: Shader compilation warnings:"
print warnings
shader <- either
(\errors -> do
error ("loadShader: Compilation errors:" <> "\n" <> show errors)
)
return
eShader
let createInfo = Vk.zero let createInfo = Vk.zero
{ Vk.code = shaderSource { Vk.code = shader
} }
snd <$> allocate snd <$> allocate
@ -161,13 +176,16 @@ createGraphicsPipelines
, Vk.colorAttachments = V.singleton colorAttachmentReference , Vk.colorAttachments = V.singleton colorAttachmentReference
} }
subpassDependency = Vk.zero subpassDependency = Vk.zero
{ Vk.srcSubpass = Vk.SUBPASS_EXTERNAL { Vk.srcSubpass = Vk.SUBPASS_EXTERNAL
, Vk.dstSubpass = 0 , Vk.dstSubpass = 0
, Vk.srcStageMask = Vk.PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT , Vk.srcStageMask = Vk.PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT
, Vk.dstStageMask = Vk.PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT
, Vk.srcAccessMask = Vk.ACCESS_COLOR_ATTACHMENT_WRITE_BIT , Vk.srcAccessMask = Vk.ACCESS_COLOR_ATTACHMENT_WRITE_BIT
, Vk.dstAccessMask =
Vk.ACCESS_COLOR_ATTACHMENT_READ_BIT .|. Vk.ACCESS_COLOR_ATTACHMENT_WRITE_BIT
} }
renderPassCreateInfo = Vk.zero renderPassCreateInfo = Vk.zero
{ Vk.attachments = V.singleton colorAttachmentDescription { Vk.attachments = V.replicate 4 colorAttachmentDescription
, Vk.subpasses = V.singleton subpassDescriptor , Vk.subpasses = V.singleton subpassDescriptor
, Vk.dependencies = V.singleton subpassDependency , Vk.dependencies = V.singleton subpassDependency
} :: Vk.RenderPassCreateInfo '[] } :: Vk.RenderPassCreateInfo '[]

View File

@ -7,8 +7,10 @@ import Control.Monad
import Control.Monad.IO.Class import Control.Monad.IO.Class
import Control.Monad.Trans.Resource import Control.Monad.Trans.Resource
import qualified Data.Vector as V import qualified Data.Vector as V
import Linear (V2)
import qualified SDL hiding (V2) import qualified SDL hiding (V2)
import qualified SDL.Video.Vulkan as SDL import qualified SDL.Video.Vulkan as SDL
import Foreign.C.Types (CInt)
import Foreign.Ptr import Foreign.Ptr
import qualified Vulkan.Core10 as Vk import qualified Vulkan.Core10 as Vk
import qualified Vulkan.Extensions.VK_KHR_swapchain as Khr import qualified Vulkan.Extensions.VK_KHR_swapchain as Khr
@ -26,10 +28,14 @@ initEngine
:: (MonadResource m, MonadFail m) :: (MonadResource m, MonadFail m)
=> m => m
( SDL.Window ( SDL.Window
, V2 CInt
, Vk.Device , Vk.Device
, Khr.SwapchainKHR , Khr.SwapchainKHR
, Vk.Queue , Vk.Queue
, V.Vector Vk.CommandBuffer , V.Vector Vk.CommandBuffer
, Vk.Framebuffer
, V.Vector Vk.Pipeline
, Vk.RenderPass
, Vk.Fence , Vk.Fence
, Vk.Semaphore , Vk.Semaphore
, Vk.Semaphore , Vk.Semaphore
@ -68,10 +74,14 @@ initVulkan
=> SDL.Window => SDL.Window
-> m -> m
( SDL.Window ( SDL.Window
, V2 CInt
, Vk.Device , Vk.Device
, Khr.SwapchainKHR , Khr.SwapchainKHR
, Vk.Queue , Vk.Queue
, V.Vector Vk.CommandBuffer , V.Vector Vk.CommandBuffer
, Vk.Framebuffer
, V.Vector Vk.Pipeline
, Vk.RenderPass
, Vk.Fence , Vk.Fence
, Vk.Semaphore , Vk.Semaphore
, Vk.Semaphore , Vk.Semaphore
@ -96,8 +106,8 @@ initVulkan window = do
(swapchain, surfaceFormat) <- (swapchain, surfaceFormat) <-
createSwapchain vulkanSurface surfaceFormats dimensions vulkanLogicalDevice createSwapchain vulkanSurface surfaceFormats dimensions vulkanLogicalDevice
imageViews <- getImageViewHandles swapchain surfaceFormat vulkanLogicalDevice imageViews <- getImageViewHandles swapchain surfaceFormat vulkanLogicalDevice
vertexShader <- loadShader vulkanLogicalDevice "shadersrc/shader.vert" vertexShader <- loadShader vulkanLogicalDevice "shadersrc/shader.vert" "vert"
fragmentShader <- loadShader vulkanLogicalDevice "shadersrc/shader.frag" fragmentShader <- loadShader vulkanLogicalDevice "shadersrc/shader.frag" "frag"
(pipelines, renderPass) <- (pipelines, renderPass) <-
createGraphicsPipelines createGraphicsPipelines
vulkanLogicalDevice vulkanLogicalDevice
@ -117,10 +127,14 @@ initVulkan window = do
return return
( window ( window
, dimensions
, vulkanLogicalDevice , vulkanLogicalDevice
, swapchain , swapchain
, graphicsQueue , graphicsQueue
, commandBuffer , commandBuffer
, frameBuffer
, pipelines
, renderPass
, inFlightFence , inFlightFence
, imageAvailableSemaphore , imageAvailableSemaphore
, renderFinishedSemaphore , renderFinishedSemaphore

View File

@ -22,7 +22,7 @@ import Draw (drawFrame)
main :: IO () main :: IO ()
main = runResourceT $ do main = runResourceT $ do
(window, logicalDevice, swapchain, graphicsQueue, commandBuffer, inFlightFence, imageAvailableSemaphore, renderFinishedSemaphore) <- initEngine (window, dimensions, logicalDevice, swapchain, graphicsQueue, commandBuffer, framebuffer, pipelines, renderPass, inFlightFence, imageAvailableSemaphore, renderFinishedSemaphore) <- initEngine
SDL.showWindow window SDL.showWindow window
@ -40,6 +40,10 @@ main = runResourceT $ do
swapchain swapchain
graphicsQueue graphicsQueue
(V.head commandBuffer) (V.head commandBuffer)
renderPass
framebuffer
dimensions
(V.head pipelines)
inFlightFence inFlightFence
imageAvailableSemaphore imageAvailableSemaphore
renderFinishedSemaphore renderFinishedSemaphore
@ -55,6 +59,8 @@ main = runResourceT $ do
evs evs
) )
Vk.deviceWaitIdle logicalDevice
createBufferView createBufferView
:: (MonadResource m) :: (MonadResource m)
=> Vk.Device => Vk.Device

View File

@ -38,7 +38,6 @@ executable vulkan-tutorial
, sdl2 , sdl2
, vulkan , vulkan
, vulkan-utils , vulkan-utils
, VulkanMemoryAllocator
, linear , linear
, monad-loops , monad-loops
, stm , stm