diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,3 @@ +# Changelog for ktx + +## Unreleased changes diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Alexander Bondarenko (c) 2020 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Alexander Bondarenko nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,1 @@ +# ktx diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/ktx-codec.cabal b/ktx-codec.cabal new file mode 100644 --- /dev/null +++ b/ktx-codec.cabal @@ -0,0 +1,69 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.33.0. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: fefddec4091fd40932865a839c649f4c8d82ecce52ef3f70f527a25c3d04c1d5 + +name: ktx-codec +version: 0.0.1.0 +synopsis: Khronos texture format +description: KTX is a format for storing textures for OpenGL® and OpenGL® ES applications. + It is distinguished by the simplicity of the loader required to instantiate a + GL texture object from the file contents. + . + https://www.khronos.org/opengles/sdk/tools/KTX/file_format_spec/ +category: Graphics +author: Alexander Bondarenko +maintainer: aenor.realm@gmail.com +copyright: 2020 Alexander Bondarenko +license: BSD3 +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + ChangeLog.md + +source-repository head + type: git + location: https://gitlab.com/dpwiz/ktx + +library + exposed-modules: + Codec.Ktx + other-modules: + Paths_ktx_codec + hs-source-dirs: + src + default-extensions: ApplicativeDo BlockArguments DeriveGeneric DuplicateRecordFields FlexibleContexts GeneralizedNewtypeDeriving LambdaCase OverloadedStrings PatternSynonyms RecordWildCards StrictData + build-depends: + base >=4.7 && <5 + , binary >=0.8.7 && <1 + , bytestring >=0.10 && <0.11 + , containers >=0.6 && <0.7 + , text >=1.2 && <1.3 + , vector >=0.12 && <0.13 + default-language: Haskell2010 + +test-suite ktx-codec-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Paths_ktx_codec + hs-source-dirs: + test + default-extensions: ApplicativeDo BlockArguments DeriveGeneric DuplicateRecordFields FlexibleContexts GeneralizedNewtypeDeriving LambdaCase OverloadedStrings PatternSynonyms RecordWildCards StrictData + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + base >=4.7 && <5 + , binary >=0.8.7 && <1 + , bytestring >=0.10 && <0.11 + , containers >=0.6 && <0.7 + , directory >=1.3 && <1.4 + , filepath >=1.4 && <1.5 + , ktx-codec + , shower >=0.2 && <0.3 + , text >=1.2 && <1.3 + , vector >=0.12 && <0.13 + default-language: Haskell2010 diff --git a/src/Codec/Ktx.hs b/src/Codec/Ktx.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Ktx.hs @@ -0,0 +1,254 @@ +module Codec.Ktx where + +import Debug.Trace + +import Data.Binary (Binary(..), decodeFileOrFail) +import Data.Binary.Get (Get, ByteOffset, getWord32le, getWord32be, getByteString, skip) +import Data.Binary.Put (Put, putByteString, putWord32le) +import Data.ByteString (ByteString) +import Data.Coerce (coerce) +import Data.Foldable (for_) +import Data.Map.Strict (Map) +import Data.Text (Text) +import Data.Vector (Vector) +import Data.Word (Word32) +import GHC.Generics (Generic) + +import qualified Data.Text.Encoding as Text +import qualified Data.Map.Strict as Map +import qualified Data.Vector as Vector +import qualified Data.ByteString as BS + +fromFile :: FilePath -> IO (Either (ByteOffset, String) Ktx) +fromFile = decodeFileOrFail + +data Ktx = Ktx + { header :: Header + , kvs :: KeyValueData + , images :: MipLevels + } deriving (Show, Generic) + +instance Binary Ktx where + get = do + header <- get + kvs <- getKeyValueData header + images <- getImages header + pure Ktx{..} + + put Ktx{..} = do + put header + putKeyValueData kvs + putImages images + +-- * Header + +data Header = Header + { identifier :: ByteString + , endianness :: Word32 + , glType :: Word32 + , glTypeSize :: Word32 + , glFormat :: Word32 + , glInternalFormat :: Word32 + , glBaseInternalFormat :: Word32 + , pixelWidth :: Word32 + , pixelHeight :: Word32 + , pixelDepth :: Word32 + , numberOfArrayElements :: Word32 + , numberOfFaces :: Word32 + , numberOfMipmapLevels :: Word32 + , bytesOfKeyValueData :: Word32 + } deriving (Show, Generic) + +instance Binary Header where + get = do + identifier <- getByteString 12 + if identifier == canonicalIdentifier then + pure () + else + fail $ "KTX identifier mismatch: " <> show identifier + + endianness <- getWord32le + let + getNext = + if endianness == endiannessLE then + getWord32le + else + getWord32be + + glType <- getNext + glTypeSize <- getNext + glFormat <- getNext + glInternalFormat <- getNext + glBaseInternalFormat <- getNext + pixelWidth <- getNext + pixelHeight <- getNext + pixelDepth <- getNext + numberOfArrayElements <- getNext + numberOfFaces <- getNext + numberOfMipmapLevels <- getNext + bytesOfKeyValueData <- getNext + + pure Header{..} + + put Header{..} = do + putByteString identifier + putWord32le endianness + putWord32le glType + putWord32le glTypeSize + putWord32le glFormat + putWord32le glInternalFormat + putWord32le glBaseInternalFormat + putWord32le pixelWidth + putWord32le pixelHeight + putWord32le pixelDepth + putWord32le numberOfArrayElements + putWord32le numberOfFaces + putWord32le numberOfMipmapLevels + putWord32le bytesOfKeyValueData + +endiannessLE :: Word32 +endiannessLE = 0x04030201 + +canonicalIdentifier :: ByteString +canonicalIdentifier = BS.pack + [ 0xAB, 0x4B, 0x54, 0x58, 0x20, 0x31, 0x31, 0xBB -- «KTX 11» + , 0x0D, 0x0A, 0x1A, 0x0A -- \r\n\x1A\n + ] + +-- * Key-value data + +type KeyValueData = Map Key Value + +newtype Key = Key Text + deriving (Eq, Ord, Show, Generic) + +newtype Value = Value ByteString + deriving (Show, Generic) + +getKeyValueData :: Header -> Get KeyValueData +getKeyValueData Header{..} = Map.fromList <$> go bytesOfKeyValueData [] + where + go remains acc + | remains == 0 = + pure acc + + | remains < 0 = + fail "" + + | otherwise = do + keyAndValueByteSize <- getSize + keyAndValue <- getByteString (fromIntegral keyAndValueByteSize) + _valuePadding <- skip . fromIntegral $ 3 - ((keyAndValueByteSize + 3) `rem` 4) + + let (key, value) = BS.span (/= 0x00) keyAndValue + go (remains - keyAndValueByteSize) $ + ( Key $ Text.decodeUtf8 key + , Value value + ) : acc + + getSize = + if endianness == endiannessLE then + getWord32le + else + getWord32be + +putKeyValueData :: Map Key Value -> Put +putKeyValueData kvs = + for_ (Map.toList kvs) \(Key key, Value value) -> do + let keyAndValue = Text.encodeUtf8 key <> BS.singleton 0x00 <> value + putWord32le (fromIntegral $ BS.length keyAndValue) + putByteString keyAndValue + +-- * Images + +type MipLevels = Vector MipLevel + +data MipLevel = MipLevel + { imageSize :: Word32 + , arrayElements :: Vector ArrayElement + } + deriving (Show, Generic) + +newtype ArrayElement = ArrayElement + { faces :: Vector Face + } + deriving (Show, Generic) + +newtype Face = Face + { zSlices :: Vector ZSlice + } + deriving (Show, Generic) + +newtype ZSlice = ZSlice + { block :: ByteString + } + deriving (Generic) + +instance Show ZSlice where + show ZSlice{..} = + let + size = BS.length block + in + mconcat + [ "ZSlice (" + , show size + , ") " + , show (BS.take 32 block) + ] + +getImages :: Header -> Get MipLevels +getImages Header{..} = do + traceM $ "numberOfMipmapLevels: " <> show numberOfMipmapLevels' + some_ numberOfMipmapLevels' do + imageSize <- getImageSize + + let + sliceSize = fromIntegral $ + if numberOfFaces == 6 then + imageSize + else + imageSize + `div` numberOfArrayElements' + `div` numberOfFaces + `div` pixelDepth' + traceM $ " sliceSize: " <> show sliceSize + traceM $ " numberOfArrayElements: " <> show numberOfArrayElements + + elements <- some_ numberOfArrayElements' $ + some_ numberOfFaces $ + some_ pixelDepth' $ + ZSlice <$> getByteString sliceSize + + pure MipLevel + { imageSize = imageSize + , arrayElements = coerce elements + } + + where + some_ n action = Vector.forM (Vector.fromList [1..n]) \_ix -> action + + numberOfMipmapLevels' + | numberOfMipmapLevels == 0 = 1 + | otherwise = numberOfMipmapLevels + + numberOfArrayElements' + | numberOfArrayElements == 0 = 1 + | otherwise = numberOfArrayElements + + pixelDepth' + | pixelDepth == 0 = 1 + | otherwise = pixelDepth + + getImageSize = + if endianness == endiannessLE then + getWord32le + else + getWord32be + +putImages :: MipLevels -> Put +putImages mipLevels = Vector.forM_ mipLevels \MipLevel{..} -> do + put imageSize + Vector.forM_ arrayElements \ArrayElement{..} -> + Vector.forM_ faces \Face{..} -> + Vector.forM_ zSlices \ZSlice{..} -> + putByteString block diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,36 @@ +module Main where + +import Control.Monad (guard) +import Data.List (isSuffixOf) +import Debug.Trace (traceM) +import Shower (printer) +import System.Directory (listDirectory) +import System.FilePath (()) + +import qualified Codec.Ktx as Ktx1 + +assetsPath :: FilePath +assetsPath = ".." "assets" + +main :: IO () +main = do + assets <- listDirectory assetsPath + + mapM_ testKtx1 do + fp <- assets + guard $ ".ktx" `isSuffixOf` fp + pure $ assetsPath fp + +testKtx1 :: FilePath -> IO () +testKtx1 source = + Ktx1.fromFile source >>= \case + Left (offset, err) -> do + traceM err + fail $ unwords + [ "KTX-1 load error in" + , source + , "at" + , show offset + ] + Right ktx -> do + printer ktx