diff --git a/src/Textures.hs b/src/Textures.hs new file mode 100644 index 0000000..16bc336 --- /dev/null +++ b/src/Textures.hs @@ -0,0 +1,147 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Textures where + +import qualified Codec.Picture as P +import Control.Monad.IO.Class +import Control.Monad.Trans.Resource +import qualified Data.Vector as V +import qualified Data.Vector.Storable as VS +import Foreign +import qualified Vulkan as Vk +import qualified Vulkan.CStruct.Extends as Vk +import qualified Vulkan.Zero as Vk +import qualified VulkanMemoryAllocator as VMA + +-- internal imports + +import Types +import Memory +import Sync + +loadImageFromFile + :: (MonadResource m, MonadIO m) + => EngineData + -> FilePath + -> m AllocatedImage +loadImageFromFile engineData file = do + + pixels <- liftIO $ either error P.convertRGBA8 <$> P.readImage file + + let texWidth = P.imageWidth pixels + texHeight = P.imageHeight pixels + imageSize = 4 * texWidth * texHeight + imageFormat = Vk.FORMAT_R8G8B8A8_SRGB + + stagingBuffer <- + createAllocatedBuffer + (engineAllocator engineData) + imageSize + Vk.BUFFER_USAGE_TRANSFER_SRC_BIT + VMA.MEMORY_USAGE_CPU_ONLY + + let dataPtr = VMA.mappedData (bufferInfo stagingBuffer) + + liftIO $ V.mapM_ + (\(idx, px) -> + poke + (castPtr dataPtr `plusPtr` (idx * sizeOf px)) + px + ) + (V.zip + (V.fromList [0..]) + (V.convert $ P.imageData pixels) + ) + + let imageExtent = Vk.Extent3D + { width = fromIntegral $ texWidth + , height = fromIntegral $ texHeight + , depth = 1 + } + dImgCreateInfo = Vk.zero + { Vk.format = imageFormat + , Vk.usage = Vk.IMAGE_USAGE_SAMPLED_BIT .|. Vk.IMAGE_USAGE_TRANSFER_DST_BIT + , Vk.extent = imageExtent + } + dImgAllocCreateInfo = Vk.zero + { VMA.usage = VMA.MEMORY_USAGE_GPU_ONLY + } :: VMA.AllocationCreateInfo + + (newImage, allocation, _) <- snd <$> + VMA.withImage (engineAllocator engineData) dImgCreateInfo dImgAllocCreateInfo allocate + + immediateSubmit + (engineUploadContext engineData) + (engineQueue engineData) + (engineLogicalDevice engineData) + (\cmd -> do + let range = Vk.zero + { Vk.aspectMask = Vk.IMAGE_ASPECT_COLOR_BIT + , Vk.baseMipLevel = 0 + , Vk.levelCount = 1 + , Vk.baseArrayLayer = 0 + , Vk.layerCount = 1 + } + imageBarrierToTransfer = V.singleton $ Vk.SomeStruct (Vk.zero + { Vk.oldLayout = Vk.IMAGE_LAYOUT_UNDEFINED + , Vk.newLayout = Vk.IMAGE_LAYOUT_TRANSFER_DST_OPTIMAL + , Vk.image = newImage + , Vk.subresourceRange = range + , Vk.srcAccessMask = bit 0 + , Vk.dstAccessMask = Vk.ACCESS_TRANSFER_WRITE_BIT + } :: Vk.ImageMemoryBarrier '[]) + + Vk.cmdPipelineBarrier + cmd + Vk.PIPELINE_STAGE_TOP_OF_PIPE_BIT + Vk.PIPELINE_STAGE_TRANSFER_BIT + (bit 0) + V.empty + V.empty + imageBarrierToTransfer + + let copyRegion = V.singleton (Vk.zero + { Vk.bufferOffset = 0 + , Vk.bufferRowLength = 0 + , Vk.bufferImageHeight = 0 + , Vk.imageExtent = imageExtent + , Vk.imageSubresource = Vk.zero + { Vk.aspectMask = Vk.IMAGE_ASPECT_COLOR_BIT + , Vk.mipLevel = 0 + , Vk.baseArrayLayer = 0 + , Vk.layerCount = 1 + } :: Vk.ImageSubresourceLayers + } :: Vk.BufferImageCopy) + + Vk.cmdCopyBufferToImage + cmd + (allocatedBuffer stagingBuffer) + newImage + Vk.IMAGE_LAYOUT_TRANSFER_DST_OPTIMAL + copyRegion + + let imageBarrierToReadable = V.singleton $ Vk.SomeStruct (Vk.zero + { Vk.oldLayout = Vk.IMAGE_LAYOUT_TRANSFER_DST_OPTIMAL + , Vk.newLayout = Vk.IMAGE_LAYOUT_SHADER_READ_ONLY_OPTIMAL + , Vk.image = newImage + , Vk.subresourceRange = range + , Vk.srcAccessMask = Vk.ACCESS_TRANSFER_WRITE_BIT + , Vk.dstAccessMask = Vk.ACCESS_SHADER_READ_BIT + } :: Vk.ImageMemoryBarrier '[]) + + Vk.cmdPipelineBarrier + cmd + Vk.PIPELINE_STAGE_TRANSFER_BIT + Vk.PIPELINE_STAGE_FRAGMENT_SHADER_BIT + (bit 0) + V.empty + V.empty + imageBarrierToReadable + ) + + return $ AllocatedImage + { image = newImage + , allocation = allocation + } diff --git a/src/Types.hs b/src/Types.hs index 8c3637e..15e068c 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -44,6 +44,7 @@ data EngineData = EngineData , engineSceneParameters :: GPUSceneData , engineUploadContext :: UploadContext } + deriving (Show) data AllocatedBuffer = AllocatedBuffer { allocatedBuffer :: Vk.Buffer diff --git a/vulkan-tutorial.cabal b/vulkan-tutorial.cabal index 6134990..b0c1026 100644 --- a/vulkan-tutorial.cabal +++ b/vulkan-tutorial.cabal @@ -35,6 +35,7 @@ executable vulkan-tutorial Mesh Image Sync + Textures Types Util @@ -55,6 +56,7 @@ executable vulkan-tutorial , resourcet , mtl , containers + , JuicyPixels hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall