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
vulkanTutorial = pkgs.haskellPackages.callCabal2nix "vulkan-tutorial" (gitignore ./.) {};
gitignore = src: pkgs.nix-gitignore.gitignoreSource [] src;
hpkgs = pkgs.haskellPackages.override {
overrides = final: prev: {
vulkanTutorial = vulkanTutorial;
};
};
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
import Devices
import GHC.IO.Handle.Text (commitBuffer')
createCommandPool
:: (MonadResource m)
@ -85,7 +86,7 @@ recordCommandBuffer commandBuffer renderPass frameBuffer (V2 width height) graph
, 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
@ -118,6 +119,7 @@ recordCommandBuffer commandBuffer renderPass frameBuffer (V2 width height) graph
Vk.cmdEndRenderPass commandBuffer
Vk.endCommandBuffer commandBuffer
createSyncObjects
:: (MonadResource m, MonadFail m)
@ -138,6 +140,11 @@ createSyncObjects logicalDevice = do
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)

View File

@ -153,7 +153,7 @@ createSwapchain surface surfaceFormats windowDimension logicalDevice = do
(\(V2 w h) -> Vk.Extent2D (fromIntegral w) (fromIntegral h)) windowDimension
, Vk.imageArrayLayers = 1
, 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.compositeAlpha = Vk.COMPOSITE_ALPHA_OPAQUE_BIT_KHR
, Vk.clipped = True

View File

@ -5,11 +5,16 @@ module Draw where
import Control.Monad
import Control.Monad.Trans.Resource
import qualified Data.Vector as V
import Foreign.C.Types (CInt)
import Linear (V2(..))
import qualified Vulkan.Core10 as Vk
import qualified Vulkan.Extensions.VK_KHR_swapchain as Khr
import qualified Vulkan.CStruct.Extends as Vk
import qualified Vulkan.Zero as Vk
-- internal imports
import CommandBuffer
drawFrame
:: (MonadResource m)
@ -17,6 +22,10 @@ drawFrame
-> Khr.SwapchainKHR
-> Vk.Queue
-> Vk.CommandBuffer
-> Vk.RenderPass
-> Vk.Framebuffer
-> V2 CInt
-> Vk.Pipeline
-> Vk.Fence
-> Vk.Semaphore
-> Vk.Semaphore
@ -26,6 +35,10 @@ drawFrame
swapchain
graphicsQueue
commandBuffer
renderPass
framebuffer
dimensions
pipeline
inFlightFence
imageAvailableSemaphore
renderFinishedSemaphore
@ -37,13 +50,15 @@ drawFrame
Vk.resetFences logicalDevice fences
(imageResult, index) <-
Khr.acquireNextImageKHR logicalDevice swapchain maxBound imageAvailableSemaphore inFlightFence
Khr.acquireNextImageKHR logicalDevice swapchain maxBound imageAvailableSemaphore Vk.NULL_HANDLE
unless (imageResult == Vk.SUCCESS) $
error "drawFrame: Failed acquiring next image from swapchain"
Vk.resetCommandBuffer commandBuffer (Vk.CommandBufferResetFlagBits 0)
recordCommandBuffer commandBuffer renderPass framebuffer dimensions pipeline
let submitInfo = Vk.zero
{ Vk.waitSemaphores = V.singleton imageAvailableSemaphore
, 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.Trans.Resource
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 Foreign.C.Types (CInt)
import qualified Vulkan.Core10 as Vk
import qualified Vulkan.Zero as Vk
import qualified Vulkan.CStruct.Extends as Vk
import qualified Vulkan.Utils.ShaderQQ.GLSL.Shaderc as Vk
loadShader
:: (MonadResource m)
=> Vk.Device
-> FilePath
-> String
-> m Vk.ShaderModule
loadShader logicalDevice shaderPath = do
loadShader logicalDevice shaderPath stage = do
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
{ Vk.code = shaderSource
{ Vk.code = shader
}
snd <$> allocate
@ -161,13 +176,16 @@ createGraphicsPipelines
, Vk.colorAttachments = V.singleton colorAttachmentReference
}
subpassDependency = Vk.zero
{ Vk.srcSubpass = Vk.SUBPASS_EXTERNAL
, Vk.dstSubpass = 0
, Vk.srcStageMask = Vk.PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT
{ Vk.srcSubpass = Vk.SUBPASS_EXTERNAL
, Vk.dstSubpass = 0
, 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.dstAccessMask =
Vk.ACCESS_COLOR_ATTACHMENT_READ_BIT .|. Vk.ACCESS_COLOR_ATTACHMENT_WRITE_BIT
}
renderPassCreateInfo = Vk.zero
{ Vk.attachments = V.singleton colorAttachmentDescription
{ Vk.attachments = V.replicate 4 colorAttachmentDescription
, Vk.subpasses = V.singleton subpassDescriptor
, Vk.dependencies = V.singleton subpassDependency
} :: Vk.RenderPassCreateInfo '[]

View File

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

View File

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

View File

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