init textures

This commit is contained in:
nek0 2023-05-14 18:50:02 +02:00
parent fa4f2d6838
commit 1f9434b06c
3 changed files with 150 additions and 0 deletions

147
src/Textures.hs Normal file
View file

@ -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
}

View file

@ -44,6 +44,7 @@ data EngineData = EngineData
, engineSceneParameters :: GPUSceneData , engineSceneParameters :: GPUSceneData
, engineUploadContext :: UploadContext , engineUploadContext :: UploadContext
} }
deriving (Show)
data AllocatedBuffer = AllocatedBuffer data AllocatedBuffer = AllocatedBuffer
{ allocatedBuffer :: Vk.Buffer { allocatedBuffer :: Vk.Buffer

View file

@ -35,6 +35,7 @@ executable vulkan-tutorial
Mesh Mesh
Image Image
Sync Sync
Textures
Types Types
Util Util
@ -55,6 +56,7 @@ executable vulkan-tutorial
, resourcet , resourcet
, mtl , mtl
, containers , containers
, JuicyPixels
hs-source-dirs: src hs-source-dirs: src
default-language: Haskell2010 default-language: Haskell2010
ghc-options: -Wall ghc-options: -Wall