From a9715e1767dad88e6448faf889d994dc7ce40b9f Mon Sep 17 00:00:00 2001 From: nek0 Date: Wed, 13 Jul 2022 19:29:38 +0200 Subject: [PATCH] add the module --- src/CommandBuffer.hs | 122 +++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 122 insertions(+) create mode 100644 src/CommandBuffer.hs diff --git a/src/CommandBuffer.hs b/src/CommandBuffer.hs new file mode 100644 index 0000000..0f81af8 --- /dev/null +++ b/src/CommandBuffer.hs @@ -0,0 +1,122 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE DataKinds #-} +module CommandBuffer where + +import Control.Monad +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 Foreign.C.Types (CInt) +import Linear +import qualified SDL hiding (V2) +import qualified Control.Concurrent.STM as STM +import qualified Vulkan as Vk +import qualified Vulkan.Zero as Vk + +-- internal imports + +import Devices +import qualified Vulkan.Dynamic as Vk + +createCommandPool + :: (MonadResource m) + => Vk.PhysicalDevice + -> Vk.Device + -> m Vk.CommandPool +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 + + snd <$> allocate + (Vk.createCommandPool logicalDevice poolCreateInfo Nothing) + (\commandPool -> do + putStrLn "destroying comman pool" + Vk.destroyCommandPool logicalDevice commandPool Nothing + ) + +createCommandBuffer + :: (MonadResource m) + => Vk.CommandPool + -> Vk.Device + -> m (V.Vector Vk.CommandBuffer) +createCommandBuffer commandPool logicalDevice = do + + let commandBufferAllocationInfo = Vk.zero + { Vk.commandPool = commandPool + , Vk.level = Vk.COMMAND_BUFFER_LEVEL_PRIMARY + , Vk.commandBufferCount = 1 + } + + 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.singleton (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 = 0 + } + 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