ktx-codec (empty) → 0.0.1.0

raw patch · 7 files changed

+395/−0 lines, 7 filesdep +basedep +binarydep +bytestringsetup-changed

Dependencies added: base, binary, bytestring, containers, directory, filepath, ktx-codec, shower, text, vector

Files

ChangeLog.md +3/−0
LICENSE +30/−0
README.md +1/−0
Setup.hs +2/−0
ktx-codec.cabal +69/−0
src/Codec/Ktx.hs +254/−0
test/Spec.hs +36/−0

+ ChangeLog.md view

@@ -0,0 +1,3 @@+# Changelog for ktx++## Unreleased changes

+ LICENSE view

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

+ README.md view

@@ -0,0 +1,1 @@+# ktx

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ ktx-codec.cabal view

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

+ src/Codec/Ktx.hs view

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

+ test/Spec.hs view

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