JuicyPixels-blp 0.2.0.0 → 0.3.0.0

raw patch · 13 files changed

+821/−289 lines, 13 filesdep +containersdep +tastydep +tasty-hunitdep −hashabledep −text-showdep −unordered-containersdep ~JuicyPixelsdep ~attoparsecdep ~basePVP ok

version bump matches the API change (PVP)

Dependencies added: containers, tasty, tasty-hunit

Dependencies removed: hashable, text-show, unordered-containers

Dependency ranges changed: JuicyPixels, attoparsec, base, bytestring, directory, filepath, vector

API changes (from Hackage documentation)

Files

• CHANGELOG.md +57/−0
• JuicyPixels-blp.cabal +48/−17
• README.md +1/−1
• blp2any/Convert.hs +0/−1
• blp2any/Main.hs +0/−1
• blp2any/Statistics.hs +5/−5
• src/Codec/Picture/Blp.hs +126/−51
• src/Codec/Picture/Blp/Internal/Convert.hs +60/−100
• src/Codec/Picture/Blp/Internal/Data.hs +0/−72
• src/Codec/Picture/Blp/Internal/Encoder.hs +20/−33
• src/Codec/Picture/Blp/Internal/Parser.hs +76/−8
• test/Fixture.hs +97/−0
• test/Main.hs +331/−0

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

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

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

@@ -12,7 +12,6 @@ import Control.Monad import Data.Char import Data.Maybe-import Data.Monoid import System.Directory import System.FilePath 

@@ -1,6 +1,5 @@ module Main where -import Data.Monoid import Options.Applicative.Simple  import Statistics

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

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

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

@@ -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 = "<bslength " <> tl v <> ">"-  where-    tl = showb . BS.length---- | Helper to display bytestring as placeholder with length-showVector :: Vector a -> Builder-showVector v = "<veclength " <> 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

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

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

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

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