module Codec.Ktx where
import Data.Binary (Binary(..), decodeFileOrFail, decodeOrFail)
import Data.Binary.Get (Get, ByteOffset, getWord32le, getWord32be, getByteString)
import Data.Binary.Put (Put, execPut, putByteString, putWord32le, putWord32be)
import Data.ByteString (ByteString)
import Data.ByteString qualified as BS
import Data.ByteString.Builder (Builder, hPutBuilder)
import Data.ByteString.Lazy qualified as BSL
import Data.Coerce (coerce)
import Data.Vector (Vector)
import Data.Vector qualified as Vector
import Data.Word (Word32)
import GHC.Generics (Generic)
import System.IO (IOMode(..), withBinaryFile)
import Codec.Ktx.KeyValue (KeyValueData)
import Codec.Ktx.KeyValue qualified as KeyValue
fromByteStringLazy :: BSL.ByteString -> Either (ByteOffset, String) Ktx
fromByteStringLazy :: ByteString -> Either (ByteOffset, String) Ktx
fromByteStringLazy ByteString
bsl =
case forall a.
Binary a =>
ByteString
-> Either
(ByteString, ByteOffset, String) (ByteString, ByteOffset, a)
decodeOrFail ByteString
bsl of
Right (ByteString
_leftovers, ByteOffset
_bytesLeft, Ktx
ktx) ->
forall a b. b -> Either a b
Right Ktx
ktx
Left (ByteString
_leftovers, ByteOffset
bytesLeft, String
err) ->
forall a b. a -> Either a b
Left (ByteOffset
bytesLeft, String
err)
fromByteString :: ByteString -> Either (ByteOffset, String) Ktx
fromByteString :: ByteString -> Either (ByteOffset, String) Ktx
fromByteString = ByteString -> Either (ByteOffset, String) Ktx
fromByteStringLazy forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BSL.fromStrict
fromFile :: FilePath -> IO (Either (ByteOffset, String) Ktx)
fromFile :: String -> IO (Either (ByteOffset, String) Ktx)
fromFile = forall a. Binary a => String -> IO (Either (ByteOffset, String) a)
decodeFileOrFail
toBuilder :: Ktx -> Builder
toBuilder :: Ktx -> Builder
toBuilder = forall a. PutM a -> Builder
execPut forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. Binary t => t -> Put
put
toFile :: FilePath -> Ktx -> IO ()
toFile :: String -> Ktx -> IO ()
toFile String
dest Ktx
ktx =
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withBinaryFile String
dest IOMode
WriteMode forall a b. (a -> b) -> a -> b
$ \Handle
handle ->
Handle -> Builder -> IO ()
hPutBuilder Handle
handle (Ktx -> Builder
toBuilder Ktx
ktx)
data Ktx = Ktx
{ :: Header
, Ktx -> KeyValueData
kvs :: KeyValueData
, Ktx -> MipLevels
images :: MipLevels
} deriving (Int -> Ktx -> ShowS
[Ktx] -> ShowS
Ktx -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Ktx] -> ShowS
$cshowList :: [Ktx] -> ShowS
show :: Ktx -> String
$cshow :: Ktx -> String
showsPrec :: Int -> Ktx -> ShowS
$cshowsPrec :: Int -> Ktx -> ShowS
Show, forall x. Rep Ktx x -> Ktx
forall x. Ktx -> Rep Ktx x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Ktx x -> Ktx
$cfrom :: forall x. Ktx -> Rep Ktx x
Generic)
instance Binary Ktx where
get :: Get Ktx
get = do
Header
header <- forall t. Binary t => Get t
get
KeyValueData
kvs <- Get Word32 -> Int -> Get KeyValueData
KeyValue.getData
(Word32 -> Get Word32
mkGetWord32 forall a b. (a -> b) -> a -> b
$ Header -> Word32
endianness Header
header)
(forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Header -> Word32
bytesOfKeyValueData Header
header)
MipLevels
images <- Header -> Get MipLevels
getImages Header
header
pure Ktx{KeyValueData
MipLevels
Header
images :: MipLevels
kvs :: KeyValueData
header :: Header
images :: MipLevels
kvs :: KeyValueData
header :: Header
..}
put :: Ktx -> Put
put Ktx{KeyValueData
MipLevels
Header
images :: MipLevels
kvs :: KeyValueData
header :: Header
images :: Ktx -> MipLevels
kvs :: Ktx -> KeyValueData
header :: Ktx -> Header
..} = do
forall t. Binary t => t -> Put
put Header
header
(Word32 -> Put) -> KeyValueData -> Put
KeyValue.putData Word32 -> Put
putWord32 KeyValueData
kvs
(Word32 -> Put) -> MipLevels -> Put
putImages Word32 -> Put
putWord32 MipLevels
images
where
putWord32 :: Word32 -> Put
putWord32 = Word32 -> Word32 -> Put
mkPutWord32 forall a b. (a -> b) -> a -> b
$ Header -> Word32
endianness Header
header
data =
{ Header -> ByteString
identifier :: ByteString
, Header -> Word32
endianness :: Word32
, Header -> Word32
glType :: Word32
, Header -> Word32
glTypeSize :: Word32
, Header -> Word32
glFormat :: Word32
, Header -> Word32
glInternalFormat :: Word32
, Header -> Word32
glBaseInternalFormat :: Word32
, Header -> Word32
pixelWidth :: Word32
, Header -> Word32
pixelHeight :: Word32
, Header -> Word32
pixelDepth :: Word32
, Header -> Word32
numberOfArrayElements :: Word32
, Header -> Word32
numberOfFaces :: Word32
, Header -> Word32
numberOfMipmapLevels :: Word32
, Header -> Word32
bytesOfKeyValueData :: Word32
} deriving (Int -> Header -> ShowS
[Header] -> ShowS
Header -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Header] -> ShowS
$cshowList :: [Header] -> ShowS
show :: Header -> String
$cshow :: Header -> String
showsPrec :: Int -> Header -> ShowS
$cshowsPrec :: Int -> Header -> ShowS
Show, forall x. Rep Header x -> Header
forall x. Header -> Rep Header x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Header x -> Header
$cfrom :: forall x. Header -> Rep Header x
Generic)
instance Binary Header where
get :: Get Header
get = do
ByteString
identifier <- Int -> Get ByteString
getByteString Int
12
if ByteString
identifier forall a. Eq a => a -> a -> Bool
== ByteString
canonicalIdentifier then
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
else
forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"KTX identifier mismatch: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show ByteString
identifier
Word32
endianness <- Get Word32
getWord32le
let
getNext :: Get Word32
getNext =
if Word32
endianness forall a. Eq a => a -> a -> Bool
== Word32
endiannessLE then
Get Word32
getWord32le
else
Get Word32
getWord32be
Word32
glType <- Get Word32
getNext
Word32
glTypeSize <- Get Word32
getNext
Word32
glFormat <- Get Word32
getNext
Word32
glInternalFormat <- Get Word32
getNext
Word32
glBaseInternalFormat <- Get Word32
getNext
Word32
pixelWidth <- Get Word32
getNext
Word32
pixelHeight <- Get Word32
getNext
Word32
pixelDepth <- Get Word32
getNext
Word32
numberOfArrayElements <- Get Word32
getNext
Word32
numberOfFaces <- Get Word32
getNext
Word32
numberOfMipmapLevels <- Get Word32
getNext
Word32
bytesOfKeyValueData <- Get Word32
getNext
pure Header{Word32
ByteString
bytesOfKeyValueData :: Word32
numberOfMipmapLevels :: Word32
numberOfFaces :: Word32
numberOfArrayElements :: Word32
pixelDepth :: Word32
pixelHeight :: Word32
pixelWidth :: Word32
glBaseInternalFormat :: Word32
glInternalFormat :: Word32
glFormat :: Word32
glTypeSize :: Word32
glType :: Word32
endianness :: Word32
identifier :: ByteString
numberOfMipmapLevels :: Word32
numberOfFaces :: Word32
numberOfArrayElements :: Word32
pixelDepth :: Word32
pixelHeight :: Word32
pixelWidth :: Word32
glBaseInternalFormat :: Word32
glInternalFormat :: Word32
glFormat :: Word32
glTypeSize :: Word32
glType :: Word32
identifier :: ByteString
bytesOfKeyValueData :: Word32
endianness :: Word32
..}
put :: Header -> Put
put Header{Word32
ByteString
bytesOfKeyValueData :: Word32
numberOfMipmapLevels :: Word32
numberOfFaces :: Word32
numberOfArrayElements :: Word32
pixelDepth :: Word32
pixelHeight :: Word32
pixelWidth :: Word32
glBaseInternalFormat :: Word32
glInternalFormat :: Word32
glFormat :: Word32
glTypeSize :: Word32
glType :: Word32
endianness :: Word32
identifier :: ByteString
numberOfMipmapLevels :: Header -> Word32
numberOfFaces :: Header -> Word32
numberOfArrayElements :: Header -> Word32
pixelDepth :: Header -> Word32
pixelHeight :: Header -> Word32
pixelWidth :: Header -> Word32
glBaseInternalFormat :: Header -> Word32
glInternalFormat :: Header -> Word32
glFormat :: Header -> Word32
glTypeSize :: Header -> Word32
glType :: Header -> Word32
identifier :: Header -> ByteString
bytesOfKeyValueData :: Header -> Word32
endianness :: Header -> Word32
..} = do
ByteString -> Put
putByteString ByteString
identifier
let putWord32 :: Word32 -> Put
putWord32 = Word32 -> Word32 -> Put
mkPutWord32 Word32
endianness
Word32 -> Put
putWord32 Word32
endianness
Word32 -> Put
putWord32 Word32
glType
Word32 -> Put
putWord32 Word32
glTypeSize
Word32 -> Put
putWord32 Word32
glFormat
Word32 -> Put
putWord32 Word32
glInternalFormat
Word32 -> Put
putWord32 Word32
glBaseInternalFormat
Word32 -> Put
putWord32 Word32
pixelWidth
Word32 -> Put
putWord32 Word32
pixelHeight
Word32 -> Put
putWord32 Word32
pixelDepth
Word32 -> Put
putWord32 Word32
numberOfArrayElements
Word32 -> Put
putWord32 Word32
numberOfFaces
Word32 -> Put
putWord32 Word32
numberOfMipmapLevels
Word32 -> Put
putWord32 Word32
bytesOfKeyValueData
endiannessLE :: Word32
endiannessLE :: Word32
endiannessLE = Word32
0x04030201
canonicalIdentifier :: ByteString
canonicalIdentifier :: ByteString
canonicalIdentifier = [Word8] -> ByteString
BS.pack
[ Word8
0xAB, Word8
0x4B, Word8
0x54, Word8
0x58, Word8
0x20, Word8
0x31, Word8
0x31, Word8
0xBB
, Word8
0x0D, Word8
0x0A, Word8
0x1A, Word8
0x0A
]
type MipLevels = Vector MipLevel
data MipLevel = MipLevel
{ MipLevel -> Word32
imageSize :: Word32
, MipLevel -> Vector ArrayElement
arrayElements :: Vector ArrayElement
}
deriving (Int -> MipLevel -> ShowS
[MipLevel] -> ShowS
MipLevel -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MipLevel] -> ShowS
$cshowList :: [MipLevel] -> ShowS
show :: MipLevel -> String
$cshow :: MipLevel -> String
showsPrec :: Int -> MipLevel -> ShowS
$cshowsPrec :: Int -> MipLevel -> ShowS
Show, forall x. Rep MipLevel x -> MipLevel
forall x. MipLevel -> Rep MipLevel x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep MipLevel x -> MipLevel
$cfrom :: forall x. MipLevel -> Rep MipLevel x
Generic)
newtype ArrayElement = ArrayElement
{ ArrayElement -> Vector Face
faces :: Vector Face
}
deriving (Int -> ArrayElement -> ShowS
[ArrayElement] -> ShowS
ArrayElement -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ArrayElement] -> ShowS
$cshowList :: [ArrayElement] -> ShowS
show :: ArrayElement -> String
$cshow :: ArrayElement -> String
showsPrec :: Int -> ArrayElement -> ShowS
$cshowsPrec :: Int -> ArrayElement -> ShowS
Show, forall x. Rep ArrayElement x -> ArrayElement
forall x. ArrayElement -> Rep ArrayElement x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ArrayElement x -> ArrayElement
$cfrom :: forall x. ArrayElement -> Rep ArrayElement x
Generic)
newtype Face = Face
{ Face -> Vector ZSlice
zSlices :: Vector ZSlice
}
deriving (Int -> Face -> ShowS
[Face] -> ShowS
Face -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Face] -> ShowS
$cshowList :: [Face] -> ShowS
show :: Face -> String
$cshow :: Face -> String
showsPrec :: Int -> Face -> ShowS
$cshowsPrec :: Int -> Face -> ShowS
Show, forall x. Rep Face x -> Face
forall x. Face -> Rep Face x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Face x -> Face
$cfrom :: forall x. Face -> Rep Face x
Generic)
newtype ZSlice = ZSlice
{ ZSlice -> ByteString
block :: ByteString
}
deriving (forall x. Rep ZSlice x -> ZSlice
forall x. ZSlice -> Rep ZSlice x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ZSlice x -> ZSlice
$cfrom :: forall x. ZSlice -> Rep ZSlice x
Generic)
instance Show ZSlice where
show :: ZSlice -> String
show ZSlice{ByteString
block :: ByteString
block :: ZSlice -> ByteString
..} =
let
size :: Int
size = ByteString -> Int
BS.length ByteString
block
in
forall a. Monoid a => [a] -> a
mconcat
[ String
"ZSlice ("
, forall a. Show a => a -> String
show Int
size
, String
") "
, forall a. Show a => a -> String
show (Int -> ByteString -> ByteString
BS.take Int
32 ByteString
block)
]
getImages :: Header -> Get MipLevels
getImages :: Header -> Get MipLevels
getImages Header{Word32
ByteString
bytesOfKeyValueData :: Word32
numberOfMipmapLevels :: Word32
numberOfFaces :: Word32
numberOfArrayElements :: Word32
pixelDepth :: Word32
pixelHeight :: Word32
pixelWidth :: Word32
glBaseInternalFormat :: Word32
glInternalFormat :: Word32
glFormat :: Word32
glTypeSize :: Word32
glType :: Word32
endianness :: Word32
identifier :: ByteString
numberOfMipmapLevels :: Header -> Word32
numberOfFaces :: Header -> Word32
numberOfArrayElements :: Header -> Word32
pixelDepth :: Header -> Word32
pixelHeight :: Header -> Word32
pixelWidth :: Header -> Word32
glBaseInternalFormat :: Header -> Word32
glInternalFormat :: Header -> Word32
glFormat :: Header -> Word32
glTypeSize :: Header -> Word32
glType :: Header -> Word32
identifier :: Header -> ByteString
bytesOfKeyValueData :: Header -> Word32
endianness :: Header -> Word32
..} =
forall {m :: * -> *} {a} {b}.
(Monad m, Num a, Enum a) =>
a -> m b -> m (Vector b)
some_ Word32
numberOfMipmapLevels' do
Word32
imageSize <- Get Word32
getImageSize
let
sliceSize :: Int
sliceSize = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$
if Word32
numberOfFaces forall a. Eq a => a -> a -> Bool
== Word32
6 then
Word32
imageSize
else
Word32
imageSize
forall a. Integral a => a -> a -> a
`div` Word32
numberOfArrayElements'
forall a. Integral a => a -> a -> a
`div` Word32
numberOfFaces
forall a. Integral a => a -> a -> a
`div` Word32
pixelDepth'
Vector (Vector (Vector ZSlice))
elements <- forall {m :: * -> *} {a} {b}.
(Monad m, Num a, Enum a) =>
a -> m b -> m (Vector b)
some_ Word32
numberOfArrayElements' forall a b. (a -> b) -> a -> b
$
forall {m :: * -> *} {a} {b}.
(Monad m, Num a, Enum a) =>
a -> m b -> m (Vector b)
some_ Word32
numberOfFaces forall a b. (a -> b) -> a -> b
$
forall {m :: * -> *} {a} {b}.
(Monad m, Num a, Enum a) =>
a -> m b -> m (Vector b)
some_ Word32
pixelDepth' forall a b. (a -> b) -> a -> b
$
ByteString -> ZSlice
ZSlice forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Get ByteString
getByteString Int
sliceSize
pure MipLevel
{ imageSize :: Word32
imageSize = Word32
imageSize
, arrayElements :: Vector ArrayElement
arrayElements = coerce :: forall a b. Coercible a b => a -> b
coerce Vector (Vector (Vector ZSlice))
elements
}
where
some_ :: a -> m b -> m (Vector b)
some_ a
n m b
action = forall (m :: * -> *) a b.
Monad m =>
Vector a -> (a -> m b) -> m (Vector b)
Vector.forM (forall a. [a] -> Vector a
Vector.fromList [a
1..a
n]) \a
_ix -> m b
action
numberOfMipmapLevels' :: Word32
numberOfMipmapLevels'
| Word32
numberOfMipmapLevels forall a. Eq a => a -> a -> Bool
== Word32
0 = Word32
1
| Bool
otherwise = Word32
numberOfMipmapLevels
numberOfArrayElements' :: Word32
numberOfArrayElements'
| Word32
numberOfArrayElements forall a. Eq a => a -> a -> Bool
== Word32
0 = Word32
1
| Bool
otherwise = Word32
numberOfArrayElements
pixelDepth' :: Word32
pixelDepth'
| Word32
pixelDepth forall a. Eq a => a -> a -> Bool
== Word32
0 = Word32
1
| Bool
otherwise = Word32
pixelDepth
getImageSize :: Get Word32
getImageSize =
if Word32
endianness forall a. Eq a => a -> a -> Bool
== Word32
endiannessLE then
Get Word32
getWord32le
else
Get Word32
getWord32be
putImages :: (Word32 -> Put) -> MipLevels -> Put
putImages :: (Word32 -> Put) -> MipLevels -> Put
putImages Word32 -> Put
putWord32 MipLevels
mipLevels = forall (m :: * -> *) a b. Monad m => Vector a -> (a -> m b) -> m ()
Vector.forM_ MipLevels
mipLevels \MipLevel{Word32
Vector ArrayElement
arrayElements :: Vector ArrayElement
imageSize :: Word32
arrayElements :: MipLevel -> Vector ArrayElement
imageSize :: MipLevel -> Word32
..} -> do
Word32 -> Put
putWord32 Word32
imageSize
forall (m :: * -> *) a b. Monad m => Vector a -> (a -> m b) -> m ()
Vector.forM_ Vector ArrayElement
arrayElements \ArrayElement{Vector Face
faces :: Vector Face
faces :: ArrayElement -> Vector Face
..} ->
forall (m :: * -> *) a b. Monad m => Vector a -> (a -> m b) -> m ()
Vector.forM_ Vector Face
faces \Face{Vector ZSlice
zSlices :: Vector ZSlice
zSlices :: Face -> Vector ZSlice
..} ->
forall (m :: * -> *) a b. Monad m => Vector a -> (a -> m b) -> m ()
Vector.forM_ Vector ZSlice
zSlices \ZSlice{ByteString
block :: ByteString
block :: ZSlice -> ByteString
..} ->
ByteString -> Put
putByteString ByteString
block
mkGetWord32 :: Word32 -> Get Word32
mkGetWord32 :: Word32 -> Get Word32
mkGetWord32 Word32
someEndianness =
if Word32
someEndianness forall a. Eq a => a -> a -> Bool
== Word32
endiannessLE then
Get Word32
getWord32le
else
Get Word32
getWord32be
mkPutWord32 :: Word32 -> (Word32 -> Put)
mkPutWord32 :: Word32 -> Word32 -> Put
mkPutWord32 Word32
someEndianness =
if Word32
someEndianness forall a. Eq a => a -> a -> Bool
== Word32
endiannessLE then
Word32 -> Put
putWord32le
else
Word32 -> Put
putWord32be