vulkan-tutorial/src/Draw.hs

97 lines
2.9 KiB
Haskell
Raw Normal View History

2022-07-14 05:02:10 +00:00
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DuplicateRecordFields #-}
module Draw where
import Control.Monad
2022-07-16 14:36:51 +00:00
import Control.Monad.IO.Class (liftIO)
2022-07-14 05:02:10 +00:00
import Control.Monad.Trans.Resource
import qualified Data.Vector as V
2022-07-14 09:02:12 +00:00
import Foreign.C.Types (CInt)
import Linear (V2(..))
2022-07-14 05:02:10 +00:00
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
2022-07-14 09:02:12 +00:00
-- internal imports
import CommandBuffer
2022-07-14 05:02:10 +00:00
drawFrame
:: (MonadResource m)
=> Vk.Device
-> Khr.SwapchainKHR
-> Vk.Queue
2022-07-16 14:36:51 +00:00
-> V.Vector Vk.CommandBuffer
2022-07-14 09:02:12 +00:00
-> Vk.RenderPass
2022-07-16 14:36:51 +00:00
-> V.Vector Vk.Framebuffer
2022-07-14 09:02:12 +00:00
-> V2 CInt
2022-07-16 14:36:51 +00:00
-> V.Vector Vk.Pipeline
2022-07-14 05:02:10 +00:00
-> Vk.Fence
-> Vk.Semaphore
-> Vk.Semaphore
-> m ()
drawFrame
logicalDevice
swapchain
graphicsQueue
2022-07-16 14:36:51 +00:00
commandBuffers
2022-07-14 09:02:12 +00:00
renderPass
2022-07-16 14:36:51 +00:00
framebuffers
2022-07-14 09:02:12 +00:00
dimensions
2022-07-16 14:36:51 +00:00
pipelines
2022-07-14 05:02:10 +00:00
inFlightFence
imageAvailableSemaphore
renderFinishedSemaphore
= do
2022-07-16 14:36:51 +00:00
unless (all (V.length commandBuffers ==)
[V.length commandBuffers, V.length framebuffers, V.length pipelines]) $
error ("Numbers of elements mismatch: command buffers " <> show (V.length commandBuffers) <>
", frame buffers " <> show (V.length framebuffers) <>
", pipelines " <> show (V.length pipelines))
2022-07-14 05:02:10 +00:00
let fences = V.singleton inFlightFence
void $ Vk.waitForFences logicalDevice fences True maxBound
Vk.resetFences logicalDevice fences
(imageResult, index) <-
2022-07-14 09:02:12 +00:00
Khr.acquireNextImageKHR logicalDevice swapchain maxBound imageAvailableSemaphore Vk.NULL_HANDLE
2022-07-14 05:02:10 +00:00
unless (imageResult == Vk.SUCCESS) $
error "drawFrame: Failed acquiring next image from swapchain"
2022-07-16 14:36:51 +00:00
liftIO $ putStrLn "resetting command buffer"
Vk.resetCommandBuffer (commandBuffers V.! fromIntegral index) (Vk.CommandBufferResetFlagBits 0)
2022-07-14 05:02:10 +00:00
2022-07-16 14:36:51 +00:00
liftIO $ putStrLn "recording command buffer"
recordCommandBuffer
(commandBuffers V.! fromIntegral index)
renderPass
(framebuffers V.! fromIntegral index)
dimensions
(pipelines V.! fromIntegral index)
2022-07-14 09:02:12 +00:00
2022-07-14 05:02:10 +00:00
let submitInfo = Vk.zero
{ Vk.waitSemaphores = V.singleton imageAvailableSemaphore
, Vk.waitDstStageMask = V.singleton Vk.PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT
2022-07-16 14:36:51 +00:00
, Vk.commandBuffers = V.singleton (Vk.commandBufferHandle $ commandBuffers V.! fromIntegral index)
2022-07-14 05:02:10 +00:00
, Vk.signalSemaphores = V.singleton renderFinishedSemaphore
}
2022-07-16 14:36:51 +00:00
liftIO $ putStrLn "submitting to queue"
2022-07-14 05:02:10 +00:00
Vk.queueSubmit graphicsQueue (V.singleton (Vk.SomeStruct submitInfo)) inFlightFence
let presentInfo = Vk.zero
{ Khr.waitSemaphores = V.singleton renderFinishedSemaphore
, Khr.swapchains = V.singleton swapchain
2022-07-16 14:36:51 +00:00
, Khr.imageIndices = V.singleton index
2022-07-14 05:02:10 +00:00
}
2022-07-16 14:36:51 +00:00
liftIO $ putStrLn "presenting queue"
2022-07-14 05:02:10 +00:00
presentResult <- Khr.queuePresentKHR graphicsQueue presentInfo
unless (presentResult == Vk.SUCCESS) $
error "drawFrame: presentation failed"