vulkan-tutorial/src/Textures.hs

183 lines
5.2 KiB
Haskell

{-# 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.Reader
import Control.Monad.Trans.Resource
import qualified Data.Map.Strict as M
import qualified Data.Vector as V
import Foreign hiding (void)
import qualified Control.Concurrent.STM as STM
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
import Image
loadImageFromFile
:: (MonadResource m, MonadIO m)
=> VMA.Allocator
-> UploadContext
-> Vk.Queue
-> Vk.Device
-> FilePath
-> m AllocatedImage
loadImageFromFile allocator uploadContext queue device 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
allocator
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 allocator dImgCreateInfo dImgAllocCreateInfo allocate
immediateSubmit
uploadContext
queue
device
(\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
}
loadImages
:: (MonadResource m, MonadReader ReadState m)
=> VMA.Allocator
-> UploadContext
-> Vk.Queue
-> Vk.Device
-> m ()
loadImages allocator uploadContext queue device = do
loadedImage <- loadImageFromFile allocator uploadContext queue device "assets/textures/bricks.png"
let imageInfo = imageviewCreate (image loadedImage) Vk.FORMAT_R8G8B8A8_SRGB Vk.IMAGE_ASPECT_COLOR_BIT
imageView <- snd <$> Vk.withImageView device imageInfo Nothing allocate
let texture = Texture
{ textureImage = loadedImage
, textureImageView = imageView
}
textureLib <- asks textureLibrary
void $ liftIO $ STM.atomically $ do
texMap <- STM.readTMVar textureLib
let newMap = M.insert "bricks" texture texMap
STM.swapTMVar textureLib newMap