almost drawing, just fix shaders

This commit is contained in:
nek0 2022-07-14 07:02:10 +02:00
parent bfb3b1a814
commit 83950010ac
7 changed files with 174 additions and 38 deletions

View File

@ -19,7 +19,7 @@ createCommandPool
:: (MonadResource m)
=> Vk.PhysicalDevice
-> Vk.Device
-> m Vk.CommandPool
-> m (Vk.CommandPool, Vk.Queue)
createCommandPool physicalDevice logicalDevice = do
queueFamilyIndex <- getQueueFamily physicalDevice Vk.QUEUE_GRAPHICS_BIT
@ -29,19 +29,23 @@ createCommandPool physicalDevice logicalDevice = do
, Vk.queueFamilyIndex = queueFamilyIndex
} :: Vk.CommandPoolCreateInfo
snd <$> allocate
graphicsQueue <- Vk.getDeviceQueue logicalDevice queueFamilyIndex 0
commandPool <- snd <$> allocate
(Vk.createCommandPool logicalDevice poolCreateInfo Nothing)
(\commandPool -> do
putStrLn "destroying comman pool"
Vk.destroyCommandPool logicalDevice commandPool Nothing
)
return (commandPool, graphicsQueue)
createCommandBuffer
:: (MonadResource m)
=> Vk.CommandPool
-> Vk.Device
=> Vk.Device
-> Vk.CommandPool
-> m (V.Vector Vk.CommandBuffer)
createCommandBuffer commandPool logicalDevice = do
createCommandBuffer logicalDevice commandPool = do
let commandBufferAllocationInfo = Vk.zero
{ Vk.commandPool = commandPool
@ -123,6 +127,8 @@ createSyncObjects logicalDevice = do
let semaphoreCreateInfo = Vk.zero
fenceCreateInfo = Vk.zero
{ Vk.flags = Vk.FENCE_CREATE_SIGNALED_BIT
} :: Vk.FenceCreateInfo '[]
[imageAvailableSemaphore, renderFinishedSemaphore] <- replicateM 2
(snd <$> allocate
@ -134,4 +140,4 @@ createSyncObjects logicalDevice = do
)
inFlightFence <- Vk.createFence logicalDevice fenceCreateInfo Nothing
return (imageAvailableSemaphore, renderFinishedSemaphore,inFlightFence)
return (imageAvailableSemaphore, renderFinishedSemaphore, inFlightFence)

65
src/Draw.hs Normal file
View File

@ -0,0 +1,65 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DuplicateRecordFields #-}
module Draw where
import Control.Monad
import Control.Monad.Trans.Resource
import qualified Data.Vector as V
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
drawFrame
:: (MonadResource m)
=> Vk.Device
-> Khr.SwapchainKHR
-> Vk.Queue
-> Vk.CommandBuffer
-> Vk.Fence
-> Vk.Semaphore
-> Vk.Semaphore
-> m ()
drawFrame
logicalDevice
swapchain
graphicsQueue
commandBuffer
inFlightFence
imageAvailableSemaphore
renderFinishedSemaphore
= do
let fences = V.singleton inFlightFence
void $ Vk.waitForFences logicalDevice fences True maxBound
Vk.resetFences logicalDevice fences
(imageResult, index) <-
Khr.acquireNextImageKHR logicalDevice swapchain maxBound imageAvailableSemaphore inFlightFence
unless (imageResult == Vk.SUCCESS) $
error "drawFrame: Failed acquiring next image from swapchain"
Vk.resetCommandBuffer commandBuffer (Vk.CommandBufferResetFlagBits 0)
let submitInfo = Vk.zero
{ Vk.waitSemaphores = V.singleton imageAvailableSemaphore
, Vk.waitDstStageMask = V.singleton Vk.PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT
, Vk.commandBuffers = V.singleton (Vk.commandBufferHandle commandBuffer)
, Vk.signalSemaphores = V.singleton renderFinishedSemaphore
}
Vk.queueSubmit graphicsQueue (V.singleton (Vk.SomeStruct submitInfo)) inFlightFence
let presentInfo = Vk.zero
{ Khr.waitSemaphores = V.singleton renderFinishedSemaphore
, Khr.swapchains = V.singleton swapchain
, Khr.imageIndices = V.singleton index
}
presentResult <- Khr.queuePresentKHR graphicsQueue presentInfo
unless (presentResult == Vk.SUCCESS) $
error "drawFrame: presentation failed"

View File

@ -4,26 +4,21 @@
module Framebuffers where
import Linear
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.Vector as V
import Foreign.C.Types (CInt)
import qualified Vulkan as Vk
import qualified Vulkan.Zero as Vk
import qualified Vulkan.CStruct.Extends as Vk
createFramebuffer
:: (MonadResource m)
=> Vk.RenderPass
=> Vk.Device
-> Vk.RenderPass
-> V.Vector Vk.ImageView
-> V2 CInt
-> Vk.Device
-> m Vk.Framebuffer
createFramebuffer renderPass swapchainImageViews (V2 swapchainWidth swapcheinHeight) logicalDevice
createFramebuffer logicalDevice renderPass swapchainImageViews (V2 swapchainWidth swapcheinHeight)
= do
let framebufferCreateInfo = Vk.zero

View File

@ -11,7 +11,7 @@ import Data.Bits
import qualified Data.ByteString as BS
import qualified Data.Vector as V
import Foreign.C.Types (CInt)
import qualified Vulkan as Vk
import qualified Vulkan.Core10 as Vk
import qualified Vulkan.Zero as Vk
import qualified Vulkan.CStruct.Extends as Vk
@ -36,20 +36,20 @@ loadShader logicalDevice shaderPath = do
createGraphicsPipelines
:: (MonadResource m)
=> Vk.ShaderModule
=> Vk.Device
-> Vk.ShaderModule
-> Vk.ShaderModule
-> BS.ByteString
-> V2 CInt
-> Vk.Format
-> Vk.Device
-> m (V.Vector Vk.Pipeline)
-> m (V.Vector Vk.Pipeline, Vk.RenderPass)
createGraphicsPipelines
logicalDevice
vertexShaderModule
fragmentShaderModule
stageName
(V2 width height)
swapchainImageFormat
logicalDevice
= do
let vertexShaderStageCreateInfo = Vk.zero
@ -160,10 +160,16 @@ createGraphicsPipelines
{ Vk.pipelineBindPoint = Vk.PIPELINE_BIND_POINT_GRAPHICS
, 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.srcAccessMask = Vk.ACCESS_COLOR_ATTACHMENT_WRITE_BIT
}
renderPassCreateInfo = Vk.zero
{ Vk.attachments = V.singleton colorAttachmentDescription
, Vk.subpasses = V.singleton subpassDescriptor
, Vk.dependencies = V.empty
, Vk.dependencies = V.singleton subpassDependency
} :: Vk.RenderPassCreateInfo '[]
pipelineRenderPass <- snd <$> allocate
@ -190,7 +196,7 @@ createGraphicsPipelines
, Vk.basePipelineIndex = -1
}
snd <$> allocate
pipelines <- snd <$> allocate
(do
(result, pipelines) <- Vk.createGraphicsPipelines
logicalDevice
@ -209,3 +215,5 @@ createGraphicsPipelines
)
pipelines
)
return (pipelines, pipelineRenderPass)

