diff --git a/dear-imgui.cabal b/dear-imgui.cabal index 1cf90a1..fb65d7c 100644 --- a/dear-imgui.cabal +++ b/dear-imgui.cabal @@ -350,3 +350,5 @@ executable vulkan ^>= 3.9 , vulkan-utils ^>= 0.4.1 + , VulkanMemoryAllocator + , JuicyPixels diff --git a/examples/vulkan/Main.hs b/examples/vulkan/Main.hs index 1fafa47..7e799bf 100644 --- a/examples/vulkan/Main.hs +++ b/examples/vulkan/Main.hs @@ -24,7 +24,9 @@ import Control.Arrow import Control.Exception ( throw ) import Control.Monad - ( unless, void ) + ( unless, void, when ) +import Data.Bits + ( (.|.) ) import Data.Foldable ( traverse_ ) import Data.String @@ -62,11 +64,13 @@ import qualified Data.Vector as Boxed ( Vector ) import qualified Data.Vector as Boxed.Vector ( (!), head, singleton, unzip ) +import qualified Data.Vector.Storable as Storable.Vector -- vulkan import qualified Vulkan -import qualified Vulkan.Exception as Vulkan -import qualified Vulkan.Zero as Vulkan +import qualified Vulkan.Exception as Vulkan +import qualified Vulkan.Zero as Vulkan +import qualified VulkanMemoryAllocator as VMA -- dear-imgui import Attachments @@ -76,6 +80,13 @@ import qualified DearImGui as ImGui import qualified DearImGui.Vulkan as ImGui.Vulkan import qualified DearImGui.SDL as ImGui.SDL import qualified DearImGui.SDL.Vulkan as ImGui.SDL.Vulkan +import Util (vmaVulkanFunctions) +import Foreign (Ptr, castPtr, copyBytes, with, withForeignPtr, wordPtrToPtr) +import qualified DearImGui.Raw as ImGui.Raw +import UnliftIO (MonadUnliftIO) +import qualified Vulkan.CStruct.Extends as Vulkan + +import qualified Codec.Picture as Picture -------------------------------------------------------------------------------- @@ -83,8 +94,8 @@ type Handler = LogMessage -> ResourceT IO () deriving via ( ReaderT Handler (ResourceT IO) ) instance MonadResource ( LoggingT LogMessage (ResourceT IO) ) -gui :: MonadIO m => m ImGui.DrawData -gui = do +gui :: MonadUnliftIO m => (ImGui.Raw.ImVec2, Ptr ()) -> m ImGui.DrawData +gui texture = do -- Prepare frame ImGui.Vulkan.vulkanNewFrame ImGui.SDL.sdl2NewFrame @@ -92,6 +103,25 @@ gui = do -- Run your windows ImGui.showDemoWindow + ImGui.withWindowOpen "Vulkan demo" do + clicked <- liftIO do + with (fst texture) \sizePtr -> + with (ImGui.Raw.ImVec2 0 0) \uv0Ptr -> + with (ImGui.Raw.ImVec2 1 1) \uv1Ptr -> + with (ImGui.Raw.ImVec4 1 1 1 1) \tintColPtr -> + with (ImGui.Raw.ImVec4 1 1 1 1) \bgColPtr -> + ImGui.Raw.imageButton + (snd texture) + sizePtr + uv0Ptr + uv1Ptr + (-1) + bgColPtr + tintColPtr + + when clicked $ + ImGui.text "clicky click!" + -- Process ImGui state into draw commands ImGui.render @@ -275,6 +305,80 @@ app = do logDebug "Allocating command buffers" commandBuffers <- snd <$> allocatePrimaryCommandBuffers device commandPool imageCount + logDebug "Allocating VMA" + (_key, vma) <- VMA.withAllocator + Vulkan.zero + { VMA.instance' = Vulkan.instanceHandle instance' + , VMA.device = Vulkan.deviceHandle device + , VMA.physicalDevice = Vulkan.physicalDeviceHandle physicalDevice + , VMA.vulkanFunctions = Just $ vmaVulkanFunctions device instance' + } + ResourceT.allocate + + logDebug "Loading image data" + picture <- liftIO (Picture.readImage "Example.png") >>= either error (pure . Picture.convertRGBA8) + + logDebug "Allocating image" + let textureWidth = Picture.imageWidth picture + let textureHeight = Picture.imageHeight picture + + (_key, (image, _imageAllocation, _imageAllocationInfo)) <- VMA.withImage + vma + ( Vulkan.zero + { Vulkan.imageType = Vulkan.IMAGE_TYPE_2D + , Vulkan.mipLevels = 1 + , Vulkan.arrayLayers = 1 + , Vulkan.format = Vulkan.FORMAT_R8G8B8A8_SRGB + , Vulkan.extent = Vulkan.Extent3D (fromIntegral textureWidth) (fromIntegral textureHeight) 1 + , Vulkan.tiling = Vulkan.IMAGE_TILING_OPTIMAL + , Vulkan.initialLayout = Vulkan.IMAGE_LAYOUT_UNDEFINED + , Vulkan.usage = Vulkan.IMAGE_USAGE_SAMPLED_BIT .|. Vulkan.IMAGE_USAGE_TRANSFER_DST_BIT + , Vulkan.sharingMode = Vulkan.SHARING_MODE_EXCLUSIVE + , Vulkan.samples = Vulkan.SAMPLE_COUNT_1_BIT + } + ) + ( Vulkan.zero + { VMA.flags = Vulkan.zero + , VMA.usage = VMA.MEMORY_USAGE_GPU_ONLY + , VMA.requiredFlags = Vulkan.MEMORY_PROPERTY_DEVICE_LOCAL_BIT + } + ) + ResourceT.allocate + + let (pictureF, pictureSize) = Storable.Vector.unsafeToForeignPtr0 (Picture.imageData picture) + + let stageBufferCI = Vulkan.zero + { Vulkan.size = fromIntegral pictureSize + , Vulkan.usage = Vulkan.BUFFER_USAGE_TRANSFER_SRC_BIT + , Vulkan.sharingMode = Vulkan.SHARING_MODE_EXCLUSIVE + } + let stageAllocationCI = Vulkan.zero + { VMA.flags = VMA.ALLOCATION_CREATE_MAPPED_BIT + , VMA.usage = VMA.MEMORY_USAGE_CPU_TO_GPU + , VMA.requiredFlags = Vulkan.MEMORY_PROPERTY_HOST_VISIBLE_BIT + } + + (stageKey, (stage, stageAllocation, stageAllocationInfo)) <- VMA.withBuffer + vma + stageBufferCI + stageAllocationCI + ResourceT.allocate + + liftIO $ withForeignPtr pictureF \srcPtr -> + copyBytes (VMA.mappedData stageAllocationInfo) (castPtr srcPtr) pictureSize + + VMA.flushAllocation vma stageAllocation 0 Vulkan.WHOLE_SIZE + + logDebug "Allocating sampler" + (_key, sampler) <- Vulkan.withSampler device Vulkan.zero Nothing ResourceT.allocate + logDebug "Allocating image view" + (_key, imageView) <- createImageView + device + image + Vulkan.IMAGE_VIEW_TYPE_2D + Vulkan.FORMAT_R8G8B8A8_SRGB + Vulkan.IMAGE_ASPECT_COLOR_BIT + ------------------------------------------- -- Initialise Dear ImGui. @@ -308,23 +412,96 @@ app = do logDebug "Creating fence" ( fenceKey, fence ) <- createFence device logDebug "Allocating one-shot command buffer" - ( fontUploadCommandBufferKey, fontUploadCommandBuffer ) <- + ( oneshotCommandBufferKey, oneshotCommandBuffer ) <- second Boxed.Vector.head <$> allocatePrimaryCommandBuffers device commandPool 1 logDebug "Recording one-shot commands" - beginCommandBuffer fontUploadCommandBuffer - _ <- ImGui.Vulkan.vulkanCreateFontsTexture fontUploadCommandBuffer - endCommandBuffer fontUploadCommandBuffer + beginCommandBuffer oneshotCommandBuffer + _ <- ImGui.Vulkan.vulkanCreateFontsTexture oneshotCommandBuffer + + logDebug "Uploading texture" + let textureSubresource = Vulkan.ImageSubresourceRange + { Vulkan.aspectMask = Vulkan.IMAGE_ASPECT_COLOR_BIT + , Vulkan.baseMipLevel = 0 + , Vulkan.levelCount = 1 + , Vulkan.baseArrayLayer = 0 + , Vulkan.layerCount = 1 + } + + let uploadBarrier = Vulkan.zero + { Vulkan.srcAccessMask = Vulkan.zero + , Vulkan.dstAccessMask = Vulkan.ACCESS_TRANSFER_WRITE_BIT + , Vulkan.oldLayout = Vulkan.IMAGE_LAYOUT_UNDEFINED + , Vulkan.newLayout = Vulkan.IMAGE_LAYOUT_TRANSFER_DST_OPTIMAL + , Vulkan.srcQueueFamilyIndex = Vulkan.QUEUE_FAMILY_IGNORED + , Vulkan.dstQueueFamilyIndex = Vulkan.QUEUE_FAMILY_IGNORED + , Vulkan.image = image + , Vulkan.subresourceRange = textureSubresource + } :: Vulkan.ImageMemoryBarrier '[] + Vulkan.cmdPipelineBarrier + oneshotCommandBuffer + Vulkan.PIPELINE_STAGE_TOP_OF_PIPE_BIT + Vulkan.PIPELINE_STAGE_TRANSFER_BIT + Vulkan.zero + mempty + mempty + (Boxed.Vector.singleton $ Vulkan.SomeStruct uploadBarrier) + + Vulkan.cmdCopyBufferToImage oneshotCommandBuffer stage image Vulkan.IMAGE_LAYOUT_TRANSFER_DST_OPTIMAL $ + Boxed.Vector.singleton Vulkan.BufferImageCopy + { Vulkan.bufferOffset = 0 + , Vulkan.bufferRowLength = Vulkan.zero + , Vulkan.bufferImageHeight = Vulkan.zero + , Vulkan.imageSubresource = Vulkan.ImageSubresourceLayers + { aspectMask = Vulkan.IMAGE_ASPECT_COLOR_BIT + , mipLevel = 0 + , baseArrayLayer = 0 + , layerCount = 1 + } + , Vulkan.imageOffset = Vulkan.zero + , Vulkan.imageExtent = Vulkan.Extent3D + { width = fromIntegral textureWidth + , height = fromIntegral textureHeight + , depth = 1 + } + } + + logDebug "Transitioning texture" + let transitionBarrier = Vulkan.zero + { Vulkan.srcAccessMask = Vulkan.ACCESS_TRANSFER_WRITE_BIT + , Vulkan.dstAccessMask = Vulkan.ACCESS_SHADER_READ_BIT + , Vulkan.oldLayout = Vulkan.IMAGE_LAYOUT_TRANSFER_DST_OPTIMAL + , Vulkan.newLayout = Vulkan.IMAGE_LAYOUT_SHADER_READ_ONLY_OPTIMAL + , Vulkan.srcQueueFamilyIndex = Vulkan.QUEUE_FAMILY_IGNORED + , Vulkan.dstQueueFamilyIndex = Vulkan.QUEUE_FAMILY_IGNORED + , Vulkan.image = image + , Vulkan.subresourceRange = textureSubresource + } :: Vulkan.ImageMemoryBarrier '[] + Vulkan.cmdPipelineBarrier + oneshotCommandBuffer + Vulkan.PIPELINE_STAGE_TRANSFER_BIT + Vulkan.PIPELINE_STAGE_FRAGMENT_SHADER_BIT + Vulkan.zero + mempty + mempty + (Boxed.Vector.singleton $ Vulkan.SomeStruct transitionBarrier) + + endCommandBuffer oneshotCommandBuffer logDebug "Submitting one-shot commands" - submitCommandBuffer queue fontUploadCommandBuffer [] [] ( Just fence ) + submitCommandBuffer queue oneshotCommandBuffer [] [] ( Just fence ) waitForFences device ( WaitAll [ fence ] ) logDebug "Finished uploading font objects" logDebug "Cleaning up one-shot commands" ImGui.Vulkan.vulkanDestroyFontUploadObjects - traverse_ ResourceT.release [ fenceKey, fontUploadCommandBufferKey ] + traverse_ ResourceT.release [ fenceKey, oneshotCommandBufferKey, stageKey ] + + logDebug "Adding imgui texture" + Vulkan.DescriptorSet ds <- ImGui.Vulkan.vulkanAddTexture sampler imageView Vulkan.IMAGE_LAYOUT_SHADER_READ_ONLY_OPTIMAL + let textureSize = ImGui.Raw.ImVec2 (fromIntegral textureWidth) (fromIntegral textureHeight) + let texture = (textureSize, wordPtrToPtr $ fromIntegral ds) let mainLoop :: AppState m -> m () @@ -364,7 +541,7 @@ app = do beginCommandBuffer commandBuffer cmdBeginRenderPass commandBuffer imGuiRenderPass framebuffer clearValues swapchainExtent - drawData <- gui + drawData <- gui texture ImGui.Vulkan.vulkanRenderDrawData drawData commandBuffer Nothing cmdEndRenderPass commandBuffer diff --git a/examples/vulkan/Util.hs b/examples/vulkan/Util.hs index afdf64e..176b47b 100644 --- a/examples/vulkan/Util.hs +++ b/examples/vulkan/Util.hs @@ -1,4 +1,7 @@ {-# LANGUAGE BlockArguments #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} module Util where @@ -12,6 +15,10 @@ import Data.Functor.Identity ( Identity(..) ) import Data.Traversable ( for ) +#if MIN_VERSION_VulkanMemoryAllocator(0,8,0) +import Foreign + ( castFunPtr ) +#endif -- transformers import Control.Monad.Trans.State.Strict @@ -19,6 +26,16 @@ import Control.Monad.Trans.State.Strict import Control.Monad.Trans.Writer.Strict ( runWriter, tell ) +-- vulkan +import qualified Vulkan +#if MIN_VERSION_VulkanMemoryAllocator(0,8,0) +import qualified Vulkan.Dynamic as VkDynamic +#endif +import Vulkan.Zero (zero) + +-- VulkanMemoryAllocator +import qualified VulkanMemoryAllocator as VMA + --------------------------------------------------------------- iunzipWith @@ -38,3 +55,19 @@ ifor i0 upd ta f = (`evalState` i0) . getCompose $ result where result :: Compose (State i) f (t b) result = for ta \ a -> ( coerce ( \ i -> ( f i a, upd i ) ) ) + +vmaVulkanFunctions + :: Vulkan.Device + -> Vulkan.Instance + -> VMA.VulkanFunctions +#if MIN_VERSION_VulkanMemoryAllocator(0,8,0) +vmaVulkanFunctions Vulkan.Device{deviceCmds} Vulkan.Instance{instanceCmds} = + zero + { VMA.vkGetInstanceProcAddr = + castFunPtr $ VkDynamic.pVkGetInstanceProcAddr instanceCmds + , VMA.vkGetDeviceProcAddr = + castFunPtr $ VkDynamic.pVkGetDeviceProcAddr deviceCmds + } +#else +vmaVulkanFunctions _device _instance = zero +#endif diff --git a/src/DearImGui/Vulkan.hs b/src/DearImGui/Vulkan.hs index 600da63..c315a6e 100644 --- a/src/DearImGui/Vulkan.hs +++ b/src/DearImGui/Vulkan.hs @@ -19,6 +19,8 @@ module DearImGui.Vulkan , vulkanCreateFontsTexture , vulkanDestroyFontUploadObjects , vulkanSetMinImageCount + + , vulkanAddTexture ) where @@ -32,7 +34,7 @@ import Foreign.Marshal.Alloc import Foreign.Ptr ( FunPtr, Ptr, freeHaskellFunPtr, nullPtr ) import Foreign.Storable - ( Storable(poke) ) + ( poke ) -- inline-c import qualified Language.C.Inline as C @@ -92,7 +94,7 @@ withVulkan initInfo renderPass action = ( \ ( _, initResult ) -> action initResult ) -- | Wraps @ImGui_ImplVulkan_Init@. --- +-- -- Use 'vulkanShutdown' to clean up on shutdown. -- Prefer using 'withVulkan' when possible, as it automatically handles cleanup. vulkanInit :: MonadIO m => InitInfo -> Vulkan.RenderPass -> m (FunPtr (Vulkan.Result -> IO ()), Bool) @@ -184,3 +186,16 @@ vulkanDestroyFontUploadObjects = liftIO do vulkanSetMinImageCount :: MonadIO m => Word32 -> m () vulkanSetMinImageCount minImageCount = liftIO do [C.exp| void { ImGui_ImplVulkan_SetMinImageCount($(uint32_t minImageCount)); } |] + +-- | Wraps @ImGui_ImplVulkan_AddTexture@. +vulkanAddTexture :: MonadIO m => Vulkan.Sampler -> Vulkan.ImageView -> Vulkan.ImageLayout -> m Vulkan.DescriptorSet +vulkanAddTexture sampler imageView imageLayout = liftIO do + [C.block| + VkDescriptorSet { + return ImGui_ImplVulkan_AddTexture( + $(VkSampler sampler), + $(VkImageView imageView), + $(VkImageLayout imageLayout) + ); + } + |] diff --git a/src/DearImGui/Vulkan/Types.hs b/src/DearImGui/Vulkan/Types.hs index e4fefb7..3200d9d 100644 --- a/src/DearImGui/Vulkan/Types.hs +++ b/src/DearImGui/Vulkan/Types.hs @@ -31,6 +31,10 @@ vulkanTypesTable = Map.fromList , ( C.TypeName "VkRenderPass" , [t| Vulkan.RenderPass |] ) , ( C.TypeName "VkResult" , [t| Vulkan.Result |] ) , ( C.TypeName "VkSampleCountFlagBits", [t| Vulkan.SampleCountFlagBits |] ) + , ( C.TypeName "VkSampler" , [t| Vulkan.Sampler |] ) + , ( C.TypeName "VkImageView" , [t| Vulkan.ImageView |] ) + , ( C.TypeName "VkImageLayout" , [t| Vulkan.ImageLayout |] ) + , ( C.TypeName "VkDescriptorSet" , [t| Vulkan.DescriptorSet |] ) ] vulkanCtx :: C.Context