vulkan-tutorial/src/CommandBuffer.hs

151 lines
4.2 KiB
Haskell

{-# 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
import GHC.IO.Handle.Text (commitBuffer')
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 comman pool"
Vk.destroyCommandPool logicalDevice commandPool Nothing
)
return (commandPool, graphicsQueue)
createCommandBuffer
:: (MonadResource m)
=> Vk.Device
-> Vk.CommandPool
-> m (V.Vector Vk.CommandBuffer)
createCommandBuffer logicalDevice commandPool = 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.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 = 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
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)