diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,60 @@ +0.3.0.0 (2026-10-15) +==================== + +Breaking changes: + +- `encodeBlpUncompressedWithAlpha` always writes an alpha plane and + `encodeBlpUncompressedWithoutAlpha` never does. Both used to pick by the + input image, so the two were identical and `blp2any -b` had no effect. +- `decodeBlp` and `decodeBlpMipmaps` always return `ImageRGBA8`. JPEG BLPs + whose stream is not four-component (greyscale, YCbCr) used to come back as + `ImageY8` or `ImageRGB8`. +- Removed unused functions from `Codec.Picture.Blp.Internal.Convert`: + `toPngRepresentable` and `toBlpUncompressable`. +- `mipMapsUpTo` counts every level down to the minimum side; it was one short + and returned 0 or less for tiny images. +- Removed the `TextShow` and `Hashable` instances from + `Codec.Picture.Blp.Internal.Data`, and with them the `text-show` and + `hashable` dependencies. `blp2any` no longer depends on + `unordered-containers`. + +The encoder always writes mip 0; a mipmap count of zero or less used to +produce an unreadable file, which `blp2any` did for 1x1 images. + +The uncompressed encoder no longer hands out ByteStrings over image memory it +does not keep alive, and no longer relies on an orphan, endianness-dependent +`Storable PixelRGBA8` instance. + +Decoder robustness for BLP1 files found in the wild: + +- Accept picture type 6 (WoW JPEG variant) and picture type 0 (#5, #10). +- Tolerate palettes shorter than 256 entries (#6). +- Decode files labelled with-alpha whose mipmap 0 has no alpha plane as + without-alpha instead of crashing (#8). +- A corrupt JPEG mipmap no longer fails the whole file; the mipmap list is + cut at the first broken level (#9). +- `decodeBlpMipmaps` renders uncompressed mipmaps at their own sizes instead of + crashing; a mip 0 too short for the image is a `Left` (#13). +- Without-alpha textures decode opaque regardless of the palette's fourth + byte, so the encoder's own output no longer comes back transparent (#14). +- Decoding no longer dumps the parsed structure to stderr (#15). +- The JPEG encoder writes plain BGRA planes instead of dividing colour by + alpha, and a uniformly semi-transparent alpha plane is kept; only all-0x00 + or all-0xFF planes count as unpopulated (#17). +- The JPEG encoder shares one header between mipmaps; 1x1 textures no longer + encode to a file without image data (#18). +- Skip mipmap slots that point past the end of the file or overlap an earlier + one (#7). +- Decode JPEG planes as BGRA instead of CMYK (#11). + +Support GHC 9.4 – 9.14: relax upper bounds for `attoparsec`, `bytestring`, +`hashable`, `text-show`, `vector` and `filepath`. Minimum supported GHC is now 9.4. + +0.2.1.0 +======= + +Relax upper boundary for `text-show-3.9`. + 0.2.0.0 ======= diff --git a/JuicyPixels-blp.cabal b/JuicyPixels-blp.cabal --- a/JuicyPixels-blp.cabal +++ b/JuicyPixels-blp.cabal @@ -1,27 +1,38 @@ +cabal-version: 2.2 name: JuicyPixels-blp -version: 0.2.0.0 +version: 0.3.0.0 synopsis: BLP format decoder/encoder over JuicyPixels library description: The library provides decoding/encoding functions for BLP1 texture format of Warcraft III game. The result is represented in types of [JuicyPixels](http://hackage.haskell.org/package/JuicyPixels) library. Please see README.md for detailed description. -homepage: http://github.com/NCrashed/JuicyPixels-blp#readme -license: BSD3 +homepage: https://github.com/NCrashed/JuicyPixels-blp#readme +license: BSD-3-Clause license-file: LICENSE author: Anton Gushcha maintainer: ncrashed@gmail.com -copyright: 2015-2018 Anton Gushcha +copyright: 2015-2026 Anton Gushcha category: Codec, Graphics, Image build-type: Simple -cabal-version: >=1.10 -extra-source-files: README.md, CHANGELOG.md +extra-doc-files: README.md, CHANGELOG.md +tested-with: + GHC == 9.4.8 + || == 9.6.7 + || == 9.8.4 + || == 9.10.3 + || == 9.12.3 + || == 9.14.1 source-repository head type: git - location: git@github.com:NCrashed/JuicyPixels-blp.git + location: https://github.com/NCrashed/JuicyPixels-blp.git +common warnings + ghc-options: -Wall -Wcompat + library + import: warnings hs-source-dirs: src exposed-modules: Codec.Picture.Blp @@ -32,14 +43,12 @@ default-language: Haskell2010 build-depends: - base >= 4.7 && < 5 - , attoparsec >= 0.12 && < 0.14 + base >= 4.17 && < 5 + , attoparsec >= 0.12 && < 0.15 , binary >= 0.8 && < 0.10 - , bytestring >= 0.10 && < 0.11 - , hashable >= 1.2 && < 1.4 + , bytestring >= 0.10 && < 0.13 , JuicyPixels >= 3.2 && < 3.4 - , text-show >= 3.7 && < 3.9 - , vector >= 0.10 && < 0.13 + , vector >= 0.10 && < 0.14 default-extensions: BangPatterns @@ -49,6 +58,7 @@ RecordWildCards executable blp2any + import: warnings hs-source-dirs: blp2any main-is: Main.hs other-modules: @@ -58,15 +68,36 @@ ghc-options: -threaded -rtsopts -with-rtsopts=-N default-language: Haskell2010 build-depends: - base >= 4.7 && < 5 + base , bytestring + , containers >= 0.6 && < 0.9 , directory >= 1.2 && < 1.4 - , filepath >= 1.4 && < 1.5 + , filepath >= 1.4 && < 1.6 , JuicyPixels , JuicyPixels-blp , optparse-simple >= 0.0.3 && < 0.2 - , text-show - , unordered-containers >= 0.2 && < 0.3 default-extensions: + RecordWildCards + +test-suite spec + import: warnings + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + other-modules: + Fixture + default-language: Haskell2010 + build-depends: + base + , bytestring + , directory + , filepath + , JuicyPixels + , JuicyPixels-blp + , tasty >= 1.4 && < 1.6 + , tasty-hunit >= 0.10 && < 0.11 + + default-extensions: + OverloadedStrings RecordWildCards diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,7 +1,7 @@ JuicyPixels-blp =============== -[![Build Status](https://travis-ci.org/NCrashed/JuicyPixels-blp.svg?branch=master)](https://travis-ci.org/NCrashed/JuicyPixels-blp) +[![CI](https://github.com/NCrashed/JuicyPixels-blp/actions/workflows/ci.yml/badge.svg)](https://github.com/NCrashed/JuicyPixels-blp/actions/workflows/ci.yml) The library provides decoding/encoding functions for BLP1 texture format of Warcraft III game. The result is represented in types of [JuicyPixels](http://hackage.haskell.org/package/JuicyPixels) library. diff --git a/blp2any/Convert.hs b/blp2any/Convert.hs --- a/blp2any/Convert.hs +++ b/blp2any/Convert.hs @@ -12,7 +12,6 @@ import Control.Monad import Data.Char import Data.Maybe -import Data.Monoid import System.Directory import System.FilePath diff --git a/blp2any/Main.hs b/blp2any/Main.hs --- a/blp2any/Main.hs +++ b/blp2any/Main.hs @@ -1,6 +1,5 @@ module Main where -import Data.Monoid import Options.Applicative.Simple import Statistics diff --git a/blp2any/Statistics.hs b/blp2any/Statistics.hs --- a/blp2any/Statistics.hs +++ b/blp2any/Statistics.hs @@ -12,7 +12,7 @@ import System.FilePath import qualified Data.ByteString as BS -import qualified Data.HashMap.Strict as H +import qualified Data.Map.Strict as M import qualified Data.List as L import File @@ -20,13 +20,13 @@ type BlpInfo = (BlpCompression, [BlpFlag], BlpPictureType, Word32) type BlpStat = (FilePath, Int) -type StatMap = H.HashMap BlpInfo BlpStat +type StatMap = M.Map BlpInfo BlpStat collectSamples :: FilePath -> IO StatMap collectSamples dir = do f <- doesDirectoryExist dir unless f $ fail $ "Provided directory " ++ dir ++ " doesn't exists!" - forEachFile dir ((".blp" ==).takeExtension) collectSample H.empty + forEachFile dir ((".blp" ==).takeExtension) collectSample M.empty collectSample :: StatMap -> FilePath -> IO StatMap collectSample stats inputFile = do @@ -40,7 +40,7 @@ blpType BlpStruct{..} = (blpCompression, blpFlags, blpPictureType, blpPictureSubType) adjust' :: (Maybe BlpStat -> BlpStat) -> BlpInfo -> StatMap -> StatMap -adjust' f k m = H.insert k (f $ H.lookup k m) m +adjust' f k m = M.insert k (f $ M.lookup k m) m updateStat :: FilePath -> Maybe BlpStat -> BlpStat updateStat path Nothing = (path, 1) @@ -49,7 +49,7 @@ printStatistics :: FilePath -> StatMap -> IO () printStatistics dir stats = do createDirectoryIfMissing True dir - forM_ (H.toList stats) $ \((compression, flags, pictureType, pictureSubType), (path, i)) -> do + forM_ (M.toList stats) $ \((compression, flags, pictureType, pictureSubType), (path, i)) -> do let postfix = L.intercalate "-" [show compression, show flags, show pictureType, show pictureSubType] copyFile path $ dir ++ "/" ++ dropExtension (takeFileName path) ++ "-" ++ postfix ++ ".blp" diff --git a/src/Codec/Picture/Blp.hs b/src/Codec/Picture/Blp.hs --- a/src/Codec/Picture/Blp.hs +++ b/src/Codec/Picture/Blp.hs @@ -1,8 +1,30 @@ +{-| +Decoding and encoding of BLP1, the texture format of Warcraft III, on top of +JuicyPixels. + +BLP1 comes in two flavours: JPEG compressed and uncompressed with a 256 +colour palette. Uncompressed textures either carry an alpha plane or not. +A file holds the full size image followed by its mipmaps, each half the size +of the previous one. + +Decoding always yields 'ImageRGBA8'. Files from the wild are often slightly +off spec; the decoder accepts the common deviations and, when a mipmap is +damaged, keeps the levels before it. + +> Right img <- readBlp "war3mapMap.blp" +> writePng "war3mapMap.png" (convertRGBA8 img) +-} module Codec.Picture.Blp( + -- * Decoding readBlp , readBlpMipmaps , decodeBlp , decodeBlpMipmaps + -- * Encoding + -- | The mipmap count passed to the encoders is the number of levels to + -- write, mip 0 included. It is clamped to at least one, and asking for + -- more levels than the image has stops at the level where a side reaches + -- one pixel. 'mipMapsUpTo' computes it from a minimum side length. , writeBlpJpeg , writeBlpUncompressedWithAlpha , writeBlpUncompressedWithoutAlpha @@ -13,11 +35,8 @@ ) where import Codec.Picture -import Codec.Picture.Types +import Data.Bits (shiftR) import Data.ByteString (ByteString) -import Data.Monoid -import Data.Word -import TextShow.Debug.Trace import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BSL @@ -28,91 +47,147 @@ import Codec.Picture.Blp.Internal.Encoder import Codec.Picture.Blp.Internal.Parser --- | Read BLP from given file without mipmaps +-- | Read a BLP file and decode its full size image. IO errors, such as a +-- missing file, are thrown; malformed contents give 'Left'. readBlp :: FilePath -> IO (Either String DynamicImage) readBlp fp = decodeBlp `fmap` BS.readFile fp --- | Read BLP from given file with mipmaps +-- | Read a BLP file and decode the full size image followed by its mipmaps. +-- See 'decodeBlpMipmaps'. readBlpMipmaps :: FilePath -> IO (Either String [DynamicImage]) readBlpMipmaps fp = decodeBlpMipmaps `fmap` BS.readFile fp --- | Decodes BLP without mipmaps +-- | Decode the full size image of a BLP file. The result is 'ImageRGBA8'. decodeBlp :: ByteString -> Either String DynamicImage decodeBlp bs = do is <- decodeBlpMipmaps bs - if null is then Left "No data in BLP" - else return $ head is + case is of + i : _ -> Right i + [] -> Left "No data in BLP" --- | Decodes BLP and returns original image plus all mipmaps +-- | Decode the full size image followed by its mipmaps, all 'ImageRGBA8'. +-- +-- Element @ is always mip level @. Mipmaps are decoded lazily, and the +-- list stops at the first one that is damaged, so a broken mipmap never +-- costs the levels before it. A damaged full size image fails the file. decodeBlpMipmaps :: ByteString -> Either String [DynamicImage] decodeBlpMipmaps bs = do blp <- parseBlp bs - case blpExt $ traceTextShowId blp of + let width = fromIntegral $ blpWidth blp + height = fromIntegral $ blpHeight blp + case blpExt blp of BlpJpeg {..} -> do let jpegs = (blpJpegHeader <>) `fmap` blpJpegData - mips <- mapM decodeJpeg jpegs - return $ toPngRepresentable <$> mips + case jpegs of + [] -> Left "No JPEG mipmap data in BLP" + (j0:js) -> do + -- Mipmap 0 is the full-resolution image; single-image callers + -- (`decodeBlp`) only ever take `head` of the result. Decoding it + -- strictly means a failure here still fails the whole file as + -- before. Tail mipmaps are decoded lazily and the chain stops at the + -- first one that fails, so a corrupt tail can no longer poison the + -- main image, and the result stays a prefix of the mip levels + -- (index i is always level i). + mip0 <- decodeJpeg j0 + let validPrefix (j:rest) | Right m <- decodeJpeg j = m : validPrefix rest + validPrefix _ = [] + lazyTail = validPrefix js + -- The alpha decision is taken once, from the full size mipmap, so that + -- every mipmap of a texture is decoded the same way. Smaller mipmaps + -- are often padded out with a flat alpha plane of their own. + useAlpha = BlpFlagAlphaChannel `elem` blpFlags blp && jpegAlphaIsUsable mip0 + Right $ fromBlpJpeg useAlpha <$> (mip0 : lazyTail) - BlpUncompressed1 {..} -> do - let mkImage mip = ImageRGBA8 $ generateImage (gen mip) (fromIntegral $ blpWidth blp) (fromIntegral $ blpHeight blp) - return $ mkImage `fmap` blpU1MipMaps + BlpUncompressed1 {..} -> uncompressedLevels width height fits render blpU1MipMaps where - palette :: Word8 -> PixelRGBA8 - palette i = blpU1Palette V.! fromIntegral i - - makeIndex x y = y*(fromIntegral $ blpWidth blp)+x - takeColor mip x y = palette $ fst mip `BS.index` makeIndex x y - takeAlpha mip x y = snd mip `BS.index` makeIndex x y - gen mip x y = let - PixelRGBA8 r g b _ = takeColor mip x y - a = takeAlpha mip x y - in PixelRGBA8 b g r a + fits n (indexList, alphaList) = BS.length indexList >= n && BS.length alphaList >= n + render w (indexList, alphaList) x y = let + i = y * w + x + PixelRGBA8 r g b _ = blpU1Palette V.! fromIntegral (indexList `BS.index` i) + in PixelRGBA8 b g r (alphaList `BS.index` i) - BlpUncompressed2 {..} -> do - let mkImage mip = ImageRGBA8 $ generateImage (gen mip) (fromIntegral $ blpWidth blp) (fromIntegral $ blpHeight blp) - return $ mkImage `fmap` blpU2MipMaps + BlpUncompressed2 {..} -> uncompressedLevels width height fits render blpU2MipMaps where - palette :: Word8 -> PixelRGBA8 - palette i = blpU2Palette V.! fromIntegral i + fits n indexList = BS.length indexList >= n + render w indexList x y = let + PixelRGBA8 r g b _ = blpU2Palette V.! fromIntegral (indexList `BS.index` (y * w + x)) + -- Without-alpha textures have no alpha to decode; the palette's fourth + -- byte is not alpha and tools fill it inconsistently. + in PixelRGBA8 b g r 255 - makeIndex x y = y*(fromIntegral $ blpWidth blp)+x - takeColor mip x y = palette $ mip `BS.index` makeIndex x y - gen mip x y = let - PixelRGBA8 r g b a = takeColor mip x y - in PixelRGBA8 b g r (255 - a) +-- | Render the mipmaps of an uncompressed BLP. Level @l@ of a @w@ x @h@ +-- texture is @w / 2^l@ by @h / 2^l@, but never smaller than 1x1. The list +-- stops at the first level whose buffer is too short for its size, so the +-- result is always a prefix of the mip levels; a short level 0 fails the file. +uncompressedLevels :: Int -> Int + -> (Int -> mip -> Bool) -- ^ Does the buffer hold this many pixels? + -> (Int -> mip -> Int -> Int -> PixelRGBA8) -- ^ Pixel at (x, y) of a level of given width + -> [mip] + -> Either String [DynamicImage] +uncompressedLevels width height fits render mips + | null mips = Right [] + | otherwise = case go 0 mips of + [] -> Left "Mipmap 0 is too short for the image size" + levels -> Right levels + where + go l (mip : rest) + | fits (w * h) mip = ImageRGBA8 (generateImage (render w mip) w h) : go (l + 1) rest + where + w = levelSide width l + h = levelSide height l + go _ _ = [] + levelSide side l = if side <= 0 then 0 else max 1 (side `shiftR` l) --- | Calculate needed count of mipmaps to cover sizes up to given minimum size (helper for 'writeBlp*' functions) -mipMapsUpTo :: Int -- ^ Minimum size of picture side for generation of mipmap (ex. 2, 4, 16, 32, 64, 512, 1024 and etc) - -> DynamicImage -- ^ Image for which we generate mipmaps +-- | Number of mip levels, mip 0 included, whose smaller side is at least the +-- given length; never less than one. Pass it to the encoders as the mipmap +-- count. A 16x16 texture has five levels down to 1 pixel and three down to +-- 4 pixels. +mipMapsUpTo :: Int -- ^ Smallest side length to keep (2, 4, 16, ...) + -> DynamicImage -- ^ Image the mipmaps are made for -> Int -mipMapsUpTo minSize img = maxNum - minSizeNum +mipMapsUpTo minSize img = max 1 . length . takeWhile (>= max 1 minSize) $ iterate (`div` 2) minSide where - w = dynamicMap imageWidth img - h = dynamicMap imageHeight img - minSide = min w h - maxNum = ceiling $ logBase 2 (fromIntegral minSide) - minSizeNum = floor $ logBase 2 (fromIntegral (max 1 minSize)) + minSide = min (dynamicMap imageWidth img) (dynamicMap imageHeight img) +-- | Encode with 'encodeBlpJpeg' and write the result to a file. writeBlpJpeg :: FilePath -> Int -> Int -> DynamicImage -> IO () writeBlpJpeg fp quality numMips img = do let bs = encodeBlpJpeg quality numMips img BSL.writeFile fp bs +-- | Encode with 'encodeBlpUncompressedWithAlpha' and write the result to a file. writeBlpUncompressedWithAlpha :: FilePath -> Int -> DynamicImage -> IO () writeBlpUncompressedWithAlpha fp numMips img = do let bs = encodeBlpUncompressedWithAlpha numMips img BSL.writeFile fp bs +-- | Encode with 'encodeBlpUncompressedWithoutAlpha' and write the result to a +-- file. writeBlpUncompressedWithoutAlpha :: FilePath -> Int -> DynamicImage -> IO () writeBlpUncompressedWithoutAlpha fp numMips img = do let bs = encodeBlpUncompressedWithoutAlpha numMips img BSL.writeFile fp bs -encodeBlpJpeg :: Int -> Int -> DynamicImage -> BSL.ByteString -encodeBlpJpeg quality numMips = encodeBlp numMips {-. traceTextShowId-} . toBlpStruct BlpCompressionJPEG quality numMips +-- | Encode as a JPEG compressed BLP. The texture gets an alpha plane when the +-- input image has an alpha channel. +encodeBlpJpeg :: Int -- ^ JPEG quality, 0 to 100 + -> Int -- ^ Number of mip levels to write + -> DynamicImage + -> BSL.ByteString +encodeBlpJpeg quality numMips = encodeBlp numMips . toBlpStruct BlpCompressionJPEG quality numMips -encodeBlpUncompressedWithAlpha :: Int -> DynamicImage -> BSL.ByteString -encodeBlpUncompressedWithAlpha numMips = encodeBlp numMips {-. traceTextShowId-} . toBlpStruct BlpCompressionUncompressed 100 numMips +-- | Encode as an uncompressed paletted BLP with an alpha plane. An input +-- without alpha gets a fully opaque plane. Colours are quantised to 256. +encodeBlpUncompressedWithAlpha :: Int -- ^ Number of mip levels to write + -> DynamicImage + -> BSL.ByteString +encodeBlpUncompressedWithAlpha numMips = + encodeBlp numMips . toBlpStruct BlpCompressionUncompressed 100 numMips . ImageRGBA8 . convertRGBA8 -encodeBlpUncompressedWithoutAlpha :: Int -> DynamicImage -> BSL.ByteString -encodeBlpUncompressedWithoutAlpha numMips = encodeBlp numMips {-. traceTextShowId-} . toBlpStruct BlpCompressionUncompressed 100 numMips +-- | Encode as an uncompressed paletted BLP without alpha. The alpha channel +-- of the input, if any, is dropped. Colours are quantised to 256. +encodeBlpUncompressedWithoutAlpha :: Int -- ^ Number of mip levels to write + -> DynamicImage + -> BSL.ByteString +encodeBlpUncompressedWithoutAlpha numMips = + encodeBlp numMips . toBlpStruct BlpCompressionUncompressed 100 numMips . ImageRGB8 . convertRGB8 diff --git a/src/Codec/Picture/Blp/Internal/Convert.hs b/src/Codec/Picture/Blp/Internal/Convert.hs --- a/src/Codec/Picture/Blp/Internal/Convert.hs +++ b/src/Codec/Picture/Blp/Internal/Convert.hs @@ -1,118 +1,78 @@ module Codec.Picture.Blp.Internal.Convert( - toPngRepresentable - , toBlpUncompressable + fromBlpJpeg + , jpegAlphaIsUsable , toBlpCMYK8 ) where import Codec.Picture -import Codec.Picture.Types +import Codec.Picture.Types (pixelFold) import Data.Word -toPngRepresentable :: DynamicImage -> DynamicImage -toPngRepresentable i = case i of - ImageY8 _ -> i - ImageY16 _ -> i - ImageYF p -> ImageRGB16 . convertFloatImage16 . promoteImage $ p - ImageYA8 _ -> i - ImageYA16 _ -> i - ImageRGB8 _ -> i - ImageRGB16 _ -> i - ImageRGBF p -> ImageRGB16 . convertFloatImage16 $ p - ImageRGBA8 _ -> i - ImageRGBA16 _ -> i - ImageYCbCr8 p -> ImageRGB8 . convertImage $ p - ImageCMYK8 p -> ImageRGBA8 . convertCMYK8Image $ p - ImageCMYK16 p -> ImageRGBA16 . convertCMYK16Image $ p - -toBlpUncompressable :: DynamicImage -> Image PixelRGBA8 -toBlpUncompressable i = case i of - ImageY8 p -> toBlpRGB8 (promoteImage p :: Image PixelRGB8) - ImageY16 p -> toBlpRGB8 (dropBits (promoteImage p :: Image PixelRGB16) :: Image PixelRGB8) - ImageYF p -> toBlpRGB8 (convertFloatImage8 (promoteImage p :: Image PixelRGBF) :: Image PixelRGB8) - ImageYA8 p -> toBlpRGBA8 (promoteImage p :: Image PixelRGBA8) - ImageYA16 p -> toBlpRGBA8 (dropBitsA (promoteImage p :: Image PixelRGBA16) :: Image PixelRGBA8) - ImageRGB8 p -> toBlpRGB8 p - ImageRGB16 p -> toBlpRGB8 (dropBits p :: Image PixelRGB8) - ImageRGBF p -> toBlpRGB8 (convertFloatImage8 p :: Image PixelRGB8) - ImageRGBA8 p -> toBlpRGBA8 p - ImageRGBA16 p -> toBlpRGBA8 (dropBitsA p :: Image PixelRGBA8) - ImageYCbCr8 p -> toBlpRGB8 (convertImage p :: Image PixelRGB8) - ImageCMYK8 p -> toBlpRGB8 (convertImage p :: Image PixelRGB8) - ImageCMYK16 p -> toBlpRGB8 (dropBits (convertImage p :: Image PixelRGB16) :: Image PixelRGB8) - -dropBits :: Image PixelRGB16 -> Image PixelRGB8 -dropBits = pixelMap $ \(PixelRGB16 r g b) -> PixelRGB8 (f r) (f g) (f b) - where - f :: Word16 -> Word8 - f x = round $ 255 * (fromIntegral x :: Double) / 65535 +-- | Convert a decoded mipmap of a JPEG compressed BLP1 into an image that can +-- be written out directly. +-- +-- The four components of a BLP1 JPEG are the raw B, G, R and A planes of the +-- texture. The stream carries no Adobe marker, so a JPEG decoder has nothing +-- to go on and reports it as CMYK; running the generic CMYK conversion over +-- it applies an ink model to data that is not ink, and multiplies every +-- colour channel by the alpha plane. Map the planes straight across instead. +-- +-- The 'Bool' says whether the alpha plane should be honoured; see +-- 'jpegAlphaIsUsable'. When it is 'False' the texture is made fully opaque. +-- Any other kind of JPEG (greyscale, YCbCr) is converted to RGBA as usual. +fromBlpJpeg :: Bool -> DynamicImage -> DynamicImage +fromBlpJpeg useAlpha i = case i of + ImageCMYK8 p -> + let rgba = blpJpegToRGBA8 p + in ImageRGBA8 $ if useAlpha then rgba else forceOpaque rgba + _ -> ImageRGBA8 $ convertRGBA8 i -dropBitsA :: Image PixelRGBA16 -> Image PixelRGBA8 -dropBitsA = pixelMap $ \(PixelRGBA16 r g b a) -> PixelRGBA8 (f r) (f g) (f b) (f a) - where - f :: Word16 -> Word8 - f x = round $ 255 * (fromIntegral x :: Double) / 65535 +-- | Whether the alpha plane of a decoded BLP1 JPEG mipmap carries information. +-- +-- Warcraft III authoring tools disagree about the alpha plane of a JPEG +-- compressed BLP1. Some set the alpha flag and fill the plane with 0x00, +-- others with 0xFF, and both mean the same thing: the texture is opaque and +-- the plane was never populated. Taking either at face value gives a wrong +-- answer for half the files in the wild, so a plane that is entirely 0x00 or +-- entirely 0xFF is treated as carrying no information at all. +-- +-- Any other plane, including one that is uniformly semi-transparent, is used +-- as it stands. +jpegAlphaIsUsable :: DynamicImage -> Bool +jpegAlphaIsUsable i = case i of + ImageCMYK8 p -> case uniformAlpha (blpJpegToRGBA8 p) of + Just a -> a /= 0 && a /= 255 + Nothing -> True + _ -> True -convertFloatImage8 :: Image PixelRGBF -> Image PixelRGB8 -convertFloatImage8 = pixelMap convert +-- | The alpha value every pixel of an image carries, if they all agree. An +-- empty image counts as uniformly opaque. +uniformAlpha :: Image PixelRGBA8 -> Maybe Word8 +uniformAlpha img + | imageWidth img <= 0 || imageHeight img <= 0 = Just 255 + | pixelFold same True img = Just a0 + | otherwise = Nothing where - convert (PixelRGBF rf gf bf) = PixelRGB8 - (round $ 255 * rf) - (round $ 255 * gf) - (round $ 255 * bf) + PixelRGBA8 _ _ _ a0 = pixelAt img 0 0 + same acc _ _ (PixelRGBA8 _ _ _ a) = acc && a == a0 -convertFloatImage16 :: Image PixelRGBF -> Image PixelRGB16 -convertFloatImage16 = pixelMap convert +-- | Reinterpret the four planes a JPEG decoder labelled CMYK as the BGRA they +-- actually are. This inverts 'toBlpCMYK8'. +blpJpegToRGBA8 :: Image PixelCMYK8 -> Image PixelRGBA8 +blpJpegToRGBA8 = pixelMap convert where - convert (PixelRGBF rf gf bf) = PixelRGB16 - (round $ 65535 * rf) - (round $ 65535 * gf) - (round $ 65535 * bf) + convert (PixelCMYK8 c m y k) = PixelRGBA8 y m c k -convertCMYK8Image :: Image PixelCMYK8 -> Image PixelRGBA8 -convertCMYK8Image = pixelMap convert +forceOpaque :: Image PixelRGBA8 -> Image PixelRGBA8 +forceOpaque = pixelMap convert where - clampWord8 = fromIntegral . max 0 . min 255 . (`div` 256) - convert (PixelCMYK8 c m y k) = - PixelRGBA8 (clampWord8 r) (clampWord8 g) (clampWord8 b) k - where - ik :: Int - ik = fromIntegral k - r = fromIntegral y * ik - g = fromIntegral m * ik - b = fromIntegral c * ik + convert (PixelRGBA8 r g b _) = PixelRGBA8 r g b 255 +-- | Lay out the B, G, R and A planes of a texture as the four components of +-- a BLP1 JPEG. The encoder labels them CMYK only because that is the +-- four-component JPEG it can write; this is the exact inverse of +-- @blpJpegToRGBA8@. toBlpCMYK8 :: Image PixelRGBA8 -> Image PixelCMYK8 toBlpCMYK8 = pixelMap convert where - clampWord8 = fromIntegral . max 0 . min 255 - convert (PixelRGBA8 r g b a) = PixelCMYK8 (clampWord8 c) (clampWord8 m) (clampWord8 y) a - where - ik = fromIntegral a :: Double - c, m, y :: Int - c = round $ 256 * fromIntegral b / ik - m = round $ 256 * fromIntegral g / ik - y = round $ 256 * fromIntegral r / ik - -toBlpRGBA8 :: Image PixelRGBA8 -> Image PixelRGBA8 -toBlpRGBA8 = pixelMap convert - where - convert (PixelRGBA8 r g b a) = PixelRGBA8 b g r a - -toBlpRGB8 :: Image PixelRGB8 -> Image PixelRGBA8 -toBlpRGB8 = pixelMap convert - where - convert (PixelRGB8 r g b) = PixelRGBA8 b g r 0 - -convertCMYK16Image :: Image PixelCMYK16 -> Image PixelRGBA16 -convertCMYK16Image = pixelMap convert - where - convert (PixelCMYK16 c m y k) = - PixelRGBA16 (clampWord16 r) (clampWord16 g) (clampWord16 b) 65535 - where - clampWord16 = fromIntegral . max 0 . min 65535 . (`div` 65535) - - ik :: Int - ik = fromIntegral k - r = fromIntegral y * ik - g = fromIntegral m * ik - b = fromIntegral c * ik + convert (PixelRGBA8 r g b a) = PixelCMYK8 b g r a diff --git a/src/Codec/Picture/Blp/Internal/Data.hs b/src/Codec/Picture/Blp/Internal/Data.hs --- a/src/Codec/Picture/Blp/Internal/Data.hs +++ b/src/Codec/Picture/Blp/Internal/Data.hs @@ -7,18 +7,11 @@ ) where import Codec.Picture -import Data.Bifunctor import Data.ByteString (ByteString) -import Data.Hashable -import Data.Monoid import Data.Vector (Vector) import Data.Word import GHC.Generics -import TextShow -import qualified Data.ByteString as BS -import qualified Data.Vector as V - data BlpStruct = BlpStruct { blpCompression :: !BlpCompression , blpFlags :: ![BlpFlag] @@ -29,17 +22,6 @@ , blpExt :: BlpExt } deriving (Show, Generic) -instance TextShow BlpStruct where - showb BlpStruct{..} = "BlpStruct {\n" - <> " blpCompression = " <> showb blpCompression <> "\n" - <> ", blpFlags = " <> showb blpFlags <> "\n" - <> ", blpWidth = " <> showb blpWidth <> "\n" - <> ", blpHeight = " <> showb blpHeight <> "\n" - <> ", blpPictureType = " <> showb blpPictureType <> "\n" - <> ", blpPictureSubType = " <> showb blpPictureSubType <> "\n" - <> ", blpExt = " <> showb blpExt <> "\n" - <> "}" - data BlpExt = BlpJpeg { blpJpegHeader :: !ByteString @@ -55,70 +37,16 @@ } deriving (Show, Generic) --- | Helper to display bytestring as placeholder with length -showBinary :: ByteString -> Builder -showBinary v = " tl v <> ">" - where - tl = showb . BS.length - --- | Helper to display bytestring as placeholder with length -showVector :: Vector a -> Builder -showVector v = " tl v <> ">" - where - tl = showb . V.length - --- | Helper that works as Data.Text.intercalate -intercalateb :: Builder -> [Builder] -> Builder -intercalateb _ [] = mempty -intercalateb _ [x] = x -intercalateb spacer (x:xs) = x <> spacer <> intercalateb spacer xs - -instance TextShow BlpExt where - showb v = case v of - BlpJpeg{..} -> "BlpJpeg { \n" - <> " blpJpegHeader = " <> showBinary blpJpegHeader <> "\n" - <> ", blpJpegData = [" <> intercalateb ", " (fmap showBinary blpJpegData) <> "]\n" - <> "}" - BlpUncompressed1{..} -> "BlpUncompressed1 { \n" - <> " blpU1Palette = " <> showVector blpU1Palette <> "\n" - <> ", blpU1MipMaps = [" <> intercalateb ", " ( (\(a, b) -> "(" <> showBinary a <> ", " <> showBinary b <> ")") <$> blpU1MipMaps) <> "]\n" - <> "}" - BlpUncompressed2{..} -> "BlpUncompressed2 { \n" - <> " blpU2Palette = " <> showVector blpU2Palette <> "\n" - <> ", blpU2MipMaps = [" <> intercalateb ", " (fmap showBinary blpU2MipMaps) <> "]\n" - <> "}" - data BlpCompression = BlpCompressionJPEG | BlpCompressionUncompressed deriving (Eq, Ord, Enum, Bounded, Show, Generic) -instance TextShow BlpCompression where - showb v = case v of - BlpCompressionJPEG -> "BlpCompressionJPEG" - BlpCompressionUncompressed -> "BlpCompressionUncompressed" - -instance Hashable BlpCompression - data BlpFlag = BlpFlagAlphaChannel deriving (Eq, Ord, Enum, Bounded, Show, Generic) -instance TextShow BlpFlag where - showb v = case v of - BlpFlagAlphaChannel -> "BlpFlagAlphaChannel" - -instance Hashable BlpFlag - data BlpPictureType = JPEGType | UncompressedWithAlpha | UncompressedWithoutAlpha deriving (Eq, Ord, Enum, Bounded, Show, Generic) - -instance TextShow BlpPictureType where - showb v = case v of - JPEGType -> "JPEGType" - UncompressedWithAlpha -> "UncompressedWithAlpha" - UncompressedWithoutAlpha -> "UncompressedWithoutAlpha" - -instance Hashable BlpPictureType diff --git a/src/Codec/Picture/Blp/Internal/Encoder.hs b/src/Codec/Picture/Blp/Internal/Encoder.hs --- a/src/Codec/Picture/Blp/Internal/Encoder.hs +++ b/src/Codec/Picture/Blp/Internal/Encoder.hs @@ -16,15 +16,11 @@ import Data.Bits import Data.ByteString.Lazy (ByteString, toStrict) import Data.Foldable (traverse_) -import Data.Maybe -import Data.Monoid import Data.Word -import Foreign -import System.IO.Unsafe (unsafePerformIO) import qualified Codec.Picture.Metadata as CM import qualified Data.ByteString as BS -import qualified Data.ByteString.Unsafe as BS +import qualified Data.ByteString.Internal as BI import qualified Data.Foldable as F import qualified Data.Vector as V import qualified Data.Vector.Storable as VS @@ -38,7 +34,7 @@ -- | Raw encoder for BLP blpEncoder :: Int -> BlpStruct -> Put -blpEncoder numMips BlpStruct{..} = do +blpEncoder requestedMips BlpStruct{..} = do putBlpVersion putCompression putFlags @@ -50,6 +46,8 @@ putMipMapSizes putBlpExt where + -- A file without mip 0 has no image at all, so always write it. + numMips = max 1 requestedMips putBlpVersion = putByteString "BLP1" putCompression = putWord32le $ case blpCompression of BlpCompressionJPEG -> 0 @@ -187,25 +185,25 @@ -- | Convert picture to BLP payload toBlpExt :: BlpCompression -> BlpPictureType -> Int -> Int -> Image PixelRGBA8 -> BlpExt toBlpExt compr pictype quality numMips img = case compr of - BlpCompressionJPEG -> toBlpJpg (fromIntegral quality) numMips hasAlpha img + BlpCompressionJPEG -> toBlpJpg (fromIntegral quality) numMips keepAlpha img BlpCompressionUncompressed -> case pictype of UncompressedWithAlpha -> toBlpUncompressed1 numMips img UncompressedWithoutAlpha -> toBlpUncompressed2 numMips img JPEGType -> toBlpUncompressed2 numMips img -- Consider this as without alpha where - hasAlpha = case pictype of + keepAlpha = case pictype of UncompressedWithAlpha -> True _ -> False -- | Convert picture to BLP JPEG and create mipmaps toBlpJpg :: Word8 -> Int -> Bool -> Image PixelRGBA8 -> BlpExt -toBlpJpg quality numMips hasAlpha img = BlpJpeg { +toBlpJpg quality numMips keepAlpha img = BlpJpeg { blpJpegHeader = header , blpJpegData = mipmapsRawWithoutHeader } where processAlpha :: Image PixelRGBA8 -> Image PixelRGBA8 - processAlpha = pixelMap $ \p@(PixelRGBA8 r g b a) -> if hasAlpha then p else PixelRGBA8 r g b 255 + processAlpha = pixelMap $ \p@(PixelRGBA8 r g b _) -> if keepAlpha then p else PixelRGBA8 r g b 255 mipmaps :: [Image PixelCMYK8] mipmaps = toBlpCMYK8 <$> (fakeMipMaps numMips . createMipMaps . processAlpha $ img) @@ -225,42 +223,31 @@ -- | Manually scan shared prefix of each mipmap scanHeader :: Int -> [BS.ByteString] -> BS.ByteString scanHeader _ [] = mempty -scanHeader maxheader [x] = BS.take maxheader x -scanHeader maxheader mipmaps = go mipmaps mempty +scanHeader maxheader mipmaps@(m0 : _) = BS.take common m0 where - go !mps !acc = let - unconses = BS.uncons <$> mps :: [Maybe (Word8, BS.ByteString)] - heads = fmap fst <$> unconses :: [Maybe Word8] - tails = catMaybes $ fmap snd <$> unconses :: [BS.ByteString] - hitEmpty = any isNothing heads - firstByte = case heads of - (Just v : _) -> v - _ -> 0 - allEqual = all (Just firstByte ==) heads - in if | hitEmpty -> acc - | maxheader >= BS.length acc -> acc - | allEqual -> go tails (acc `BS.snoc` firstByte) - | otherwise -> acc + -- Each mipmap keeps at least one byte of its own: faked mipmaps are + -- copies of a real one, and a header swallowing a whole stream would + -- leave a zero-size slot that readers skip. + limit = min maxheader (minimum (BS.length <$> mipmaps) - 1) + common = length . takeWhile sameAt $ [0 .. limit - 1] + -- Safe to index: every stream is longer than the limit. + sameAt i = all (\m -> BS.index m i == BS.index m0 i) mipmaps -- | Helper to quantise colors to 256 colour pallete makePallette :: Image PixelRGBA8 -> (Image Pixel8, Palette) makePallette = palettize defaultPaletteOptions . pixelMap dropTransparency -instance Storable PixelRGBA8 where - sizeOf _ = sizeOf (undefined :: Word32) - alignment _ = alignment (undefined :: Word32) - peek ptr = unpackPixel <$> peek (castPtr ptr :: Ptr Word32) - poke ptr px = poke (castPtr ptr :: Ptr Word32) . packPixel $ px - -- | Convert palette to format that we need for BLP convertPalette :: Palette -> V.Vector PixelRGBA8 -convertPalette = V.convert . VS.unsafeCast . imageData . pixelMap ((\(PixelRGBA8 r g b a) -> PixelRGBA8 b g r a) . promotePixel :: PixelRGB8 -> PixelRGBA8) +convertPalette palette = V.generate (imageWidth palette) $ \i -> + let PixelRGB8 r g b = pixelAt palette i 0 in PixelRGBA8 b g r 255 -- | Convert indexed image to raw bytestring convertIndexed :: Image Pixel8 -> BS.ByteString convertIndexed img = let (fptr, l) = VS.unsafeToForeignPtr0 . imageData $ img - in unsafePerformIO $ withForeignPtr fptr $ \ptr -> BS.unsafePackCStringLen (castPtr ptr, l) + -- Shares the image buffer without copying; the ByteString keeps it alive. + in BI.fromForeignPtr fptr 0 l -- | Convert picture to BLP uncompressed with alpha and create mipmaps toBlpUncompressed1 :: Int -> Image PixelRGBA8 -> BlpExt diff --git a/src/Codec/Picture/Blp/Internal/Parser.hs b/src/Codec/Picture/Blp/Internal/Parser.hs --- a/src/Codec/Picture/Blp/Internal/Parser.hs +++ b/src/Codec/Picture/Blp/Internal/Parser.hs @@ -18,7 +18,7 @@ import Data.Attoparsec.ByteString as AT import Data.Bits import Data.ByteString (ByteString) -import Data.List (nub) +import Data.List (nub, sortOn) import Data.Word import qualified Data.Vector as V @@ -27,8 +27,8 @@ import Codec.Picture.Blp.Internal.Data -blpParser :: Parser BlpStruct -blpParser = do +blpParser :: Int -> Parser BlpStruct +blpParser inputLen = do _ <- blpVersion blpCompression <- compressionParser blpFlags <- flagsParser @@ -38,10 +38,52 @@ blpPictureSubType <- dword "picture subtype" blpMipMapOffset <- replicateM 16 dword "mipmaps offsets" blpMipMapSize <- replicateM 16 dword "mipmaps sizes" - let mipMapsInfo = nub . filter ((> 0) . snd) $ blpMipMapOffset `zip` blpMipMapSize + -- BLP1 specifies 16 mipmap slots but most files only use a handful; the + -- unused slots should be zero but some real-world files contain garbage + -- offsets/sizes left behind by the writing tool. Drop any slot whose + -- advertised range would run past the end of the file, then sort the + -- survivors by offset so that the monotonic `skipToOffset` walks forward + -- correctly even if the file stored mipmaps out of order. + let rawMipMapsInfo = nub . filter ((> 0) . snd) $ blpMipMapOffset `zip` blpMipMapSize + fitsInput (o, s) = + fromIntegral o + fromIntegral s <= (fromIntegral inputLen :: Integer) + -- Sorting is not enough on its own. `skipToOffset` only ever moves + -- forward, so a slot starting inside a range that has already been + -- consumed can never be reached: the skip stays where it is, the + -- following `take` reads the wrong bytes, and every later mipmap is + -- dragged forward until the walk runs off the end of the file. Slots + -- holding garbage that points back into mipmap 0 are common enough in + -- the wild to matter, so keep only a forward-progressing run. + dropOverlapping :: Integer -> [(Word32, Word32)] -> [(Word32, Word32)] + dropOverlapping _ [] = [] + dropOverlapping end (slot@(o, s) : rest) + | fromIntegral o >= end = + slot : dropOverlapping (fromIntegral o + fromIntegral s) rest + | otherwise = dropOverlapping end rest + mipMapsInfo = + dropOverlapping 0 . sortOn fst . filter fitsInput $ rawMipMapsInfo + -- Some writing tools set `pictureType` to `UncompressedWithAlpha` on + -- files whose mipmap 0 is actually only large enough for a single + -- index plane (w*h bytes) rather than indices + alpha (2*w*h bytes). + -- Trust the physical size over the picture-type byte and decode those + -- files via the without-alpha path instead of crashing on a half-read + -- index list. Anything short of 2*w*h cannot hold both planes, so the + -- check is a range rather than an exact match. + let pixels0 :: Integer + pixels0 = fromIntegral blpWidth * fromIntegral blpHeight + mipZeroSize = case mipMapsInfo of + ((_, s):_) -> fromIntegral s :: Integer + [] -> 0 + mislabeledAsAlpha = + blpPictureType == UncompressedWithAlpha && + pixels0 > 0 && + mipZeroSize >= pixels0 && + mipZeroSize < 2 * pixels0 + effectivePictureType = + if mislabeledAsAlpha then UncompressedWithoutAlpha else blpPictureType blpExt <- case blpCompression of BlpCompressionJPEG -> blpJpegParser mipMapsInfo - BlpCompressionUncompressed -> case blpPictureType of + BlpCompressionUncompressed -> case effectivePictureType of JPEGType -> fail "JPEG type with Uncompressed type mix" UncompressedWithAlpha -> blpUncompressed1Parser mipMapsInfo UncompressedWithoutAlpha -> blpUncompressed2Parser mipMapsInfo @@ -80,10 +122,18 @@ pictureTypeParser = ( "picture type") $ do i <- dword case i of + 0 -> return UncompressedWithAlpha 2 -> return JPEGType 3 -> return UncompressedWithAlpha 4 -> return UncompressedWithAlpha 5 -> return UncompressedWithoutAlpha + -- BLP1 files seen in the wild (notably from World of Warcraft assets, + -- as well as some BLPs found inside Warcraft III maps) use picture type + -- 6 for JPEG-compressed textures with an alpha channel. The actual data + -- layout is identical to type 2, and the dispatch in `blpParser` already + -- decides JPEG vs uncompressed based on the `compression` field, so we + -- can safely treat 6 as another spelling of `JPEGType`. + 6 -> return JPEGType _ -> fail $ "Unknown picture type " ++ show i blpJpegParser :: [(Word32, Word32)] -> Parser BlpExt @@ -105,9 +155,27 @@ if diff <= 0 then return () else void $ AT.take diff +-- | Read up to 256 palette entries, bounded by the offset of the first +-- mipmap. Some BLP1 files in the wild (e.g. produced by community map +-- tools) only emit the palette entries that are actually used, so the +-- palette region between the main header and the first mipmap can be +-- shorter than the canonical 1024 bytes. We pad the resulting vector to +-- 256 entries with transparent black so the rest of the codebase, which +-- indexes the palette by an arbitrary `Word8`, stays sound. +paletteParser :: [(Word32, Word32)] -> Parser (V.Vector PixelRGBA8) +paletteParser mps = do + pos <- getPos + let firstOffset = case mps of + ((o, _):_) -> fromIntegral o + [] -> pos + 1024 -- no mipmaps: keep historical behaviour + available = max 0 (firstOffset - pos) + nEntries = min 256 (available `div` 4) + entries <- V.replicateM nEntries rgba8 + return $ entries V.++ V.replicate (256 - nEntries) (PixelRGBA8 0 0 0 0) + blpUncompressed1Parser :: [(Word32, Word32)] -> Parser BlpExt blpUncompressed1Parser mps = do - blpU1Palette <- V.replicateM 256 rgba8 + blpU1Palette <- paletteParser mps blpU1MipMaps <- forM mps $ \(offset, size) -> do skipToOffset offset let halfSize = fromIntegral size `div` 2 @@ -118,11 +186,11 @@ blpUncompressed2Parser :: [(Word32, Word32)] -> Parser BlpExt blpUncompressed2Parser mps = do - blpU2Palette <- V.replicateM 256 rgba8 + blpU2Palette <- paletteParser mps blpU2MipMaps <- forM mps $ \(offset, size) -> do skipToOffset offset AT.take (fromIntegral size) "index list" return $ BlpUncompressed2 {..} parseBlp :: ByteString -> Either String BlpStruct -parseBlp = parseOnly blpParser +parseBlp bs = parseOnly (blpParser (BS.length bs)) bs diff --git a/test/Fixture.hs b/test/Fixture.hs new file mode 100644 --- /dev/null +++ b/test/Fixture.hs @@ -0,0 +1,97 @@ +-- | Byte-level BLP1 builder for tests. +-- +-- Uncompressed files are assembled here field by field rather than with the +-- library's encoder, so decoder tests do not depend on the encoder being +-- right. JPEG files are taken from the encoder and patched with 'setDword'. +module Fixture( + Header(..) + , defHeader + , headerSize + , blpFile + , uncompressed + , PaletteEntry + , paletteBytes + , getDword + , setDword + , offsetSlot + , sizeSlot + , pictureTypeOffset + ) where + +import Data.Bits +import Data.ByteString (ByteString) +import Data.Word + +import qualified Data.ByteString as BS + +data Header = Header { + hCompression :: Word32 +, hFlags :: Word32 +, hWidth :: Word32 +, hHeight :: Word32 +, hPictureType :: Word32 +, hSubType :: Word32 +} + +-- | Uncompressed, with-alpha 4x4 header; override fields as needed. +defHeader :: Header +defHeader = Header { + hCompression = 1 + , hFlags = 8 + , hWidth = 4 + , hHeight = 4 + , hPictureType = 4 + , hSubType = 5 + } + +-- | Size of the fixed BLP1 header: tag, six dwords, 16 offsets, 16 sizes. +headerSize :: Int +headerSize = 156 + +-- | Assemble a file from a header, the mipmap slots (padded to 16 with zeros) +-- and everything that follows the header. +blpFile :: Header -> [(Word32, Word32)] -> ByteString -> ByteString +blpFile Header{..} slots body = BS.concat + [ "BLP1" + , dwords [hCompression, hFlags, hWidth, hHeight, hPictureType, hSubType] + , dwords (map fst slots') , dwords (map snd slots') + , body + ] + where + slots' = take 16 $ slots ++ repeat (0, 0) + +-- | Palette entry as it is stored in the file: blue, green, red, alpha. +type PaletteEntry = (Word8, Word8, Word8, Word8) + +paletteBytes :: [PaletteEntry] -> ByteString +paletteBytes es = BS.pack $ concat [[b, g, r, a] | (b, g, r, a) <- es] + +-- | Uncompressed file: header, palette, then each mipmap back to back with +-- slots pointing at them. +uncompressed :: Header -> [PaletteEntry] -> [ByteString] -> ByteString +uncompressed h palette mips = blpFile h slots (pal <> BS.concat mips) + where + pal = paletteBytes palette + sizes = map (fromIntegral . BS.length) mips + offsets = scanl (+) (fromIntegral $ headerSize + BS.length pal) sizes + slots = zip offsets sizes + +dwords :: [Word32] -> ByteString +dwords = BS.concat . map dword + +dword :: Word32 -> ByteString +dword v = BS.pack [fromIntegral (v `shiftR` (8 * i)) | i <- [0 .. 3]] + +getDword :: Int -> ByteString -> Word32 +getDword o bs = foldr (\i acc -> acc `shiftL` 8 .|. fromIntegral (BS.index bs (o + i))) 0 [0 .. 3] + +setDword :: Int -> Word32 -> ByteString -> ByteString +setDword o v bs = BS.take o bs <> dword v <> BS.drop (o + 4) bs + +-- | File offsets of the header fields that tests patch. +pictureTypeOffset :: Int +pictureTypeOffset = 20 + +offsetSlot, sizeSlot :: Int -> Int +offsetSlot i = 28 + 4 * i +sizeSlot i = 92 + 4 * i diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,331 @@ +module Main(main) where + +import Codec.Picture +import Codec.Picture.Blp +import Codec.Picture.Types (convertImage) +import Control.Exception (bracket_, try) +import Control.Monad (forM_) +import Data.ByteString (ByteString) +import Data.List (isInfixOf) +import Data.Word +import System.Directory (getTemporaryDirectory, removeFile) +import System.FilePath (()) +import Test.Tasty +import Test.Tasty.HUnit + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BSL + +import Fixture + +main :: IO () +main = defaultMain $ testGroup "JuicyPixels-blp" + [ uncompressedTests + , malformedTests + , jpegTests + , encoderTests + , fileTests + ] + +-- | 4x4 test texture: pixel (x, y) is palette index @y*4+x@. +indices :: ByteString +indices = BS.pack [0 .. 15] + +-- | Alpha plane of the with-alpha variant. +alphaPlane :: ByteString +alphaPlane = BS.pack [k * 16 + 15 | k <- [0 .. 15]] + +-- | Palette stored in the file; only the first 16 entries are referenced. +palette :: Int -> [PaletteEntry] +palette n = take n $ [(k * 3, 255 - k * 16, k * 16, 0) | k <- [0 .. 15]] ++ repeat (0, 0, 0, 0) + +-- | What the decoder should produce for index @k@: palette colour, alpha from +-- the alpha plane (with alpha) or opaque (without alpha). +withAlphaPixel, withoutAlphaPixel :: Word8 -> PixelRGBA8 +withAlphaPixel k = PixelRGBA8 (k * 16) (255 - k * 16) (k * 3) (k * 16 + 15) +withoutAlphaPixel k = PixelRGBA8 (k * 16) (255 - k * 16) (k * 3) 255 + +withAlphaFile :: Word32 -> ByteString +withAlphaFile ptype = uncompressed defHeader { hPictureType = ptype } (palette 256) [indices <> alphaPlane] + +withoutAlphaFile :: ByteString +withoutAlphaFile = uncompressed defHeader { hFlags = 0, hPictureType = 5 } (palette 256) [indices] + +pixelsOf :: Image PixelRGBA8 -> [PixelRGBA8] +pixelsOf img = [pixelAt img x y | y <- [0 .. imageHeight img - 1], x <- [0 .. imageWidth img - 1]] + +decodeRGBA :: ByteString -> IO (Image PixelRGBA8) +decodeRGBA bs = either (assertFailure . ("decodeBlp: " ++)) (return . convertRGBA8) $ decodeBlp bs + +decodeLevels :: ByteString -> IO [Image PixelRGBA8] +decodeLevels bs = either (assertFailure . ("decodeBlpMipmaps: " ++)) (return . map convertRGBA8) $ decodeBlpMipmaps bs + +assertPixels :: (Word8 -> PixelRGBA8) -> ByteString -> Assertion +assertPixels expected bs = do + img <- decodeRGBA bs + (imageWidth img, imageHeight img) @?= (4, 4) + pixelsOf img @?= map expected [0 .. 15] + +assertLeft :: String -> Either String a -> Assertion +assertLeft needle r = case r of + Left e -> assertBool ("error " ++ show e ++ " should mention " ++ show needle) (needle `isInfixOf` e) + Right _ -> assertFailure "expected a decoding error" + +uncompressedTests :: TestTree +uncompressedTests = testGroup "uncompressed" + [ testCase "with alpha, picture type 4" $ assertPixels withAlphaPixel (withAlphaFile 4) + , testCase "with alpha, picture type 3" $ assertPixels withAlphaPixel (withAlphaFile 3) + , testCase "picture type 0 decodes as with alpha (#10)" $ assertPixels withAlphaPixel (withAlphaFile 0) + , testCase "without alpha, picture type 5" $ assertPixels withoutAlphaPixel withoutAlphaFile + , testCase "without alpha ignores the palette's fourth byte (#14)" $ + assertPixels withoutAlphaPixel $ uncompressed defHeader { hFlags = 0, hPictureType = 5 } + [(b, g, r, 255) | (b, g, r, _) <- palette 256] [indices] + , testCase "labelled with alpha, mip 0 holds only indices (#8)" $ + assertPixels withoutAlphaPixel $ uncompressed defHeader (palette 256) [indices] + , testCase "labelled with alpha, mip 0 between one and two planes (#8)" $ + assertPixels withoutAlphaPixel $ uncompressed defHeader (palette 256) [indices <> "pad"] + , testCase "palette shorter than 256 entries (#6)" $ + assertPixels withoutAlphaPixel $ uncompressed defHeader { hFlags = 0, hPictureType = 5 } (palette 16) [indices] + , testCase "mipmap slot past the end of the file is skipped (#7)" $ do + let bs = setDword (offsetSlot 1) 100000 . setDword (sizeSlot 1) 16 $ withAlphaFile 4 + assertPixels withAlphaPixel bs + levels <- decodeLevels bs + length levels @?= 1 + , testCase "mipmap slot overlapping mip 0 is skipped (#7)" $ do + let mip0 = getDword (offsetSlot 0) (withAlphaFile 4) + bs = setDword (offsetSlot 1) (mip0 + 4) . setDword (sizeSlot 1) 8 $ withAlphaFile 4 + assertPixels withAlphaPixel bs + levels <- decodeLevels bs + length levels @?= 1 + , testCase "with alpha mip levels have their own sizes (#13)" $ do + let bs = uncompressed defHeader (palette 256) + [indices <> alphaPlane, "\1\2\3\4" <> "\5\6\7\8", "\9" <> "\10"] + levels <- decodeLevels bs + sizes levels @?= [(4, 4), (2, 2), (1, 1)] + pixelsOf (levels !! 1) @?= [PixelRGBA8 (k * 16) (255 - k * 16) (k * 3) (k + 4) | k <- [1 .. 4]] + pixelsOf (levels !! 2) @?= [PixelRGBA8 144 111 27 10] + , testCase "without alpha mip levels have their own sizes (#13)" $ do + let bs = uncompressed defHeader { hFlags = 0, hPictureType = 5 } (palette 256) [indices, "\1\2\3\4", "\9"] + levels <- decodeLevels bs + sizes levels @?= [(4, 4), (2, 2), (1, 1)] + pixelsOf (levels !! 1) @?= map withoutAlphaPixel [1 .. 4] + , testCase "non-square texture halves each side down to 1 (#13)" $ do + let bs = uncompressed defHeader { hFlags = 0, hPictureType = 5, hWidth = 4, hHeight = 2 } (palette 256) + [BS.take 8 indices, "\1\2", "\3"] + levels <- decodeLevels bs + sizes levels @?= [(4, 2), (2, 1), (1, 1)] + , testCase "mip level shorter than its size ends the list (#13)" $ do + let bs = uncompressed defHeader { hFlags = 0, hPictureType = 5 } (palette 256) [indices, "\1\2", "\9"] + levels <- decodeLevels bs + sizes levels @?= [(4, 4)] + , testCase "mip 0 shorter than the image is an error, not an exception (#13)" $ + assertLeft "too short" . decodeBlp $ uncompressed defHeader { hFlags = 0, hPictureType = 5 } (palette 256) [BS.take 8 indices] + ] + +malformedTests :: TestTree +malformedTests = testGroup "malformed input" + [ testCase "wrong version tag" $ + assertLeft "BLP1" . decodeBlp $ "BLP2" <> BS.drop 4 (withAlphaFile 4) + , testCase "unknown compression" $ + assertLeft "compression" . decodeBlp $ uncompressed defHeader { hCompression = 7 } (palette 256) [indices] + , testCase "unknown picture type" $ + assertLeft "picture type" . decodeBlp $ withAlphaFile 9 + , testCase "uncompressed file with JPEG picture type" $ + assertLeft "JPEG type" . decodeBlp $ withAlphaFile 2 + , testCase "truncated header" $ + assertLeft "" . decodeBlp $ BS.take 100 (withAlphaFile 4) + , testCase "empty input" $ + assertLeft "" $ decodeBlp BS.empty + , testCase "file cut inside the header names the field" $ + assertLeft "mipmaps sizes" . decodeBlp $ BS.take 100 (withAlphaFile 4) + , testCase "JPEG header longer than the file" $ + assertLeft "jpeg header" . decodeBlp $ setDword headerSize 100000 jpegFile + , testCase "uncompressed file without mipmaps" $ + assertLeft "No data" . decodeBlp $ blpFile defHeader [] (paletteBytes $ palette 256) + , testCase "JPEG file without mipmaps" $ + assertLeft "No JPEG mipmap data" . decodeBlp $ blpFile defHeader { hCompression = 0 } [] "\0\0\0\0" + ] + +-- | 16x16 texture with colour and alpha gradients, enough for three mip levels. +gradient :: Image PixelRGBA8 +gradient = generateImage px 16 16 + where + px x y = PixelRGBA8 (fromIntegral $ x * 16) (fromIntegral $ y * 16) 128 (fromIntegral $ 255 - x * 8) + +-- | 'gradient' with the alpha plane flattened to opaque. +opaqueGradient :: Image PixelRGBA8 +opaqueGradient = pixelMap (\(PixelRGBA8 r g b _) -> PixelRGBA8 r g b 255) gradient + +jpegFile :: ByteString +jpegFile = BSL.toStrict $ encodeBlpJpeg 100 3 (ImageRGBA8 gradient) + +-- | Largest per-channel difference between two equally sized images. +maxDiff :: Image PixelRGBA8 -> Image PixelRGBA8 -> Int +maxDiff a b = maximum $ zipWith diff (pixelsOf a) (pixelsOf b) + where + diff (PixelRGBA8 r g b' x) (PixelRGBA8 r2 g2 b2 x2) = + maximum [d r r2, d g g2, d b' b2, d x x2] + d u v = abs (fromIntegral u - fromIntegral v :: Int) + +sizes :: [Image PixelRGBA8] -> [(Int, Int)] +sizes = map (\i -> (imageWidth i, imageHeight i)) + +jpegTests :: TestTree +jpegTests = testGroup "jpeg" + [ testCase "opaque texture round-trips through the encoder (#11)" $ do + img <- decodeRGBA . BSL.toStrict $ encodeBlpJpeg 100 1 (ImageRGBA8 opaqueGradient) + let d = maxDiff opaqueGradient img + assertBool ("max channel difference " ++ show d) (d <= 8) + , testCase "all three mip levels decode" $ do + levels <- decodeLevels jpegFile + sizes levels @?= [(16, 16), (8, 8), (4, 4)] + , testCase "picture type 6 decodes like the original (#5)" $ do + orig <- decodeRGBA jpegFile + img <- decodeRGBA (setDword pictureTypeOffset 6 jpegFile) + pixelsOf img @?= pixelsOf orig + , testCase "broken middle mip keeps only the levels before it (#9)" $ do + levels <- decodeLevels (setDword (sizeSlot 1) 12 jpegFile) + sizes levels @?= [(16, 16)] + , testCase "broken last mip keeps the levels before it (#9)" $ do + levels <- decodeLevels (setDword (sizeSlot 2) 12 jpegFile) + sizes levels @?= [(16, 16), (8, 8)] + , testCase "broken mip 0 fails the file" $ + assertLeft "" . decodeBlp $ setDword (sizeSlot 0) 12 jpegFile + , testCase "three-component JPEG decodes to RGBA" $ do + let rgb = generateImage (\x y -> PixelRGB8 (fromIntegral $ x * 16) (fromIntegral $ y * 16) 128) 16 16 + jpeg = BSL.toStrict . encodeJpeg $ (convertImage rgb :: Image PixelYCbCr8) + bs = blpFile defHeader { hCompression = 0, hFlags = 0, hWidth = 16, hHeight = 16, hPictureType = 2 } + [(fromIntegral headerSize + 4, fromIntegral $ BS.length jpeg)] ("\0\0\0\0" <> jpeg) + dyn <- either (assertFailure . ("decodeBlp: " ++)) return $ decodeBlp bs + case dyn of + ImageRGBA8 img -> do + direct <- either (assertFailure . ("decodeJpeg: " ++)) (return . convertRGBA8) $ decodeJpeg jpeg + pixelsOf img @?= pixelsOf direct + _ -> assertFailure "expected ImageRGBA8" + , testCase "semi-transparent texture round-trips through the encoder (#17)" $ do + img <- decodeRGBA . BSL.toStrict $ encodeBlpJpeg 100 1 (ImageRGBA8 gradient) + let d = maxDiff gradient img + assertBool ("max channel difference " ++ show d) (d <= 8) + , testCase "uniformly semi-transparent texture keeps its alpha (#17)" $ do + let solid = generateImage (\_ _ -> PixelRGBA8 200 100 50 128) 8 8 + img <- decodeRGBA . BSL.toStrict $ encodeBlpJpeg 100 1 (ImageRGBA8 solid) + let d = maxDiff solid img + assertBool ("max channel difference " ++ show d) (d <= 4) + , testCase "all-zero alpha plane means opaque (#11)" $ do + let clear = generateImage (\_ _ -> PixelRGBA8 200 100 50 0) 8 8 + opaque = pixelMap (\(PixelRGBA8 r g b _) -> PixelRGBA8 r g b 255) clear + img <- decodeRGBA . BSL.toStrict $ encodeBlpJpeg 100 1 (ImageRGBA8 clear) + let d = maxDiff opaque img + assertBool ("max channel difference " ++ show d) (d <= 4) + , testCase "mipmaps share a JPEG header (#18)" $ do + let shared = getDword headerSize jpegFile + assertBool ("shared header size " ++ show shared) (shared > 0 && shared <= 624) + levels <- decodeLevels jpegFile + sizes levels @?= [(16, 16), (8, 8), (4, 4)] + , testCase "single mipmap keeps its data out of the shared header (#18)" $ do + let tiny = generateImage (\_ _ -> PixelRGBA8 200 100 50 255) 1 1 + img <- decodeRGBA . BSL.toStrict $ encodeBlpJpeg 100 1 (ImageRGBA8 tiny) + let d = maxDiff tiny img + assertBool ("max channel difference " ++ show d) (d <= 4) + ] + +encoderTests :: TestTree +encoderTests = testGroup "encoder" + [ testCase "with alpha writes the expected header" $ do + let bs = BSL.toStrict $ encodeBlpUncompressedWithAlpha 3 (ImageRGBA8 gradient) + map (`getDword` bs) [4, 8, 12, 16] @?= [1, 8, 16, 16] + getDword pictureTypeOffset bs @?= 3 + map (\i -> getDword (sizeSlot i) bs) [0 .. 2] @?= [512, 128, 32] + , testCase "without alpha writes the expected header" $ do + let bs = BSL.toStrict $ encodeBlpUncompressedWithoutAlpha 3 (ImageRGB8 $ convertRGB8 (ImageRGBA8 gradient)) + map (`getDword` bs) [4, 8] @?= [1, 0] + getDword pictureTypeOffset bs @?= 5 + map (\i -> getDword (sizeSlot i) bs) [0 .. 2] @?= [256, 64, 16] + , testCase "with alpha round-trips mip 0" $ do + img <- decodeRGBA . BSL.toStrict $ encodeBlpUncompressedWithAlpha 1 (ImageRGBA8 gradient) + let d = maxDiff gradient img + assertBool ("max channel difference " ++ show d) (d <= 8) + , testCase "without alpha round-trips mip 0 (#14)" $ do + let opaque = convertRGB8 (ImageRGBA8 opaqueGradient) + img <- decodeRGBA . BSL.toStrict $ encodeBlpUncompressedWithoutAlpha 1 (ImageRGB8 opaque) + let d = maxDiff opaqueGradient img + assertBool ("max channel difference " ++ show d) (d <= 8) + , testCase "encoded mipmaps decode at their own sizes (#13)" $ do + levels <- decodeLevels . BSL.toStrict $ encodeBlpUncompressedWithAlpha 3 (ImageRGBA8 gradient) + sizes levels @?= [(16, 16), (8, 8), (4, 4)] + , testCase "JPEG alpha flag and picture type follow the input format" $ do + let header dyn = let bs = BSL.toStrict $ encodeBlpJpeg 90 1 dyn + in (getDword 8 bs, getDword pictureTypeOffset bs) + rgba = convertRGBA8 (ImageRGBA8 gradient) + header (ImageY8 $ pixelMap (\(PixelRGBA8 r _ _ _) -> r) rgba) @?= (0, 5) + header (ImageYA8 $ pixelMap (\(PixelRGBA8 r _ _ a) -> PixelYA8 r a) rgba) @?= (8, 3) + header (ImageRGB16 $ pixelMap (\(PixelRGBA8 r g b _) -> PixelRGB16 (w16 r) (w16 g) (w16 b)) rgba) @?= (0, 5) + header (ImageRGBA16 $ pixelMap (\(PixelRGBA8 r g b a) -> PixelRGBA16 (w16 r) (w16 g) (w16 b) (w16 a)) rgba) @?= (8, 3) + , testCase "without alpha drops the alpha of an RGBA input" $ do + let bs = BSL.toStrict $ encodeBlpUncompressedWithoutAlpha 1 (ImageRGBA8 gradient) + (getDword 8 bs, getDword pictureTypeOffset bs) @?= (0, 5) + img <- decodeRGBA bs + let d = maxDiff opaqueGradient img + assertBool ("max channel difference " ++ show d) (d <= 8) + , testCase "with alpha keeps an alpha plane for an RGB input" $ do + let bs = BSL.toStrict $ encodeBlpUncompressedWithAlpha 1 (ImageRGB8 $ convertRGB8 (ImageRGBA8 opaqueGradient)) + (getDword 8 bs, getDword pictureTypeOffset bs) @?= (8, 3) + img <- decodeRGBA bs + let d = maxDiff opaqueGradient img + assertBool ("max channel difference " ++ show d) (d <= 8) + , testCase "JPEG without alpha decodes opaque" $ do + let bs = BSL.toStrict $ encodeBlpJpeg 100 1 (ImageRGB8 $ convertRGB8 (ImageRGBA8 gradient)) + getDword 8 bs @?= 0 + img <- decodeRGBA bs + let d = maxDiff opaqueGradient img + assertBool ("max channel difference " ++ show d) (d <= 8) + , testCase "asking for more mipmaps than levels stops at 1x1" $ do + levels <- decodeLevels . BSL.toStrict $ encodeBlpUncompressedWithAlpha 20 (ImageRGBA8 gradient) + sizes levels @?= [(16, 16), (8, 8), (4, 4), (2, 2), (1, 1)] + , testCase "non-square mip chain stops when a side reaches 1" $ do + let wide = generateImage (\x y -> PixelRGBA8 (fromIntegral x) (fromIntegral y) 0 255) 64 16 + levels <- decodeLevels . BSL.toStrict $ encodeBlpJpeg 90 16 (ImageRGBA8 wide) + sizes levels @?= [(64, 16), (32, 8), (16, 4), (8, 2), (4, 1)] + odd' <- decodeLevels . BSL.toStrict $ encodeBlpUncompressedWithAlpha 16 (ImageRGBA8 $ generateImage (\_ _ -> PixelRGBA8 1 2 3 4) 5 3) + sizes odd' @?= [(5, 3), (2, 1)] + , testCase "mipMapsUpTo counts every level down to the minimum side" $ do + let img w h = ImageRGBA8 $ generateImage (\_ _ -> PixelRGBA8 0 0 0 0) w h + mipMapsUpTo 1 (img 16 16) @?= 5 + mipMapsUpTo 4 (img 16 16) @?= 3 + mipMapsUpTo 1 (img 64 16) @?= 5 + mipMapsUpTo 1 (img 5 5) @?= 3 + mipMapsUpTo 1 (img 1 1) @?= 1 + mipMapsUpTo 32 (img 16 16) @?= 1 + , testCase "zero or negative mipmap count still writes mip 0" $ do + let enc n = [ encodeBlpJpeg 90 n (ImageRGBA8 gradient) + , encodeBlpUncompressedWithAlpha n (ImageRGBA8 gradient) ] + forM_ (concatMap enc [0, -1]) $ \bs -> do + levels <- decodeLevels (BSL.toStrict bs) + sizes levels @?= [(16, 16)] + ] + +fileTests :: TestTree +fileTests = testGroup "files" + [ testCase "write and read back each format" $ do + tmp <- getTemporaryDirectory + let path = tmp "juicypixels-blp-test.blp" + img = ImageRGBA8 opaqueGradient + check write = bracket_ (write path) (removeFile path) $ do + Right single <- readBlp path + let d = maxDiff opaqueGradient (convertRGBA8 single) + assertBool ("max channel difference " ++ show d) (d <= 8) + Right levels <- readBlpMipmaps path + sizes (map convertRGBA8 levels) @?= [(16, 16), (8, 8)] + check $ \p -> writeBlpJpeg p 100 2 img + check $ \p -> writeBlpUncompressedWithAlpha p 2 img + check $ \p -> writeBlpUncompressedWithoutAlpha p 2 (ImageRGB8 $ convertRGB8 img) + , testCase "missing file is an IO error" $ do + r <- tryIO $ readBlp "/nonexistent/juicypixels-blp.blp" + assertBool "readBlp should throw" (either (const True) (const False) r) + ] + where + tryIO :: IO a -> IO (Either IOError a) + tryIO = try + +w16 :: Word8 -> Word16 +w16 v = fromIntegral v * 257