{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DuplicateRecordFields #-} module Draw where import qualified Control.Concurrent.STM as STM 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 -- internal imports import CommandBuffer import Types import Control.Monad.IO.Class (MonadIO(liftIO)) drawFrame :: (MonadResource m) => EngineData -> STM.TMVar Bool -> m () drawFrame engineData switch = do 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) <> ", frame buffers " <> show (V.length $ engineFramebuffers engineData) ) 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) switchState <- liftIO $ STM.atomically $ STM.readTMVar switch -- liftIO $ putStrLn "recording command buffer" recordCommandBuffer (engineCommandBuffers engineData V.! fromIntegral index) (engineRenderPass engineData) (engineFramebuffers engineData V.! fromIntegral index) (engineWindowDimensions engineData) (if switchState then redEnginePipelines engineData V.! fromIntegral index else rainbowEnginePipelines engineData V.! fromIntegral index ) 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"