2022-07-14 05:02:10 +00:00
|
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
{-# LANGUAGE DuplicateRecordFields #-}
|
|
|
|
module Draw where
|
|
|
|
|
2022-10-26 14:52:55 +00:00
|
|
|
import qualified Control.Concurrent.STM as STM
|
2022-07-14 05:02:10 +00:00
|
|
|
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
|
|
|
|
|
2022-07-14 09:02:12 +00:00
|
|
|
-- internal imports
|
|
|
|
|
|
|
|
import CommandBuffer
|
2022-07-16 19:50:22 +00:00
|
|
|
import Types
|
2022-10-26 14:52:55 +00:00
|
|
|
import Control.Monad.IO.Class (MonadIO(liftIO))
|
2022-07-14 05:02:10 +00:00
|
|
|
|
|
|
|
drawFrame
|
2022-12-03 00:44:06 +00:00
|
|
|
:: (MonadResource m, MonadFail m)
|
2022-07-16 19:50:22 +00:00
|
|
|
=> EngineData
|
2022-12-02 19:34:35 +00:00
|
|
|
-> STM.TMVar Pipelines
|
2022-07-14 05:02:10 +00:00
|
|
|
-> m ()
|
2022-10-26 14:52:55 +00:00
|
|
|
drawFrame engineData switch = do
|
2022-07-16 19:50:22 +00:00
|
|
|
|
|
|
|
unless (all (V.length (engineCommandBuffers engineData) ==)
|
|
|
|
[ V.length (engineCommandBuffers engineData)
|
|
|
|
, V.length (engineFramebuffers engineData)
|
|
|
|
]) $
|
|
|
|
error ("Numbers of elements mismatch: command buffers " <>
|
|
|
|
show (V.length $ engineCommandBuffers engineData) <>
|
2022-10-26 14:52:55 +00:00
|
|
|
", frame buffers " <> show (V.length $ engineFramebuffers engineData)
|
|
|
|
)
|
2022-07-16 19:50:22 +00:00
|
|
|
|
|
|
|
let fences = V.singleton $ engineInFlightFence engineData
|
|
|
|
|
|
|
|
void $ Vk.waitForFences (engineLogicalDevice engineData) fences True maxBound
|
|
|
|
Vk.resetFences (engineLogicalDevice engineData) fences
|
|
|
|
|
|
|
|
(imageResult, index) <-
|
|
|
|
Khr.acquireNextImageKHR
|
|
|
|
(engineLogicalDevice engineData)
|
|
|
|
(engineSwapchain engineData)
|
|
|
|
maxBound
|
|
|
|
(engineImageAvailableSemaphore engineData)
|
|
|
|
Vk.NULL_HANDLE
|
|
|
|
|
|
|
|
unless (imageResult == Vk.SUCCESS) $
|
|
|
|
error "drawFrame: Failed acquiring next image from swapchain"
|
|
|
|
|
|
|
|
-- liftIO $ putStrLn "resetting command buffer"
|
|
|
|
Vk.resetCommandBuffer
|
|
|
|
(engineCommandBuffers engineData V.! fromIntegral index) (Vk.CommandBufferResetFlagBits 0)
|
|
|
|
|
2022-10-26 14:52:55 +00:00
|
|
|
switchState <- liftIO $ STM.atomically $ STM.readTMVar switch
|
|
|
|
|
2022-07-16 19:50:22 +00:00
|
|
|
-- liftIO $ putStrLn "recording command buffer"
|
|
|
|
recordCommandBuffer
|
|
|
|
(engineCommandBuffers engineData V.! fromIntegral index)
|
|
|
|
(engineRenderPass engineData)
|
|
|
|
(engineFramebuffers engineData V.! fromIntegral index)
|
|
|
|
(engineWindowDimensions engineData)
|
2022-12-02 19:34:35 +00:00
|
|
|
(case switchState of
|
|
|
|
Rainbow ->
|
2022-10-26 14:52:55 +00:00
|
|
|
redEnginePipelines engineData V.! fromIntegral index
|
2022-12-02 19:34:35 +00:00
|
|
|
Red ->
|
2022-10-26 14:52:55 +00:00
|
|
|
rainbowEnginePipelines engineData V.! fromIntegral index
|
2022-12-02 19:34:35 +00:00
|
|
|
Green ->
|
|
|
|
meshPipeline engineData V.! fromIntegral index
|
2022-10-26 14:52:55 +00:00
|
|
|
)
|
2022-12-03 00:44:06 +00:00
|
|
|
(case switchState of
|
|
|
|
Green ->
|
|
|
|
Just $ engineMesh engineData
|
|
|
|
_ ->
|
|
|
|
Nothing
|
|
|
|
)
|
2022-07-16 19:50:22 +00:00
|
|
|
|
|
|
|
let submitInfo = Vk.zero
|
|
|
|
{ Vk.waitSemaphores =
|
|
|
|
V.singleton $ engineImageAvailableSemaphore engineData
|
|
|
|
, Vk.waitDstStageMask =
|
|
|
|
V.singleton Vk.PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT
|
|
|
|
, Vk.commandBuffers =
|
|
|
|
V.singleton (Vk.commandBufferHandle $ engineCommandBuffers engineData V.! fromIntegral index)
|
|
|
|
, Vk.signalSemaphores =
|
|
|
|
V.singleton $ engineRenderFinishedSemaphore engineData
|
|
|
|
}
|
|
|
|
|
|
|
|
-- liftIO $ putStrLn "submitting to queue"
|
|
|
|
Vk.queueSubmit
|
|
|
|
(engineQueue engineData)
|
|
|
|
(V.singleton (Vk.SomeStruct submitInfo))
|
|
|
|
(engineInFlightFence engineData)
|
|
|
|
|
|
|
|
let presentInfo = Vk.zero
|
|
|
|
{ Khr.waitSemaphores = V.singleton $ engineRenderFinishedSemaphore engineData
|
|
|
|
, Khr.swapchains = V.singleton $ engineSwapchain engineData
|
|
|
|
, Khr.imageIndices = V.singleton index
|
|
|
|
}
|
|
|
|
|
|
|
|
-- liftIO $ putStrLn "presenting queue"
|
|
|
|
presentResult <- Khr.queuePresentKHR (engineQueue engineData) presentInfo
|
|
|
|
|
|
|
|
unless (presentResult == Vk.SUCCESS) $
|
|
|
|
error "drawFrame: presentation failed"
|