View File

@ -10,16 +10,30 @@ import qualified Data.Vector as V
import qualified SDL hiding (V2)
import qualified SDL.Video.Vulkan as SDL
import Foreign.Ptr
import qualified Vulkan as Vk
import qualified Vulkan.Core10 as Vk
import qualified Vulkan.Extensions.VK_KHR_swapchain as Khr
import qualified Vulkan.Extensions.VK_KHR_surface as Khr
-- internal imports
import Instance
import Devices
import GraphicsPipeline
import Framebuffers
import CommandBuffer
initEngine
:: MonadResource m
=> m (SDL.Window, Vk.Instance, Vk.SurfaceKHR, Vk.SwapchainKHR, V.Vector Vk.ImageView)
:: (MonadResource m, MonadFail m)
=> m
( SDL.Window
, Vk.Device
, Khr.SwapchainKHR
, Vk.Queue
, V.Vector Vk.CommandBuffer
, Vk.Fence
, Vk.Semaphore
, Vk.Semaphore
)
initEngine = do
-- initialize SDL2 with all subsystems
void $ allocate_
@ -46,32 +60,68 @@ initEngine = do
SDL.destroyWindow window
)
-- create vulkan surface and vulkan instance from window
(surface, inst, swapchain, images) <- initVulkan window
return (window, inst, surface, swapchain, images)
-- initialize viúlkan data structures
initVulkan window
initVulkan
:: MonadResource m
:: (MonadResource m, MonadFail m)
=> SDL.Window
-> m (Vk.SurfaceKHR, Vk.Instance, Vk.SwapchainKHR, V.Vector Vk.ImageView)
-> m
( SDL.Window
, Vk.Device
, Khr.SwapchainKHR
, Vk.Queue
, V.Vector Vk.CommandBuffer
, Vk.Fence
, Vk.Semaphore
, Vk.Semaphore
)
initVulkan window = do
vulkanInstance <- createInstance window
(_, vulkanSurface) <- allocate
(Vk.SurfaceKHR <$>
(Khr.SurfaceKHR <$>
SDL.vkCreateSurface window (castPtr (Vk.instanceHandle vulkanInstance))
)
(\vulkanSurface -> do
putStrLn "destroying surface"
Vk.destroySurfaceKHR vulkanInstance vulkanSurface Nothing
Khr.destroySurfaceKHR vulkanInstance vulkanSurface Nothing
)
vulkanPhysicalDevice <- pickPhysicalDevice vulkanInstance
(vulkanLogicalDevice, surfaceFormats) <- createLogicalDevice vulkanPhysicalDevice vulkanSurface
dimensions <- liftIO $ SDL.windowInitialSize <$> SDL.getWindowConfig window
(swapchain, surfaceFormat) <- createSwapchain vulkanSurface surfaceFormats dimensions vulkanLogicalDevice
(swapchain, surfaceFormat) <-
createSwapchain vulkanSurface surfaceFormats dimensions vulkanLogicalDevice
imageViews <- getImageViewHandles swapchain surfaceFormat vulkanLogicalDevice
vertexShader <- loadShader vulkanLogicalDevice "shadersrc/shader.vert"
fragmentShader <- loadShader vulkanLogicalDevice "shadersrc/shader.frag"
(pipelines, renderPass) <-
createGraphicsPipelines
vulkanLogicalDevice
vertexShader
fragmentShader
"main"
dimensions
(Khr.format surfaceFormat)
return (vulkanSurface, vulkanInstance, swapchain, imageViews)
frameBuffer <- createFramebuffer vulkanLogicalDevice renderPass imageViews dimensions
(commandPool, graphicsQueue) <- createCommandPool vulkanPhysicalDevice vulkanLogicalDevice
commandBuffer <- createCommandBuffer vulkanLogicalDevice commandPool
(imageAvailableSemaphore, renderFinishedSemaphore, inFlightFence) <-
createSyncObjects vulkanLogicalDevice
return
( window
, vulkanLogicalDevice
, swapchain
, graphicsQueue
, commandBuffer
, inFlightFence
, imageAvailableSemaphore
, renderFinishedSemaphore
)

View File

@ -8,6 +8,7 @@ import Control.Monad.Loops
import Control.Monad.IO.Class
import Control.Monad.Trans.Resource
import Data.Bits
import qualified Data.Vector as V
import Data.Word
import qualified SDL hiding (V2)
import qualified Control.Concurrent.STM as STM
@ -17,10 +18,11 @@ import qualified Vulkan.Zero as Vk
-- internal imports
import Init
import Draw (drawFrame)
main :: IO ()
main = runResourceT $ do
(window, inst, surface, swapchain, images) <- initEngine
(window, logicalDevice, swapchain, graphicsQueue, commandBuffer, inFlightFence, imageAvailableSemaphore, renderFinishedSemaphore) <- initEngine
SDL.showWindow window
@ -28,17 +30,26 @@ main = runResourceT $ do
quit <- liftIO $ STM.newTMVarIO True
-- main loop
liftIO $ whileM_
(STM.atomically $ STM.readTMVar quit
whileM_
(liftIO $ STM.atomically $ STM.readTMVar quit
)
( do
-- draw
drawFrame
logicalDevice
swapchain
graphicsQueue
(V.head commandBuffer)
inFlightFence
imageAvailableSemaphore
renderFinishedSemaphore
-- poll events
evs <- SDL.pollEvents
evs <- liftIO SDL.pollEvents
-- flip abort condition on window close
mapM_
(\e -> case SDL.eventPayload e of
SDL.WindowClosedEvent _ ->
void $ STM.atomically $ STM.swapTMVar quit False
void $ liftIO $ STM.atomically $ STM.swapTMVar quit False
_ -> return ()
)
evs

View File

@ -30,6 +30,7 @@ executable vulkan-tutorial
GraphicsPipeline
Framebuffers
CommandBuffer
Draw
-- LANGUAGE extensions used by modules in this package.
-- other-extensions: