{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE DataKinds #-} module CommandBuffer where import Control.Monad import Control.Monad.Trans.Resource import qualified Data.Vector as V import Foreign.C.Types (CInt) import Linear import qualified Vulkan as Vk import qualified Vulkan.Zero as Vk -- internal imports import Devices createCommandPool :: (MonadResource m) => Vk.PhysicalDevice -> Vk.Device -> m (Vk.CommandPool, Vk.Queue) createCommandPool physicalDevice logicalDevice = do queueFamilyIndex <- getQueueFamily physicalDevice Vk.QUEUE_GRAPHICS_BIT let poolCreateInfo = Vk.zero { Vk.flags = Vk.COMMAND_POOL_CREATE_RESET_COMMAND_BUFFER_BIT , Vk.queueFamilyIndex = queueFamilyIndex } :: Vk.CommandPoolCreateInfo graphicsQueue <- Vk.getDeviceQueue logicalDevice queueFamilyIndex 0 commandPool <- snd <$> allocate (Vk.createCommandPool logicalDevice poolCreateInfo Nothing) (\commandPool -> do putStrLn "destroying command pool" Vk.destroyCommandPool logicalDevice commandPool Nothing ) return (commandPool, graphicsQueue) createCommandBuffer :: (MonadResource m) => Vk.Device -> Vk.CommandPool -> Int -> m (V.Vector Vk.CommandBuffer) createCommandBuffer logicalDevice commandPool number = do let commandBufferAllocationInfo = Vk.zero { Vk.commandPool = commandPool , Vk.level = Vk.COMMAND_BUFFER_LEVEL_PRIMARY , Vk.commandBufferCount = 1 } V.concat <$> replicateM number (Vk.allocateCommandBuffers logicalDevice commandBufferAllocationInfo) recordCommandBuffer :: (MonadResource m) => Vk.CommandBuffer -> Vk.RenderPass -> Vk.Framebuffer -> V2 CInt -> Vk.Pipeline -> m () recordCommandBuffer commandBuffer renderPass frameBuffer (V2 width height) graphicsPipeline = do let commandBufferBeginInfo = Vk.zero { Vk.flags = Vk.COMMAND_BUFFER_USAGE_ONE_TIME_SUBMIT_BIT , Vk.inheritanceInfo = Nothing } Vk.beginCommandBuffer commandBuffer commandBufferBeginInfo let renderPassInfo = Vk.zero { Vk.renderPass = renderPass , Vk.framebuffer = frameBuffer , Vk.renderArea = Vk.Rect2D { offset = Vk.Offset2D { Vk.x = 0 , Vk.y = 0 } , extent = Vk.Extent2D { Vk.width = fromIntegral width , Vk.height = fromIntegral height } } , Vk.clearValues = V.replicate 4 (Vk.Color $ Vk.Float32 0 0 0 1) } Vk.cmdBeginRenderPass commandBuffer renderPassInfo Vk.SUBPASS_CONTENTS_INLINE Vk.cmdBindPipeline commandBuffer Vk.PIPELINE_BIND_POINT_GRAPHICS graphicsPipeline let viewport = Vk.zero { Vk.x = 0 , Vk.y = 0 , Vk.width = fromIntegral width , Vk.height = fromIntegral height , Vk.minDepth = 0 , Vk.maxDepth = 1 } scissor = Vk.Rect2D { Vk.offset = Vk.Offset2D { Vk.x = 0 , Vk.y = 0 } , Vk.extent = Vk.Extent2D { Vk.width = fromIntegral width , Vk.height = fromIntegral height } } Vk.cmdSetViewport commandBuffer 0 (V.singleton viewport) Vk.cmdSetScissor commandBuffer 0 (V.singleton scissor) Vk.cmdDraw commandBuffer 3 1 0 0 Vk.cmdEndRenderPass commandBuffer Vk.endCommandBuffer commandBuffer createSyncObjects :: (MonadResource m, MonadFail m) => Vk.Device -> m (Vk.Semaphore, Vk.Semaphore, Vk.Fence) 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 (Vk.createSemaphore logicalDevice semaphoreCreateInfo Nothing) (\semaphore -> do putStrLn "destroying semaphore" Vk.destroySemaphore logicalDevice semaphore Nothing ) ) inFlightFence <- snd <$> allocate (Vk.createFence logicalDevice fenceCreateInfo Nothing) (\fence -> do putStrLn "destroying fence" Vk.destroyFence logicalDevice fence Nothing ) return (imageAvailableSemaphore, renderFinishedSemaphore, inFlightFence)