module Resource.Texture.Ktx1
( load
, loadBytes
, loadKtx1
) where
import RIO
import Codec.Ktx qualified as Ktx1
import Data.ByteString.Unsafe (unsafeUseAsCStringLen)
import Data.Kind (Type)
import Data.Text qualified as Text
import Data.Vector qualified as Vector
import Foreign qualified
import GHC.Stack (withFrozenCallStack)
import UnliftIO.Resource (MonadResource)
import Vulkan.Core10 qualified as Vk
import Vulkan.Utils.FromGL qualified as FromGL
import VulkanMemoryAllocator qualified as VMA
import Engine.Vulkan.Types (HasVulkan(..), MonadVulkan, Queues)
import Resource.Image qualified as Image
import Resource.Source (Source(..))
import Resource.Source qualified as Source
import Resource.Texture (Texture(..), TextureLayers(..))
import Resource.Texture qualified as Texture
load
:: forall (a :: Type) env m
. ( TextureLayers a
, MonadVulkan env m
, MonadResource m
, MonadThrow m
, HasLogFunc env
, Typeable a
, HasCallStack
)
=> Queues Vk.CommandPool
-> Source
-> m (Texture a)
load :: forall a env (m :: * -> *).
(TextureLayers a, MonadVulkan env m, MonadResource m, MonadThrow m,
HasLogFunc env, Typeable a, HasCallStack) =>
Queues CommandPool -> Source -> m (Texture a)
load Queues CommandPool
pool Source
source =
(HasCallStack => m (Texture a)) -> m (Texture a)
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => m (Texture a)) -> m (Texture a))
-> (HasCallStack => m (Texture a)) -> m (Texture a)
forall a b. (a -> b) -> a -> b
$
(ByteString -> m (Texture a)) -> Source -> m (Texture a)
forall a (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, Typeable a,
HasCallStack) =>
(ByteString -> m a) -> Source -> m a
Source.load (Queues CommandPool -> ByteString -> m (Texture a)
forall {k} (a :: k) env (m :: * -> *).
(TextureLayers a, MonadVulkan env m, MonadResource m, MonadThrow m,
HasLogFunc env) =>
Queues CommandPool -> ByteString -> m (Texture a)
loadBytes Queues CommandPool
pool) Source
source
loadBytes
:: ( TextureLayers a
, MonadVulkan env m
, MonadResource m
, MonadThrow m
, HasLogFunc env
)
=> Queues Vk.CommandPool
-> ByteString
-> m (Texture a)
loadBytes :: forall {k} (a :: k) env (m :: * -> *).
(TextureLayers a, MonadVulkan env m, MonadResource m, MonadThrow m,
HasLogFunc env) =>
Queues CommandPool -> ByteString -> m (Texture a)
loadBytes Queues CommandPool
pool ByteString
bytes = do
case ByteString -> Either (ByteOffset, String) Ktx
Ktx1.fromByteString ByteString
bytes of
Left (ByteOffset
offset, String
err) -> do
Utf8Builder -> m ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError (Utf8Builder -> m ()) -> Utf8Builder -> m ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Texture load error: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> String -> Utf8Builder
forall a. IsString a => String -> a
fromString String
err
TextureError -> m (Texture a)
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (TextureError -> m (Texture a)) -> TextureError -> m (Texture a)
forall a b. (a -> b) -> a -> b
$ ByteOffset -> Text -> TextureError
Texture.LoadError ByteOffset
offset (String -> Text
Text.pack String
err)
Right Ktx
ktx1 ->
Queues CommandPool -> Ktx -> m (Texture a)
forall {k} (a :: k) (m :: * -> *) env.
(TextureLayers a, MonadVulkan env m, MonadResource m, MonadThrow m,
HasLogFunc env) =>
Queues CommandPool -> Ktx -> m (Texture a)
loadKtx1 Queues CommandPool
pool Ktx
ktx1
loadKtx1
:: forall a m env
. ( TextureLayers a
, MonadVulkan env m
, MonadResource m
, MonadThrow m
, HasLogFunc env
)
=> Queues Vk.CommandPool
-> Ktx1.Ktx
-> m (Texture a)
loadKtx1 :: forall {k} (a :: k) (m :: * -> *) env.
(TextureLayers a, MonadVulkan env m, MonadResource m, MonadThrow m,
HasLogFunc env) =>
Queues CommandPool -> Ktx -> m (Texture a)
loadKtx1 Queues CommandPool
pool Ktx1.Ktx{Header
header :: Header
header :: Ktx -> Header
header, images :: Ktx -> MipLevels
images=MipLevels
ktxImages} = do
env
context <- m env
forall r (m :: * -> *). MonadReader r m => m r
ask
let vma :: Allocator
vma = env -> Allocator
forall a. HasVulkan a => a -> Allocator
getAllocator env
context
let
skipMips :: Int
skipMips = Int
0
mipsSkipped :: Int
mipsSkipped = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (MipLevels -> Int
forall a. Vector a -> Int
Vector.length MipLevels
ktxImages Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Int
skipMips
images :: MipLevels
images = Int -> MipLevels -> MipLevels
forall a. Int -> Vector a -> Vector a
Vector.drop Int
mipsSkipped MipLevels
ktxImages
mipLevels :: Word32
mipLevels = Header -> Word32
Ktx1.numberOfMipmapLevels Header
header Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
- Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
mipsSkipped
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (MipLevels -> Bool
forall a. Vector a -> Bool
Vector.null MipLevels
images) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
TextureError -> m ()
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (TextureError -> m ()) -> TextureError -> m ()
forall a b. (a -> b) -> a -> b
$ ByteOffset -> Text -> TextureError
Texture.LoadError ByteOffset
0 Text
"At least one image must be present in KTX"
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
mipLevels Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== MipLevels -> Int
forall a. Vector a -> Int
Vector.length MipLevels
images) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
TextureError -> m ()
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (TextureError -> m ()) -> TextureError -> m ()
forall a b. (a -> b) -> a -> b
$ Word32 -> Int -> TextureError
Texture.MipLevelsError Word32
mipLevels (MipLevels -> Int
forall a. Vector a -> Int
Vector.length MipLevels
images)
Format
format <- case Header -> Word32
Ktx1.glInternalFormat Header
header of
Word32
36492 ->
Format -> m Format
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Format
Vk.FORMAT_BC7_SRGB_BLOCK
Word32
other ->
case Word32 -> Maybe Format
forall a. (Eq a, Num a) => a -> Maybe Format
FromGL.internalFormat Word32
other of
Maybe Format
Nothing ->
String -> m Format
forall a. HasCallStack => String -> a
error (String -> m Format) -> String -> m Format
forall a b. (a -> b) -> a -> b
$ String
"Unexpected glInternalFormat: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Word32 -> String
forall a. Show a => a -> String
show Word32
other
Just Format
fmt ->
Format -> m Format
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Format
fmt
Utf8Builder -> m ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> m ()) -> Utf8Builder -> m ()
forall a b. (a -> b) -> a -> b
$ [Utf8Builder] -> Utf8Builder
forall a. Monoid a => [a] -> a
mconcat
[ Utf8Builder
"Loading format "
, Word32 -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display (Word32 -> Utf8Builder) -> Word32 -> Utf8Builder
forall a b. (a -> b) -> a -> b
$ Header -> Word32
Ktx1.glInternalFormat Header
header
, Utf8Builder
" as "
, Format -> Utf8Builder
forall a. Show a => a -> Utf8Builder
displayShow Format
format
]
let
extent :: Extent3D
extent = Vk.Extent3D
{ $sel:width:Extent3D :: Word32
Vk.width = Header -> Word32
Ktx1.pixelWidth Header
header Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`Foreign.shiftR` Int
mipsSkipped
, $sel:height:Extent3D :: Word32
Vk.height = Header -> Word32
Ktx1.pixelHeight Header
header Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`Foreign.shiftR` Int
mipsSkipped
, $sel:depth:Extent3D :: Word32
Vk.depth = Word32 -> Word32 -> Word32
forall a. Ord a => a -> a -> a
max Word32
1 (Word32 -> Word32) -> Word32 -> Word32
forall a b. (a -> b) -> a -> b
$ Header -> Word32
Ktx1.pixelDepth Header
header
}
arrayLayers :: Word32
arrayLayers = Word32 -> Word32 -> Word32
forall a. Ord a => a -> a -> a
max Word32
1 (Word32 -> Word32) -> Word32 -> Word32
forall a b. (a -> b) -> a -> b
$ Header -> Word32
Ktx1.numberOfArrayElements Header
header
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Word32
arrayLayers Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
1) do
Utf8Builder -> m ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError Utf8Builder
"TODO: arrayLayers > 1"
TextureError -> m ()
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (TextureError -> m ()) -> TextureError -> m ()
forall a b. (a -> b) -> a -> b
$ Word32 -> Word32 -> TextureError
Texture.ArrayError Word32
1 Word32
arrayLayers
let
numLayers :: Word32
numLayers = Header -> Word32
Ktx1.numberOfFaces Header
header
mipSizes :: Vector Word32
mipSizes = (MipLevel -> Word32) -> MipLevels -> Vector Word32
forall a b. (a -> b) -> Vector a -> Vector b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
(*) Word32
numLayers (Word32 -> Word32) -> (MipLevel -> Word32) -> MipLevel -> Word32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MipLevel -> Word32
Ktx1.imageSize) MipLevels
images
offsets' :: Vector Word32
offsets' = (Word32 -> Word32 -> Word32)
-> Word32 -> Vector Word32 -> Vector Word32
forall a b. (a -> b -> a) -> a -> Vector b -> Vector a
Vector.scanl' Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
(+) Word32
0 Vector Word32
mipSizes
totalSize :: Word32
totalSize = Vector Word32 -> Word32
forall a. Vector a -> a
Vector.last Vector Word32
offsets'
offsets :: Vector Word32
offsets = Vector Word32 -> Vector Word32
forall a. Vector a -> Vector a
Vector.init Vector Word32
offsets'
Utf8Builder -> m ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> m ()) -> Utf8Builder -> m ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"mipSizes: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Vector Word32 -> Utf8Builder
forall a. Show a => a -> Utf8Builder
displayShow Vector Word32
mipSizes
Utf8Builder -> m ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> m ()) -> Utf8Builder -> m ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"offsets: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Vector Word32 -> Utf8Builder
forall a. Show a => a -> Utf8Builder
displayShow Vector Word32
offsets
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Word32
numLayers Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== forall (a :: k). TextureLayers a => Word32
forall {k} (a :: k). TextureLayers a => Word32
textureLayers @a) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
TextureError -> m ()
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (TextureError -> m ()) -> TextureError -> m ()
forall a b. (a -> b) -> a -> b
$ Word32 -> Word32 -> TextureError
Texture.ArrayError (forall (a :: k). TextureLayers a => Word32
forall {k} (a :: k). TextureLayers a => Word32
textureLayers @a) Word32
numLayers
DstImage
dst <- Queues CommandPool
-> Maybe Text
-> Extent3D
-> Word32
-> Word32
-> Format
-> m DstImage
forall env (m :: * -> *).
(MonadVulkan env m, MonadResource m) =>
Queues CommandPool
-> Maybe Text
-> Extent3D
-> Word32
-> Word32
-> Format
-> m DstImage
Image.allocateDst
Queues CommandPool
pool
Maybe Text
forall a. Maybe a
Nothing
Extent3D
extent
Word32
mipLevels
Word32
numLayers
Format
format
Allocator
-> BufferCreateInfo '[]
-> AllocationCreateInfo
-> (m (Buffer, Allocation, AllocationInfo)
-> ((Buffer, Allocation, AllocationInfo) -> m ())
-> ((Buffer, Allocation, AllocationInfo) -> m (Texture a))
-> m (Texture a))
-> ((Buffer, Allocation, AllocationInfo) -> m (Texture a))
-> m (Texture a)
forall (a :: [*]) (io :: * -> *) r.
(Extendss BufferCreateInfo a, PokeChain a, MonadIO io) =>
Allocator
-> BufferCreateInfo a
-> AllocationCreateInfo
-> (io (Buffer, Allocation, AllocationInfo)
-> ((Buffer, Allocation, AllocationInfo) -> io ()) -> r)
-> r
VMA.withBuffer Allocator
vma (Word32 -> BufferCreateInfo '[]
forall a. Integral a => a -> BufferCreateInfo '[]
Texture.stageBufferCI Word32
totalSize) AllocationCreateInfo
Texture.stageAllocationCI m (Buffer, Allocation, AllocationInfo)
-> ((Buffer, Allocation, AllocationInfo) -> m ())
-> ((Buffer, Allocation, AllocationInfo) -> m (Texture a))
-> m (Texture a)
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket \(Buffer
staging, Allocation
stage, AllocationInfo
stageInfo) -> do
let mipImages :: Vector (Word32, MipLevel)
mipImages = Vector Word32 -> MipLevels -> Vector (Word32, MipLevel)
forall a b. Vector a -> Vector b -> Vector (a, b)
Vector.zip Vector Word32
offsets MipLevels
images
Vector (Word32, MipLevel)
-> (Int -> (Word32, MipLevel) -> m ()) -> m ()
forall (m :: * -> *) a b.
Monad m =>
Vector a -> (Int -> a -> m b) -> m ()
Vector.iforM_ Vector (Word32, MipLevel)
mipImages \Int
mipIx (Word32
offset, Ktx1.MipLevel{Word32
imageSize :: MipLevel -> Word32
imageSize :: Word32
imageSize, Vector ArrayElement
arrayElements :: Vector ArrayElement
arrayElements :: MipLevel -> Vector ArrayElement
arrayElements}) -> do
Vector ArrayElement -> (Int -> ArrayElement -> m ()) -> m ()
forall (m :: * -> *) a b.
Monad m =>
Vector a -> (Int -> a -> m b) -> m ()
Vector.iforM_ Vector ArrayElement
arrayElements \Int
arrayIx Ktx1.ArrayElement{Vector Face
faces :: Vector Face
faces :: ArrayElement -> Vector Face
faces} -> do
Vector Face -> (Int -> Face -> m ()) -> m ()
forall (m :: * -> *) a b.
Monad m =>
Vector a -> (Int -> a -> m b) -> m ()
Vector.iforM_ Vector Face
faces \Int
faceIx Ktx1.Face{Vector ZSlice
zSlices :: Vector ZSlice
zSlices :: Face -> Vector ZSlice
zSlices} -> do
Vector ZSlice -> (Int -> ZSlice -> m ()) -> m ()
forall (m :: * -> *) a b.
Monad m =>
Vector a -> (Int -> a -> m b) -> m ()
Vector.iforM_ Vector ZSlice
zSlices \Int
sliceIx Ktx1.ZSlice{ByteString
block :: ByteString
block :: ZSlice -> ByteString
block} -> do
let
indices :: Utf8Builder
indices = [Utf8Builder] -> Utf8Builder
forall a. Monoid a => [a] -> a
mconcat
[ Utf8Builder
"["
, Utf8Builder
" mip:" Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display Int
mipIx
, Utf8Builder
" arr:" Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display Int
arrayIx
, Utf8Builder
" fac:" Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display Int
faceIx
, Utf8Builder
" slc:" Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display Int
sliceIx
, Utf8Builder
" ]"
]
let blockOffset :: Word32
blockOffset = Word32
offset Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
faceIx Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
* Word32
imageSize
let sectionPtr :: Ptr Any
sectionPtr = Ptr () -> Int -> Ptr Any
forall a b. Ptr a -> Int -> Ptr b
Foreign.plusPtr (AllocationInfo -> Ptr ()
VMA.mappedData AllocationInfo
stageInfo) (Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
blockOffset)
Utf8Builder -> m ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> m ()) -> Utf8Builder -> m ()
forall a b. (a -> b) -> a -> b
$ [Utf8Builder] -> Utf8Builder
forall a. Monoid a => [a] -> a
mconcat
[ Utf8Builder
indices
, Utf8Builder
" base offset = "
, Word32 -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display Word32
offset
, Utf8Builder
" image offset = "
, Word32 -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display (Word32 -> Utf8Builder) -> Word32 -> Utf8Builder
forall a b. (a -> b) -> a -> b
$ Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
faceIx Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
* Word32
imageSize
, Utf8Builder
" image size = "
, Word32 -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display Word32
imageSize
]
IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ ByteString -> (CStringLen -> IO ()) -> IO ()
forall a. ByteString -> (CStringLen -> IO a) -> IO a
unsafeUseAsCStringLen ByteString
block \(Ptr CChar
pixelsPtr, Int
pixelBytes) -> do
if Int
pixelBytes Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
imageSize then
String -> IO ()
forall a. HasCallStack => String -> a
error String
"assert: MipLevel.imageSize matches block.pixelBytes"
else
Ptr Any -> Ptr Any -> Int -> IO ()
forall a. Ptr a -> Ptr a -> Int -> IO ()
Foreign.copyBytes Ptr Any
sectionPtr (Ptr CChar -> Ptr Any
forall a b. Ptr a -> Ptr b
Foreign.castPtr Ptr CChar
pixelsPtr) Int
pixelBytes
Allocator -> Allocation -> DeviceSize -> DeviceSize -> m ()
forall (io :: * -> *).
MonadIO io =>
Allocator -> Allocation -> DeviceSize -> DeviceSize -> io ()
VMA.flushAllocation Allocator
vma Allocation
stage DeviceSize
0 DeviceSize
Vk.WHOLE_SIZE
AllocatedImage
final <- Queues CommandPool
-> Buffer -> DstImage -> Vector Word32 -> m AllocatedImage
forall env (m :: * -> *) deviceSize (t :: * -> *).
(MonadVulkan env m, Integral deviceSize, Foldable t) =>
Queues CommandPool
-> Buffer
-> DstImage
-> ("mip offsets" ::: t deviceSize)
-> m AllocatedImage
Image.copyBufferToDst
Queues CommandPool
pool
Buffer
staging
DstImage
dst
Vector Word32
offsets
pure Texture
{ $sel:tFormat:Texture :: Format
tFormat = Format
format
, $sel:tMipLevels:Texture :: Word32
tMipLevels = Word32
mipLevels
, $sel:tLayers:Texture :: Word32
tLayers = Word32
numLayers
, $sel:tAllocatedImage:Texture :: AllocatedImage
tAllocatedImage = AllocatedImage
final
}