JuicyPixels-blp 0.3.0.0 → 0.4.0.0

raw patch · 16 files changed

+1396/−617 lines, 16 filesdep +deepseqdep +tasty-benchdep +transformersdep ~JuicyPixelsdep ~basedep ~bytestringPVP ok

version bump matches the API change (PVP)

Dependencies added: deepseq, tasty-bench, transformers

Dependency ranges changed: JuicyPixels, base, bytestring

API changes (from Hackage documentation)

Files

• CHANGELOG.md +79/−0
• JuicyPixels-blp.cabal +31/−6
• README.md +146/−8
• bench/Main.hs +111/−0
• blp2any/Convert.hs +55/−48
• blp2any/File.hs +26/−21
• blp2any/Main.hs +14/−11
• blp2any/Statistics.hs +15/−11
• docs/format.md +175/−0
• src/Codec/Picture/Blp.hs +155/−80
• src/Codec/Picture/Blp/Internal/Convert.hs +40/−31
• src/Codec/Picture/Blp/Internal/Data.hs +69/−24
• src/Codec/Picture/Blp/Internal/Encoder.hs +142/−188
• src/Codec/Picture/Blp/Internal/Parser.hs +133/−156
• test/Deprecated.hs +31/−0
• test/Main.hs +174/−33

@@ -1,3 +1,82 @@+0.4.0.0 (2026-10-15)+====================++Breaking changes:++- New encoding API: `encodeBlpWith` and `writeBlpWith` take+  `BlpEncodeOptions` (a `BlpFormat` and a mip level count) and return+  `Either BlpEncodeError`. Empty images, sides above 65535, JPEG quality+  outside 1..100 and files over 4 GiB are errors instead of crashes or+  silent wrap-around (#31). `encodeBlpJpeg`, `encodeBlpUncompressedWithAlpha`,+  `encodeBlpUncompressedWithoutAlpha` and their `writeBlp*` variants still+  work as deprecated wrappers; they clamp the JPEG quality, which used to+  wrap modulo 256.+- The decoder takes alpha from the `alphaBits` header field, as the format+  specifies, instead of from the `extra` field. Paletted files with 1-bit and+  4-bit alpha now decode, files whose `extra` field says otherwise keep their+  alpha, and unknown `extra` values are no longer rejected (#25).+- Non-square textures get the full mip chain down to 1x1 instead of+  stopping when the shorter side reaches one pixel, and `mipMapsUpTo` counts+  levels by the larger side, capped at 16 (#26, #31).+- Mipmap colour is averaged with alpha as the weight, so transparent pixels+  no longer darken the edges of sprites, and the alpha of paletted mipmaps+  is averaged instead of sampled. Opaque textures encode exactly as before+  (#32).+- `Codec.Picture.Blp.Internal.*`:+  - `BlpStruct` keeps the raw header values in `blpAlphaBits`, `blpExtra` and+    `blpHasMipmaps`; `blpCompression` is a function of `blpExt`. `BlpFlag` and+    `BlpPictureType` are gone.+  - Paletted content is one `BlpPaletted` constructor holding each level's+    raw data.+  - The parser is `parseBlp` plus `mipLevels` and `jpegFrameSize`; the+    attoparsec walk over the content (`blpJpegParser`, `skipToOffset`, ...)+    is gone.+  - `encodeBlp` and `blpEncoder` take just the `BlpStruct`; `toBlpStruct`+    takes a `BlpFormat`.++Decoding untrusted files (#30):++- Errors that JuicyPixels' JPEG decoder raises from pure code are returned+  as `Left`; in a tail mipmap they end the list.+- Width and height must be between 1 and 65535. Larger values used to+  overflow the size checks and leave an exception in the decoded image.+- Each JPEG level's frame size is read before decoding. A frame larger than+  the level is rejected, so an 800-byte file can no longer demand gigabytes;+  a smaller one is padded with transparent black.+- Mipmap slots are read by index. A missing or garbage slot ends the chain+  instead of shifting the later levels, and a garbage slot that points into+  the palette no longer breaks the file.+- Some corrupt JPEG streams still make JuicyPixels loop forever+  (haskell-github-trust/Juicy.Pixels#230), so decoding untrusted files needs+  a timeout.++Encoder fixes (#31):++- Unused mipmap slots are zero, as the format requires, and `hasMipmaps` is+  0 when only one level is written.+- Only the levels that are written are encoded; asking for one level of a+  2048x2048 JPEG texture used to encode all of them.++Faster (#34): JPEG decoding is 2.1–2.7x and JPEG encoding 2.2–2.8x as fast,+measured with the new benchmark suite (`bench/Main.hs`). Output is+byte-identical.++blp2any (#33):++- `-s`/`--shallow` and `-p` (now also `--flatten`) were accepted but did+  nothing; they now keep conversion to the top folder and write all output+  into one folder.+- A file that fails no longer aborts a batch conversion or `stats`: it is+  reported on stderr and skipped, and `convert` prints a summary and exits+  with status 1 if anything failed.+- An input folder given with a trailing slash no longer sends output to the+  root of the file system.+- `--version` reports the package version.++Documentation: `docs/format.md` describes the BLP1 format and what the+library does with each part; the README covers usage, `blp2any`,+limitations and benchmarking; every module has haddock (#27).+ 0.3.0.0 (2026-10-15) ==================== 

@@ -1,12 +1,16 @@ cabal-version:       2.2 name:                JuicyPixels-blp-version:             0.3.0.0+version:             0.4.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.+  Read and write BLP1, the texture format of Warcraft III, with images as+  [JuicyPixels](https://hackage.haskell.org/package/JuicyPixels) types.+  Supports JPEG and paletted content with and without alpha, mipmaps, and+  the non-standard files common in community maps. Includes @blp2any@, a+  converter between BLP and PNG, JPEG, TIFF, GIF and BMP.+  .+  See the README for usage and limitations, and @docs/format.md@ for the+  file format. homepage:            https://github.com/NCrashed/JuicyPixels-blp#readme license:             BSD-3-Clause license-file:        LICENSE@@ -15,7 +19,7 @@ copyright:           2015-2026 Anton Gushcha category:            Codec, Graphics, Image build-type:          Simple-extra-doc-files:     README.md, CHANGELOG.md+extra-doc-files:     README.md, CHANGELOG.md, docs/format.md tested-with:   GHC == 9.4.8    || == 9.6.7@@ -47,6 +51,7 @@     , attoparsec            >= 0.12   && < 0.15     , binary                >= 0.8    && < 0.10     , bytestring            >= 0.10   && < 0.13+    , deepseq               >= 1.4    && < 1.6     , JuicyPixels           >= 3.2    && < 3.4     , vector                >= 0.10   && < 0.14 @@ -65,6 +70,9 @@     Convert     File     Statistics+    Paths_JuicyPixels_blp+  autogen-modules:+    Paths_JuicyPixels_blp   ghc-options:       -threaded -rtsopts -with-rtsopts=-N   default-language:    Haskell2010   build-depends:@@ -76,16 +84,33 @@     , JuicyPixels     , JuicyPixels-blp     , optparse-simple       >= 0.0.3  && < 0.2+    , transformers          >= 0.5    && < 0.7    default-extensions:     RecordWildCards +benchmark bench+  import:              warnings+  type:                exitcode-stdio-1.0+  hs-source-dirs:      bench+  main-is:             Main.hs+  default-language:    Haskell2010+  ghc-options:         -rtsopts -with-rtsopts=-A32m+  build-depends:+      base+    , bytestring+    , deepseq+    , JuicyPixels+    , JuicyPixels-blp+    , tasty-bench           >= 0.3    && < 0.5+ test-suite spec   import:              warnings   type:                exitcode-stdio-1.0   hs-source-dirs:      test   main-is:             Main.hs   other-modules:+    Deprecated     Fixture   default-language:    Haskell2010   build-depends:

@@ -2,18 +2,156 @@ ===============  [![CI](https://github.com/NCrashed/JuicyPixels-blp/actions/workflows/ci.yml/badge.svg)](https://github.com/NCrashed/JuicyPixels-blp/actions/workflows/ci.yml)+[![Hackage](https://img.shields.io/hackage/v/JuicyPixels-blp.svg)](https://hackage.haskell.org/package/JuicyPixels-blp) -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.+Read and write BLP1, the texture format of Warcraft III, with images as+[JuicyPixels](https://hackage.haskell.org/package/JuicyPixels) types. The+package also ships `blp2any`, a command-line converter between BLP and+common image formats. -Features:+For the layout of a BLP file and how the library handles each part, see+[docs/format.md](docs/format.md). -- Supported all three subtypes of BLP1: JPEG with alpha, paletted without alpha and paletted with alpha.+## Library -- Command line utility to convert BLPs from/to PNG, JPEG, BMP, TGA, TIFF, GIF, Radiance formats.+```haskell+import Codec.Picture+import Codec.Picture.Blp -TODO:+main :: IO ()+main = do+  -- Decode: the result is always ImageRGBA8.+  Right img <- readBlp "war3mapMap.blp"+  writePng "war3mapMap.png" (convertRGBA8 img) -- BLP0 support+  -- Encode: JPEG at quality 90 with every mip level down to 1x1.+  Right png <- readImage "icon.png"+  result <- writeBlpWith "icon.blp" defaultBlpEncodeOptions png+  either print return result+``` -- BLP2 support+- `readBlp` / `decodeBlp` return the full size image.+- `readBlpMipmaps` / `decodeBlpMipmaps` return the image followed by its+  mipmaps.+- `encodeBlpWith` / `writeBlpWith` encode with `BlpEncodeOptions`:+  - `blpFormat`: `BlpFormatJpeg quality` (1 to 100; the texture gets alpha+    when the image has it) or `BlpFormatPaletted withAlpha` (256 colour+    palette, with 8-bit alpha or none).+  - `blpMipLevels`: how many mip levels to write, clamped to 1 and the full+    chain. `mipMapsUpTo` computes it from a smallest side length.++  They return `Left` for images they cannot encode (`BlpEncodeError`): an+  empty image, a side above 65535, an invalid JPEG quality, or a file over+  4 GiB.+- The older `encodeBlpJpeg`, `encodeBlpUncompressedWithAlpha`,+  `encodeBlpUncompressedWithoutAlpha` and their `write` variants are+  deprecated wrappers around `encodeBlpWith`.++The `Codec.Picture.Blp.Internal.*` modules expose the parser, encoder and+file structure. They are useful for tools, but their API may change between+minor versions.++## What works++- **Decoding** all BLP1 variants: JPEG, and paletted with 0, 1, 4 or 8-bit+  alpha, including their mipmaps.+- **Damaged and non-standard files** that are common in community maps and+  ports of World of Warcraft assets:+  - odd header values;+  - short palettes;+  - garbage in unused mipmap slots;+  - truncated or corrupt mipmaps. These cost only the levels from the damaged+    one onwards; a damaged full size image still fails the file.++  The decoder reports malformed input as `Left`, including errors raised+  inside JuicyPixels' JPEG decoder. One known exception: some corrupt JPEG+  streams make JuicyPixels loop forever+  ([Juicy.Pixels#230](https://github.com/haskell-github-trust/Juicy.Pixels/issues/230)),+  so decoding untrusted files needs a timeout.+- **Encoding** to JPEG or a 256 colour palette, with or without alpha. The+  JPEG header is shared between mipmaps, as in Blizzard's own files.++## Limitations++- **BLP0 and BLP2.** Only BLP1 is supported. BLP0 keeps mipmaps in separate+  `.b00`–`.b15` files; BLP2 is the World of Warcraft variant+  ([#3](https://github.com/NCrashed/JuicyPixels-blp/issues/3)).+- **Lossy palette.** Uncompressed encoding quantises to 256 colours with+  dithering, so it is lossy for images with more colours.+- **Fixed header values.** The encoder writes `extra` as 3 with alpha and 5+  without, and `hasMipmaps` as 5, or 0 for a single level.++## blp2any++```+blp2any convert INPUT_PATH OUTPUT_PATH [-i FORMAT] [-f FORMAT] [-q QUALITY]+                [-b jpg|uncompressedWithAlpha|uncompressedWithoutAlpha]+                [--min-mipmap-size N] [-s|--shallow] [-p|--flatten]+blp2any stats DIRECTORY OUTPUT_PATH+```++- **`convert`** turns a file or a whole directory from one format into+  another. Supported formats are `blp`, `png`, `jpg`, `tiff`, `gif` and+  `bmp`.+  - Formats are inferred from the file names, or given with `-i` and `-f`.+  - With a directory it recurses unless `-s` is given, and it recreates the+    subdirectories unless `-p` (`--flatten`) is given. A file that fails is+    reported on stderr and skipped; at the end it prints how many files were+    converted and failed, and exits with status 1 if any failed.+  - When writing BLP, `-b` picks the internal format (JPEG by default) and+    `--min-mipmap-size` the smallest mip level to keep. The default is 1,+    which writes every level down to 1×1. A larger value leaves textures+    without their smallest levels; Warcraft III draws missing levels as+    transparent black, so this is only safe for interface images.+- **`stats`** groups the BLP files in a directory by their header values+  and copies one example of each group to `OUTPUT_PATH`. Files it cannot+  read are reported and skipped. It helps when hunting for unusual files.++```+blp2any convert war3/ textures-png/ -f png+blp2any convert icons/ icons-blp/ -i png -f blp -b jpg -q 85+```++## Building and testing++With [Nix](https://nixos.org) (flakes enabled), each supported GHC has its+own development shell:++```+nix develop .#ghc912      # or ghc94, ghc96, ghc98, ghc910, ghc914+cabal build all+cabal test+```++`nix develop` without a name gives a shell with haskell-language-server.+`nix build` builds the package, and `nix run . -- --help` runs `blp2any`.+Plain `cabal` works as well. `stack.yaml` is kept for Stack users, but CI+does not test it.++- **Test suite.** It builds its BLP fixtures in code (`test/Fixture.hs`):+  paletted files byte by byte, and JPEG files from the encoder, patched where+  needed. A test that pins down a fix names its PR or issue.+- **CI.** It builds and tests GHC 9.4 to 9.14 with `-Werror`. The benchmarks are built+  in CI but not run.++### Benchmarks++`bench/Main.hs` (tasty-bench) times decoding and encoding at several sizes+for each content type, plus a few internals. The inputs are generated in+code. To compare a change against the current state:++```+cabal bench --ghc-options=-fproc-alignment=64 --benchmark-options '--csv before.csv'+# ... change the code ...+cabal bench --ghc-options=-fproc-alignment=64 --benchmark-options '--baseline before.csv'+```++Use `-p` to run a subset, for example `-p decode` or `-p '/jpeg alpha/'`.++Two things make the numbers noisy:++- **Code alignment.** Without `-fproc-alignment=64`, a change in one module+  can move the tight loops of another and shift its timings by 20–25%. This+  happened to the paletted decoder while the JPEG code was being changed.+- **Machine load.** Compare runs made under the same conditions, ideally by+  alternating the two builds.

@@ -0,0 +1,111 @@+-- | Benchmarks for decoding and encoding BLP textures.+--+-- Inputs are generated in code: a gradient with deterministic noise, so that+-- JPEG and palette quantisation have real work to do. Run with+--+-- > cabal bench --benchmark-options '-p decode'+--+-- and compare against an earlier run with @--csv old.csv@ / @--baseline old.csv@.+module Main(main) where++import Codec.Picture+import Codec.Picture.Blp+import Codec.Picture.Blp.Internal.Convert (jpegAlphaIsUsable)+import Codec.Picture.Blp.Internal.Encoder (createMipMaps)+import Codec.Picture.Jpg (encodeDirectJpegAtQualityWithMetadata)+import Control.DeepSeq+import Data.Bits+import Data.ByteString (ByteString)+import Data.Word+import Test.Tasty.Bench++import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BSL++main :: IO ()+main = defaultMain+  [ bgroup "decode"+    [ decodeGroup "jpeg alpha" (jpeg True) [64, 512, 2048]+    , decodeGroup "jpeg opaque" (jpeg False) [512, 2048]+    , decodeGroup "paletted alpha8" (paletted True) [64, 512, 2048]+    , decodeGroup "paletted alpha4" (setAlphaBits 4 . paletted True) [512]+    , decodeGroup "paletted alpha1" (setAlphaBits 1 . paletted True) [512]+    , decodeGroup "paletted opaque" (paletted False) [512, 2048]+    ]+  , bgroup "encode"+    [ encodeGroup "jpeg full chain" (BlpFormatJpeg 90) 16 texture [64, 512, 1024]+    , encodeGroup "jpeg one level" (BlpFormatJpeg 90) 1 texture [512, 2048]+    , encodeGroup "paletted alpha" (BlpFormatPaletted True) 16 texture [64, 512]+    , encodeGroup "paletted opaque from RGB8" (BlpFormatPaletted False) 16 (\n -> ImageRGB8 . convertRGB8 $ texture n) [512]+    , env (return . force $ texture2 1024 128) $ \img ->+        bench "jpeg full chain/1024x128" $ nf (encodeWith (BlpFormatJpeg 90) 16) img+    ]+  , bgroup "internals"+    [ env (return . force $ rgba 2048) $ \img ->+        bench "createMipMaps/2048" $ nf (map imageData . createMipMaps) img+    , env (return . force $ cmykLevel (rgba 2048)) $ \img ->+        bench "jpegAlphaIsUsable/2048 varying" $ nf jpegAlphaIsUsable img+    , env (return . force $ cmykLevel (convertRGBA8 (opaque 2048))) $ \img ->+        bench "jpegAlphaIsUsable/2048 opaque" $ nf jpegAlphaIsUsable img+    ]+  ]++-- | Decode mip 0 only, and the whole chain, of a file made for each size.+decodeGroup :: String -> (Int -> ByteString) -> [Int] -> Benchmark+decodeGroup name mkFile sizes = bgroup name+  [ env (return . force $ mkFile n) $ \file -> bgroup (show n)+      [ bench "mip 0" $ nf (fmap pixels . decodeBlp) file+      , bench "all levels" $ nf (fmap (map pixels) . decodeBlpMipmaps) file+      ]+  | n <- sizes ]+  where+    pixels img = imageData (convertRGBA8 img)++-- | Encode an image of each size with the given format and level count.+encodeGroup :: String -> BlpFormat -> Int -> (Int -> DynamicImage) -> [Int] -> Benchmark+encodeGroup name format levels mkImage sizes = bgroup name+  [ env (return . force $ mkImage n) $ \img ->+      bench (show n) $ nf (encodeWith format levels) img+  | n <- sizes ]++encodeWith :: BlpFormat -> Int -> DynamicImage -> BSL.ByteString+encodeWith format levels = either (error . show) id . encodeBlpWith (BlpEncodeOptions format levels)++-- | Square test texture with varying alpha.+texture :: Int -> DynamicImage+texture n = texture2 n n++texture2 :: Int -> Int -> DynamicImage+texture2 w h = ImageRGBA8 $ generateImage px w h+  where+    px x y = let+      noise = fromIntegral (hash (x * 7919 + y * 104729)) :: Word8+      in PixelRGBA8 (fromIntegral (x * 255 `div` w) + noise `shiftR` 3)+                    (fromIntegral (y * 255 `div` h) + noise `shiftR` 4)+                    noise+                    (fromIntegral ((x + y) * 255 `div` (w + h)))+    hash v = (v * 2654435761) `shiftR` 13 .&. 0xFF++rgba :: Int -> Image PixelRGBA8+rgba = convertRGBA8 . texture++opaque :: Int -> DynamicImage+opaque = ImageRGBA8 . pixelMap (\(PixelRGBA8 r g b _) -> PixelRGBA8 r g b 255) . rgba++jpeg :: Bool -> Int -> ByteString+jpeg withAlpha n = BSL.toStrict . encodeWith (BlpFormatJpeg 90) 16 $+  if withAlpha then texture n else opaque n++paletted :: Bool -> Int -> ByteString+paletted withAlpha n = BSL.toStrict $ encodeWith (BlpFormatPaletted withAlpha) 16 (texture n)++-- | Rewrite the alphaBits header field; an 8-bit alpha list is long enough+-- for 1 and 4 bits.+setAlphaBits :: Word32 -> ByteString -> ByteString+setAlphaBits bits file = BS.take 8 file <> BS.pack [fromIntegral (bits `shiftR` (8 * i)) | i <- [0 .. 3]] <> BS.drop 12 file++-- | A texture as JuicyPixels decodes a BLP JPEG level, before conversion.+-- An opaque one is the worst case for the alpha check: it scans every pixel.+cmykLevel :: Image PixelRGBA8 -> DynamicImage+cmykLevel img = either error id . decodeJpeg . BSL.toStrict $+  encodeDirectJpegAtQualityWithMetadata 90 mempty (pixelMap (\(PixelRGBA8 r g b a) -> PixelCMYK8 b g r a) img)

@@ -1,32 +1,39 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE MultiWayIf #-} module Convert(     convertFiles   , ConvertFormat(..)   , ConvertOptions(..)   , readConvertFormat-  , BlpFormat(..)-  , readBlpFormat+  , BlpKind(..)+  , readBlpKind   ) where  import Codec.Picture import Codec.Picture.Blp import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Trans.Except import Data.Char import Data.Maybe import System.Directory+import System.Exit import System.FilePath+import System.IO  import qualified Data.ByteString as BS  import File -data BlpFormat =+-- | BLP content type to write, as picked on the command line.+data BlpKind =     BlpJpeg   | BlpUncompressedWithAlpha   | BlpUncompressedWithoutAlpha   deriving (Eq, Ord, Show, Enum, Bounded) -readBlpFormat :: String -> Maybe BlpFormat-readBlpFormat s = case toLower <$> s of+readBlpKind :: String -> Maybe BlpKind+readBlpKind s = case toLower <$> s of   "jpeg" -> Just BlpJpeg   "jpg" -> Just BlpJpeg   "uncompressed1" -> Just BlpUncompressedWithAlpha@@ -85,38 +92,40 @@ , convertQuality        :: Int , convertPreservesDirs  :: Bool , convertShallow        :: Bool-, convertBlpFormat      :: BlpFormat+, convertBlpKind        :: BlpKind , convertBlpMinMipSize  :: Int }  convertFiles :: ConvertOptions -> IO () convertFiles opts@ConvertOptions{..} = do-  efx <- doesFileExist convertInput-  if efx-    then convertFile opts False convertInput-    else do-      edx <- doesDirectoryExist convertInput-      if edx then do -        putStrLn $ "Converting all files from " ++ convertInput ++ " folder"-        forEachFile' convertInput fileFilter $ convertFile opts True-      else fail $ "Given path " ++ convertInput ++ " doesn't exsist!"+  isFile <- doesFileExist convertInput+  isDir <- doesDirectoryExist convertInput+  if | isFile -> convertFile opts False convertInput >>= either (failWith . ((convertInput ++ ": ") ++)) putStrLn+     | isDir -> do+         putStrLn $ "Converting all files from " ++ convertInput ++ " folder"+         (converted, failed) <- forEachFile (not convertShallow) convertInput fileFilter step (0 :: Int, 0 :: Int)+         putStrLn $ show converted ++ " converted, " ++ show failed ++ " failed"+         when (failed > 0) exitFailure+     | otherwise -> failWith $ "Given path " ++ convertInput ++ " doesn't exist!"   where+    step (!converted, !failed) inputFile = do+      result <- tryAll (convertFile opts True inputFile)+      case join result of+        Right msg -> putStrLn msg >> return (converted + 1, failed)+        Left err -> hPutStrLn stderr (inputFile ++ ": " ++ err) >> return (converted, failed + 1)     fileFilter s = case convertFormat of       Blp -> (fmap toLower $ takeExtension s) `elem` supportedExtensions       _ -> (".blp" ==) . fmap toLower . takeExtension $ s+    failWith err = hPutStrLn stderr err >> exitFailure  -- | Trye to guess format from name of file guessFormat :: FilePath -> Maybe ConvertFormat guessFormat = readConvertFormat . drop 1 . takeExtension  -- | Try to load input file with desired format-readInputFile :: FilePath -> ConvertFormat -> IO DynamicImage+readInputFile :: FilePath -> ConvertFormat -> IO (Either String DynamicImage) readInputFile inputFile format = case format of-  Blp -> do-    fc <- BS.readFile inputFile-    case decodeBlp fc of-      Left err -> fail $ "Failed to load file " <> inputFile <> ", parse error: " <> err-      Right img -> pure img+  Blp -> either (Left . ("parse error: " <>)) Right . decodeBlp <$> BS.readFile inputFile   Png -> loadJuicy readPng   Jpeg -> loadJuicy readJpeg   Tiff -> loadJuicy readTiff@@ -124,18 +133,15 @@   Bmp -> loadJuicy readBitmap   UnspecifiedFormat -> case guessFormat inputFile of     Just newFormat -> readInputFile inputFile newFormat-    Nothing -> fail $ "Cannot infer format from filename " <> inputFile+    Nothing -> pure . Left $ "cannot infer format from the file name"   where-    loadJuicy :: (FilePath -> IO (Either String DynamicImage)) -> IO DynamicImage-    loadJuicy f = do-      mres <- f inputFile-      case mres of-        Left err -> fail $ "Failed to load file " <> inputFile <> " as " <> show format <> ", error: " <> err-        Right img -> pure img+    loadJuicy :: (FilePath -> IO (Either String DynamicImage)) -> IO (Either String DynamicImage)+    loadJuicy f = either (Left . (("cannot load as " <> show format <> ": ") <>)) Right <$> f inputFile -convertFile :: ConvertOptions -> Bool -> FilePath -> IO ()-convertFile ConvertOptions{..} isDir inputFile = do-  img <- readInputFile inputFile convertInputFormat+-- | Convert one file; the result is a line to report on success.+convertFile :: ConvertOptions -> Bool -> FilePath -> IO (Either String String)+convertFile ConvertOptions{..} isDir inputFile = runExceptT $ do+  img <- ExceptT $ readInputFile inputFile convertInputFormat   let distFormat = case convertFormat of         UnspecifiedFormat -> if isDir then defaultFormat           else case guessFormat convertOutput of@@ -143,26 +149,27 @@             Nothing -> defaultFormat         _ -> convertFormat -  when isDir $ createDirectoryIfMissing True convertOutput-  let outputFile = if isDir-      then convertOutput -        </> drop (length convertInput + 1) (takeDirectory inputFile)-        </> (takeBaseName inputFile <> fromMaybe "" (listToMaybe $ formatExtension distFormat))-      else convertOutput-  createDirectoryIfMissing True $ takeDirectory outputFile+      outputName = takeBaseName inputFile <> fromMaybe "" (listToMaybe $ formatExtension distFormat)+      -- Keep the input's subdirectory unless asked to flatten the output.+      outputFile+        | not isDir = convertOutput+        | convertPreservesDirs = convertOutput </> makeRelative convertInput (takeDirectory inputFile) </> outputName+        | otherwise = convertOutput </> outputName+  liftIO . createDirectoryIfMissing True $ takeDirectory outputFile    let mipsCount = mipMapsUpTo convertBlpMinMipSize img-  res <- convertionFunction distFormat convertQuality convertBlpFormat outputFile mipsCount img-  case res of-    Left err -> fail $ inputFile <> ": " <> err-    Right _ -> putStrLn $ inputFile <> ": Success"+  ExceptT $ convertionFunction distFormat convertQuality convertBlpKind outputFile mipsCount img+  pure $ inputFile <> ": Success" -convertionFunction :: ConvertFormat -> Int -> BlpFormat -> FilePath -> Int -> DynamicImage -> IO (Either String ())-convertionFunction f quality blpFormat path mipsCount img = case f of-  Blp -> case blpFormat of-    BlpJpeg -> writeBlpJpeg path quality mipsCount img >> pure (Right ())-    BlpUncompressedWithAlpha -> writeBlpUncompressedWithAlpha path mipsCount img >> pure (Right ())-    BlpUncompressedWithoutAlpha -> writeBlpUncompressedWithoutAlpha path mipsCount img >> pure (Right ())+convertionFunction :: ConvertFormat -> Int -> BlpKind -> FilePath -> Int -> DynamicImage -> IO (Either String ())+convertionFunction f quality blpKind path mipsCount img = case f of+  Blp -> do+    let format = case blpKind of+          BlpJpeg -> BlpFormatJpeg quality+          BlpUncompressedWithAlpha -> BlpFormatPaletted True+          BlpUncompressedWithoutAlpha -> BlpFormatPaletted False+    res <- writeBlpWith path (BlpEncodeOptions format mipsCount) img+    pure $ either (Left . show) Right res   Png -> do     res <- writeDynamicPng path img     pure $ void res

@@ -1,32 +1,37 @@ module File(     forEachFile-  , forEachFile'+  , tryAll   ) where +import Control.Exception+import Control.Monad import System.Directory import System.FilePath-import Control.Monad  --- | Performs width traversion of given directory-forEachFile :: FilePath -- ^ Directory to traverse+-- | Fold over the files of a directory that pass a predicate, breadth first.+forEachFile :: Bool -- ^ Whether to descend into subdirectories+  -> FilePath -- ^ Directory to traverse   -> (FilePath -> Bool) -- ^ File selector-  -> (a -> FilePath -> IO a) -- ^ Function to perform (mimics fold)-  -> a -- ^ Start value of acum-  -> IO a -- ^ Last value of accum-forEachFile path predf f acc = go acc path+  -> (a -> FilePath -> IO a) -- ^ Step, called once per file+  -> a -- ^ Initial accumulator+  -> IO a+forEachFile recurse path predf f acc = go acc path   where-    go a inputPath = do -      names <- fmap (\p -> inputPath ++ "/" ++ p) <$> getDirectoryContents inputPath-      dirs <- filter (not . isSystemDir) <$> filterM doesDirectoryExist names+    go a dir = do+      names <- fmap (dir </>) <$> listDirectory dir       files <- filter predf <$> filterM doesFileExist names-      a' <- foldM f a files -      a' `seq` foldM go a' dirs--    isSystemDir s = let bs = takeFileName s in bs == "." || bs == ".."+      a' <- foldM f a files+      if recurse+        then filterM doesDirectoryExist names >>= foldM go a'+        else return a' --- | Performs width traversion of given directory, simplified versino of forEachFile-forEachFile' :: FilePath -- ^ Directory to traverse-  -> (FilePath -> Bool) -- ^ File selector-  -> (FilePath -> IO ()) -- ^ Function to perform-  -> IO ()-forEachFile' path predf f = forEachFile path predf (const f) ()+-- | Run an action, turning any synchronous exception into 'Left'.+-- Asynchronous exceptions (such as Ctrl+C) are rethrown.+tryAll :: IO a -> IO (Either String a)+tryAll action = do+  result <- try action+  case result of+    Right a -> return (Right a)+    Left e+      | Just async <- fromException e -> throwIO (async :: SomeAsyncException)+      | otherwise -> return . Left $ displayException (e :: SomeException)

@@ -1,7 +1,10 @@ module Main where +import Data.Version (showVersion) import Options.Applicative.Simple +import qualified Paths_JuicyPixels_blp as Paths+ import Statistics import Convert @@ -19,28 +22,28 @@ convertFormatR :: ReadM ConvertFormat convertFormatR = readMPure "format" readConvertFormat --- | How to parse BlpFormat-blpFormatR :: ReadM BlpFormat-blpFormatR = readMPure "blp format" readBlpFormat+-- | How to parse BlpKind+blpKindR :: ReadM BlpKind+blpKindR = readMPure "blp format" readBlpKind  main :: IO () main = do   (_,runCmd) <- simpleOptions ver headerDesc desc (pure ()) $ do-    addCommand "convert" "Converts given blp or folder with blps to PNG" convertFiles $ (<*>) helper $ ConvertOptions+    addCommand "convert" "Converts a file or a folder between BLP and PNG, JPEG, TIFF, GIF or BMP" convertFiles $ ConvertOptions       <$> strArgument (metavar "INPUT_PATH" <> help "input file or directory (batch mode)")       <*> strArgument (metavar "OUTPUT_PATH" <> help "output file name or directory (need explicit format option)")       <*> option convertFormatR (long "input-format" <> short 'i' <> value UnspecifiedFormat <> help "Input file format, if not specified tries to infer from input file name. Values: blp png jpg tiff gif bmp.")       <*> option convertFormatR (long "format" <> short 'f' <> value UnspecifiedFormat <> help "Output file format, if not specified tries to infer from output file name. Values: blp png jpg tiff gif bmp.")       <*> option auto (long "quality" <> short 'q' <> value 90 <> help "Quality level for formats with lossy compression (default 90)")-      <*> fmap not (switch (long "notPreserveStructure" <> short 'p' <> help "Will not produce subfolders while batch converting" ))-      <*> switch (long "shallow" <> short 's' <> help "Not look into subfolders while batch converting")-      <*> option blpFormatR (long "blpFormat" <> short 'b' <> value BlpJpeg <> help "Specifies what BLP internal format to use when converting to BLP. Values: jpg uncompressedWithAlpha uncompressedWithoutAlpha")-      <*> option auto (long "min-mipmap-size" <> value 1 <> help "Minimum size of mimmap side to include in resulted BLP file")-    addCommand "stats" "Collects statistics about BLP images in folder and saves examples of BLP's for each sample" (uncurry collectStatistics) $ (<*>) helper $ (,)+      <*> fmap not (switch (long "flatten" <> long "notPreserveStructure" <> short 'p' <> help "Write every converted file straight into OUTPUT_PATH instead of recreating subfolders (files with the same name overwrite each other)"))+      <*> switch (long "shallow" <> short 's' <> help "Only convert files directly in INPUT_PATH, not in its subfolders")+      <*> option blpKindR (long "blpFormat" <> short 'b' <> value BlpJpeg <> help "Specifies what BLP internal format to use when converting to BLP. Values: jpg uncompressedWithAlpha uncompressedWithoutAlpha")+      <*> option auto (long "min-mipmap-size" <> value 1 <> help "Smallest mipmap side to keep when writing BLP (default 1)")+    addCommand "stats" "Groups the BLPs in a folder by header values and saves one example of each group" (uncurry collectStatistics) $ (,)       <$> strArgument (metavar "DIRECTORY" <> help "Input folder that stores blps (subfolders are processed)")       <*> strArgument (metavar "OUTPUT_PATH" <> help "Here blp samples would be stored")   runCmd   where-    ver = "0.1.0.0"+    ver = showVersion Paths.version     headerDesc = ""-    desc = "Converting BLP1 Warcraft III format to/from PNG, JPEG, TGA, TIFF, BMP, GIF"+    desc = "Converting BLP1 Warcraft III textures to/from PNG, JPEG, TIFF, GIF and BMP"

@@ -10,6 +10,7 @@ import Data.Word  import System.Directory import System.FilePath+import System.IO  import qualified Data.ByteString as BS import qualified Data.Map.Strict as M@@ -17,7 +18,7 @@  import File  -type BlpInfo = (BlpCompression, [BlpFlag], BlpPictureType, Word32)+type BlpInfo = (BlpCompression, Word32, Word32, Word32) type BlpStat = (FilePath, Int)  type StatMap = M.Map BlpInfo BlpStat@@ -26,18 +27,21 @@ collectSamples dir = do    f <- doesDirectoryExist dir   unless f $ fail $ "Provided directory " ++ dir ++ " doesn't exists!"-  forEachFile dir ((".blp" ==).takeExtension) collectSample M.empty-  -collectSample :: StatMap -> FilePath -> IO StatMap -collectSample stats inputFile = do +  forEachFile True dir ((".blp" ==) . takeExtension) collectSample M.empty++collectSample :: StatMap -> FilePath -> IO StatMap+collectSample stats inputFile = do   putStrLn $ "Sampling " ++ inputFile-  fc <- BS.readFile inputFile-  case parseBlp fc of -    Left err -> fail $ inputFile ++ ": " ++ err +  result <- tryAll (parseBlp <$> BS.readFile inputFile)+  case join result of+    Left err -> do+      -- One unreadable file should not lose the statistics of the rest.+      hPutStrLn stderr $ inputFile ++ ": skipped, " ++ err+      return stats     Right blp -> return $ adjust' (updateStat inputFile) (blpType blp) stats  blpType :: BlpStruct -> BlpInfo -blpType BlpStruct{..} = (blpCompression, blpFlags, blpPictureType, blpPictureSubType)+blpType blp@BlpStruct{..} = (blpCompression blp, blpAlphaBits, blpExtra, blpHasMipmaps)  adjust' :: (Maybe BlpStat -> BlpStat) -> BlpInfo -> StatMap -> StatMap  adjust' f k m = M.insert k (f $ M.lookup k m) m@@ -49,8 +53,8 @@ printStatistics :: FilePath -> StatMap -> IO ()  printStatistics dir stats = do     createDirectoryIfMissing True dir-    forM_ (M.toList stats) $ \((compression, flags, pictureType, pictureSubType), (path, i)) -> do -      let postfix = L.intercalate "-" [show compression, show flags, show pictureType, show pictureSubType]+    forM_ (M.toList stats) $ \((compression, alphaBits, extra, hasMipmaps), (path, i)) -> do +      let postfix = L.intercalate "-" [show compression, "alpha" ++ show alphaBits, "extra" ++ show extra, "mips" ++ show hasMipmaps]       copyFile path $ dir ++ "/" ++ dropExtension (takeFileName path) ++ "-"         ++ postfix ++ ".blp"       putStrLn $ postfix ++ ": " ++ show i ++ " images"

@@ -0,0 +1,175 @@+# The BLP1 format++BLP ("Blizzard Picture") is the texture format of Warcraft III (BLP1) and+World of Warcraft (BLP2). This library reads and writes **BLP1**. This page+describes the format as the community has documented it, and states for each+part what the library does with it, including where it falls short.++Primary sources:++- [BLP Specifications (WC3)](https://www.hiveworkshop.com/threads/blp-specifications-wc3.279306/)+  by Dr Super Good, the most complete account of how Warcraft III treats+  BLP files.+- [BLP on wowdev](https://wowdev.wiki/BLP), which covers all three versions.++The older description by Magos, which this repository used to ship as+`Specification`, gets several fields wrong: the meaning of the header dwords+at `0x08`, `0x14` and `0x18`, and the "inverted alpha" in the palette. The+names below follow the newer sources.++All values are little-endian.++## Header++The header is 156 bytes (`0x9C`) long.++| Offset | Type | Name | Library field | Meaning |+|---|---|---|---|---|+| `0x00` | `char[4]` | magic | – | `"BLP1"` |+| `0x04` | `uint32` | content | `blpCompression` | `0` = JPEG, `1` = paletted ("direct") |+| `0x08` | `uint32` | alphaBits | `blpAlphaBits` | Alpha depth: 0, 1, 4 or 8 for paletted content, 0 or 8 for JPEG |+| `0x0C` | `uint32` | width | `blpWidth` | Width of mip 0 in pixels |+| `0x10` | `uint32` | height | `blpHeight` | Height of mip 0 in pixels |+| `0x14` | `uint32` | extra | `blpExtra` | No known effect; WorldEdit writes 5 |+| `0x18` | `uint32` | hasMipmaps | `blpHasMipmaps` | `0` = only mip 0, otherwise a full mip chain |+| `0x1C` | `uint32[16]` | mipmapOffset | – | File offset of each mip level |+| `0x5C` | `uint32[16]` | mipmapSize | – | Size in bytes of each mip level |++What the library does with these fields:++- **Magic.** Only `BLP1` is accepted. BLP0 and BLP2 are rejected (see+  [Not supported](#not-supported)).+- **content.** Values other than 0 and 1 are rejected. The spec suggests+  treating them as JPEG; the library is stricter.+- **alphaBits.** Decides whether there is alpha and how it is packed. Values+  that are not valid for the content type mean no alpha. On paletted files,+  a mip 0 too short to hold the declared alpha list also means no alpha;+  some tools declare alpha and then write only the index list. The encoder+  writes 8 or 0.+- **extra.** Read and kept, but it has no effect on decoding. The encoder+  writes 3 with alpha and 5 without, so that readers which still pick alpha+  by this field, as older versions of this library did, read the files+  correctly.+- **hasMipmaps.** The decoder ignores it and goes by the mipmap slots. The+  encoder writes 5, or 0 when it writes a single level.++## Mipmaps++Level `l` of a `w`×`h` texture is `max 1 (w / 2^l)` by `max 1 (h / 2^l)`.+The chain is as long as the **larger** side needs to reach 1×1. For example,+32×8 has six levels: 32×8, 16×4, 8×2, 4×1, 2×1 and 1×1. Unused slots are+zero.++Warcraft III does not generate missing levels. When `hasMipmaps` is set, it+draws them as transparent black, and a model whose texture lacks them can+fail to load. It also only uses mip levels of at most 512×512; larger levels+are stored but skipped.++**Decoder.**++- Width and height must be between 1 and 65535; anything else is an error.+- Slots are read by index from slot 0. The chain ends at the first slot that+  is empty, runs past the end of the file, points into the header, or+  overlaps an earlier level, and after the last level of the full chain.+  This drops garbage in unused slots+  ([#7](https://github.com/NCrashed/JuicyPixels-blp/pull/7)), including+  slots that repeat the last level.+- `decodeBlpMipmaps` returns the levels up to the first damaged one, so+  element `i` is always level `i`+  ([#9](https://github.com/NCrashed/JuicyPixels-blp/pull/9),+  [#13](https://github.com/NCrashed/JuicyPixels-blp/issues/13)).+- A damaged mip 0 fails the file.++**Encoder.**++- It writes as many levels as asked for, at least mip 0 and at most the full+  chain down to 1×1. Unused slots are zero, and levels are encoded only+  if they are written. Downscaling averages 2×2 blocks, reusing the edge pixel+  on odd or one-pixel sides. Colour is weighted by alpha, so transparent+  pixels do not darken the edges of sprites; alpha, including the alpha list+  of paletted textures, is a plain average. Palette indices take the+  top-left pixel of each block+  ([#26](https://github.com/NCrashed/JuicyPixels-blp/issues/26)).+- `mipMapsUpTo` counts the levels whose larger side is at least a minimum;+  with 1 that is the full chain.+- `blp2any --min-mipmap-size N` with `N > 1` writes a deliberately short+  chain. That is fine for interface images, but risky for model+  textures, for the reason above.++## JPEG content (`content = 0`)++```+uint32 jpegHeaderSize+uint8  jpegHeader[jpegHeaderSize]+...    mip levels at mipmapOffset[i], mipmapSize[i] bytes each+```++- **Assembling a level.** Each level is `jpegHeader ++ mipData`, a complete+  four-component JFIF stream.+- **Components.** They are the texture's **B, G, R and A** channels, stored+  directly with no colour transform. The stream has no Adobe marker, so+  general JPEG decoders report it as CMYK. The library maps the components+  across unchanged ([#11](https://github.com/NCrashed/JuicyPixels-blp/pull/11),+  [#17](https://github.com/NCrashed/JuicyPixels-blp/issues/17)).+- **Frame size.** The decoder reads each level's frame size before decoding+  it. A frame larger than the level is treated as damage, which also stops a+  forged frame header from making the decoder allocate gigabytes. A smaller+  frame is padded with transparent black to the level size, as Warcraft III+  does.+- **JuicyPixels.** The JPEG streams themselves are decoded by JuicyPixels.+  Errors it raises are turned into `Left`, but some corrupt streams make it+  loop forever+  ([Juicy.Pixels#230](https://github.com/haskell-github-trust/Juicy.Pixels/issues/230)),+  so decoding untrusted files needs a timeout.+- **Header size.** Warcraft III crashes on a `jpegHeaderSize` above 624.+  The encoder shares the longest common prefix of all levels, up to 624+  bytes, and leaves every level at least one byte of its own+  ([#18](https://github.com/NCrashed/JuicyPixels-blp/issues/18)).+- **Unused alpha plane.** Without alpha, the plane should be all `0xFF`, and+  the encoder writes it that way. Tools in the wild fill an unused plane with+  either all `0x00` or all `0xFF`. The decoder therefore treats a plane that+  is entirely `0x00` or entirely `0xFF` as opaque, and uses any other plane,+  including a uniformly semi-transparent one, as it is.+- **Other JPEG kinds.** Streams that are not four-component, such as+  greyscale or YCbCr, are decoded as ordinary JPEG.++## Paletted content (`content = 1`)++```+uint32 palette[256]          -- 0x00RRGGBB, stored as B, G, R, padding+per mip level:+  uint8 index[w * h]         -- palette index per pixel, rows top to bottom+  uint8 alpha[(w * h * alphaBits + 7) / 8]+```++- **Palette padding byte.** The fourth byte of each palette entry is padding+  and carries no alpha. The decoder ignores it+  ([#14](https://github.com/NCrashed/JuicyPixels-blp/issues/14)).+- **Alpha.** Alpha values are packed least-significant bit first. The+  decoder handles 1, 4 and 8 bits and scales them to 0–255; the encoder+  writes 8-bit alpha.+- **Short palettes.** Palettes shorter than 256 entries, where the first mip+  starts earlier than `0x9C + 1024`, are accepted and padded+  ([#6](https://github.com/NCrashed/JuicyPixels-blp/pull/6)).+- **Encoder.** It quantises colours to 256 with JuicyPixels' median-cut+  palette and dithering, and writes 8-bit alpha or none.++## Deviations found in real files++The decoder accepts these, besides the ones mentioned above:++| Deviation | Handling |+|---|---|+| Unusual `extra` values, such as 6 on WoW assets ported to Warcraft III and 0 from community tools | ignored ([#5](https://github.com/NCrashed/JuicyPixels-blp/pull/5), [#10](https://github.com/NCrashed/JuicyPixels-blp/pull/10)) |+| `alphaBits` declared, but mip 0 holds only the index list | read as without alpha ([#8](https://github.com/NCrashed/JuicyPixels-blp/pull/8)) |+| Garbage in unused mipmap slots | slot skipped ([#7](https://github.com/NCrashed/JuicyPixels-blp/pull/7)) |+| Truncated or corrupt tail mipmaps | levels before it kept ([#9](https://github.com/NCrashed/JuicyPixels-blp/pull/9)) |++## Not supported++- **BLP0**, which stores each mip level in a separate `.b00` … `.b15` file.+- **BLP2**, the World of Warcraft variant with DXT compression+  ([#3](https://github.com/NCrashed/JuicyPixels-blp/issues/3)).+- **Writing 1-bit or 4-bit alpha**, or a chosen `extra` or `hasMipmaps`+  value, through the public encoders. `Codec.Picture.Blp.Internal.Encoder`+  can write any `BlpStruct`.

@@ -13,6 +13,9 @@  > Right img <- readBlp "war3mapMap.blp" > writePng "war3mapMap.png" (convertRGBA8 img)+>+> Right png <- readImage "icon.png"+> result <- writeBlpWith "icon.blp" defaultBlpEncodeOptions png -} module Codec.Picture.Blp(   -- * Decoding@@ -21,22 +24,30 @@   , 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.+  , encodeBlpWith+  , writeBlpWith+  , BlpEncodeOptions(..)+  , defaultBlpEncodeOptions+  , BlpFormat(..)+  , BlpEncodeError(..)+  , mipMapsUpTo+  -- * Deprecated encoders+  -- | These predate 'encodeBlpWith'. They clamp the JPEG quality to 1..100+  -- and throw on images 'encodeBlpWith' rejects.   , writeBlpJpeg   , writeBlpUncompressedWithAlpha   , writeBlpUncompressedWithoutAlpha   , encodeBlpJpeg   , encodeBlpUncompressedWithAlpha   , encodeBlpUncompressedWithoutAlpha-  , mipMapsUpTo   ) where  import Codec.Picture-import Data.Bits (shiftR)+import Control.DeepSeq (force)+import Control.Exception+import Data.Bits ((.&.), shiftR) import Data.ByteString (ByteString)+import System.IO.Unsafe (unsafeDupablePerformIO)  import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BSL@@ -76,118 +87,182 @@   let width = fromIntegral $ blpWidth blp       height = fromIntegral $ blpHeight blp   case blpExt blp of-    BlpJpeg {..} -> do-      let jpegs = (blpJpegHeader <>) `fmap` blpJpegData-      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 {..} -> uncompressedLevels width height fits render blpU1MipMaps+    BlpJpeg {..} -> case blpJpegData of+      [] -> Left "No JPEG mipmap data in BLP"+      level0 : rest -> do+        -- Mipmap 0 is the full-resolution image; a failure there fails the+        -- file. Tail mipmaps are decoded lazily and the chain stops at the+        -- first one that fails, so a corrupt tail costs only the levels from+        -- it on, and element i stays level i.+        mip0 <- decodeLevel 0 level0+        let validPrefix l (j : js) | Right m <- decodeLevel l j = m : validPrefix (l + 1) js+            validPrefix _ _ = []+            -- 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 = blpAlphaBits blp == 8 && jpegAlphaIsUsable mip0+        Right $ toLevel useAlpha <$> zip [0 ..] (mip0 : validPrefix 1 rest)       where-      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)+      -- The frame size is checked before decoding: JuicyPixels allocates the+      -- whole image up front, so a forged frame header could otherwise ask+      -- for gigabytes. A frame larger than the level is rejected; a smaller+      -- one is padded with transparent black, as Warcraft III does.+      decodeLevel :: Int -> ByteString -> Either String DynamicImage+      decodeLevel l level = do+        let jpeg = blpJpegHeader <> level+            (lw, lh) = levelSize width height l+        (fw, fh) <- maybe (Left $ "JPEG mipmap " ++ show l ++ " has no frame header") Right (jpegFrameSize jpeg)+        if fw > lw || fh > lh+          then Left $ "JPEG mipmap " ++ show l ++ " is " ++ show fw ++ "x" ++ show fh+            ++ ", larger than its level size " ++ show lw ++ "x" ++ show lh+          else safeDecodeJpeg jpeg+      toLevel useAlpha (l, img) = let+        (lw, lh) = levelSize width height l+        rgba = convertRGBA8 (fromBlpJpeg useAlpha img)+        in ImageRGBA8 $ if imageWidth rgba == lw && imageHeight rgba == lh+          then rgba+          else generateImage (\x y -> if x < imageWidth rgba && y < imageHeight rgba+            then pixelAt rgba x y else PixelRGBA8 0 0 0 0) lw lh -    BlpUncompressed2 {..} -> uncompressedLevels width height fits render blpU2MipMaps+    BlpPaletted {..} -> palettedLevels width height alphaBits blpPalette blpPalettedMipMaps       where-      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+      -- Alpha depth as declared, if valid for paletted content. A mip 0 too+      -- short to hold that much alpha has none: some tools declare alpha and+      -- then write only the index list.+      declared = case blpAlphaBits blp of+        b | b `elem` [1, 4, 8] -> fromIntegral b+        _ -> 0+      alphaBits = case blpPalettedMipMaps of+        mip0 : _ | BS.length mip0 < levelBytes (width * height) declared -> 0+        _ -> declared --- | 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+-- | Size of mip level @l@ of a @w@ x @h@ texture: each side halved @l@ times,+-- but never below one pixel.+levelSize :: Int -> Int -> Int -> (Int, Int)+levelSize w h l = (max 1 (w `shiftR` l), max 1 (h `shiftR` l))++-- | 'decodeJpeg', with errors JuicyPixels raises from pure code turned into+-- 'Left'. Asynchronous exceptions are rethrown.+safeDecodeJpeg :: ByteString -> Either String DynamicImage+safeDecodeJpeg jpeg = unsafeDupablePerformIO $ do+  result <- try (evaluate (force (decodeJpeg jpeg)))+  case result of+    Right decoded -> return decoded+    Left e+      | Just async <- fromException e -> throwIO (async :: SomeAsyncException)+      | otherwise -> return . Left $ "JPEG decoding failed: " ++ displayException (e :: SomeException)++-- | Bytes a paletted mip level of @n@ pixels takes: the index list and the+-- alpha list.+levelBytes :: Int -> Int -> Int+levelBytes n alphaBits = n + (n * alphaBits + 7) `div` 8++-- | Render the mipmaps of a paletted 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 data is too short for its size, so the result is always a+-- prefix of the mip levels; a short level 0 fails the file.+palettedLevels :: Int -> Int -> Int -> V.Vector PixelRGBA8 -> [ByteString] -> Either String [DynamicImage]+palettedLevels width height alphaBits palette 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+      | BS.length mip >= levelBytes (w * h) alphaBits =+          ImageRGBA8 (generateImage (pixel w (BS.drop (w * h) mip) mip) w h) : go (l + 1) rest       where-        w = levelSide width l-        h = levelSide height l+        (w, h) = levelSize width height l     go _ _ = []-    levelSide side l = if side <= 0 then 0 else max 1 (side `shiftR` l) --- | 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.+    -- The palette's fourth byte is padding, not alpha.+    pixel w alphas indices x y = let+      i = y * w + x+      PixelRGBA8 r g b _ = palette V.! fromIntegral (indices `BS.index` i)+      in PixelRGBA8 b g r (alphaAt alphas i)++    -- Alpha values are packed least significant bit first.+    alphaAt alphas i = case alphaBits of+      8 -> alphas `BS.index` i+      4 -> 17 * ((alphas `BS.index` (i `div` 2) `shiftR` (4 * (i `mod` 2))) .&. 0x0f)+      1 -> 255 * ((alphas `BS.index` (i `div` 8) `shiftR` (i `mod` 8)) .&. 1)+      _ -> 255++-- | Number of mip levels, mip 0 included, whose larger side is at least the+-- given length; never less than one and at most 16. Use it as 'blpMipLevels'.+-- With 1 that is the full chain down to 1x1: five levels for 16x16, seven+-- for 64x16. With 4, a 16x16 texture keeps three levels. mipMapsUpTo :: Int -- ^ Smallest side length to keep (2, 4, 16, ...)   -> DynamicImage -- ^ Image the mipmaps are made for   -> Int-mipMapsUpTo minSize img = max 1 . length . takeWhile (>= max 1 minSize) $ iterate (`div` 2) minSide+mipMapsUpTo minSize img = max 1 . min 16 . length . takeWhile (>= max 1 minSize) $ iterate (`div` 2) larger   where-    minSide = min (dynamicMap imageWidth img) (dynamicMap imageHeight img)+    larger = max (dynamicMap imageWidth img) (dynamicMap imageHeight img) +-- | JPEG at quality 90 with the full mip chain.+defaultBlpEncodeOptions :: BlpEncodeOptions+defaultBlpEncodeOptions = BlpEncodeOptions {+    blpFormat = BlpFormatJpeg 90+  , blpMipLevels = 16+  }++-- | Encode an image as a BLP1 file.+encodeBlpWith :: BlpEncodeOptions -> DynamicImage -> Either BlpEncodeError BSL.ByteString+encodeBlpWith BlpEncodeOptions{..} img+  | w < 1 || h < 1 = Left BlpEmptyImage+  | w > 65535 || h > 65535 = Left $ BlpImageTooLarge w h+  | BlpFormatJpeg quality <- blpFormat, quality < 1 || quality > 100 = Left $ BlpInvalidJpegQuality quality+  | BSL.length file > 0xFFFFFFFF = Left BlpFileTooLarge+  | otherwise = Right file+  where+    w = dynamicMap imageWidth img+    h = dynamicMap imageHeight img+    file = encodeBlp (toBlpStruct blpFormat blpMipLevels img)++-- | Encode an image with 'encodeBlpWith' and write it to a file.+writeBlpWith :: FilePath -> BlpEncodeOptions -> DynamicImage -> IO (Either BlpEncodeError ())+writeBlpWith fp opts img = traverse (BSL.writeFile fp) (encodeBlpWith opts 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+writeBlpJpeg fp quality numMips img = BSL.writeFile fp $ encodeBlpJpeg quality numMips img+{-# DEPRECATED writeBlpJpeg "Use writeBlpWith" #-}  -- | 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+writeBlpUncompressedWithAlpha fp numMips img = BSL.writeFile fp $ encodeBlpUncompressedWithAlpha numMips img+{-# DEPRECATED writeBlpUncompressedWithAlpha "Use writeBlpWith" #-}  -- | 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+writeBlpUncompressedWithoutAlpha fp numMips img = BSL.writeFile fp $ encodeBlpUncompressedWithoutAlpha numMips img+{-# DEPRECATED writeBlpUncompressedWithoutAlpha "Use writeBlpWith" #-} --- | 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+-- | Encode as a JPEG compressed BLP; see 'BlpFormatJpeg'.+encodeBlpJpeg :: Int -- ^ JPEG quality, clamped to 1..100   -> Int -- ^ Number of mip levels to write   -> DynamicImage   -> BSL.ByteString-encodeBlpJpeg quality numMips = encodeBlp numMips . toBlpStruct BlpCompressionJPEG quality numMips+encodeBlpJpeg quality numMips =+  orThrow "encodeBlpJpeg" . encodeBlpWith (BlpEncodeOptions (BlpFormatJpeg (max 1 (min 100 quality))) numMips)+{-# DEPRECATED encodeBlpJpeg "Use encodeBlpWith with BlpFormatJpeg" #-} --- | Encode as an uncompressed paletted BLP with an alpha plane. An input--- without alpha gets a fully opaque plane. Colours are quantised to 256.+-- | Encode with a 256 colour palette and 8-bit alpha; see 'BlpFormatPaletted'. encodeBlpUncompressedWithAlpha :: Int -- ^ Number of mip levels to write   -> DynamicImage   -> BSL.ByteString encodeBlpUncompressedWithAlpha numMips =-  encodeBlp numMips . toBlpStruct BlpCompressionUncompressed 100 numMips . ImageRGBA8 . convertRGBA8+  orThrow "encodeBlpUncompressedWithAlpha" . encodeBlpWith (BlpEncodeOptions (BlpFormatPaletted True) numMips)+{-# DEPRECATED encodeBlpUncompressedWithAlpha "Use encodeBlpWith with BlpFormatPaletted True" #-} --- | Encode as an uncompressed paletted BLP without alpha. The alpha channel--- of the input, if any, is dropped. Colours are quantised to 256.+-- | Encode with a 256 colour palette and no alpha; see 'BlpFormatPaletted'. encodeBlpUncompressedWithoutAlpha :: Int -- ^ Number of mip levels to write   -> DynamicImage   -> BSL.ByteString encodeBlpUncompressedWithoutAlpha numMips =-  encodeBlp numMips . toBlpStruct BlpCompressionUncompressed 100 numMips . ImageRGB8 . convertRGB8+  orThrow "encodeBlpUncompressedWithoutAlpha" . encodeBlpWith (BlpEncodeOptions (BlpFormatPaletted False) numMips)+{-# DEPRECATED encodeBlpUncompressedWithoutAlpha "Use encodeBlpWith with BlpFormatPaletted False" #-}++orThrow :: String -> Either BlpEncodeError a -> a+orThrow name = either (\e -> error $ name ++ ": " ++ show e) id

@@ -1,13 +1,22 @@+{-|+Pixel conversions between the BGRA planes of BLP1 JPEG content and+JuicyPixels images.++This is an internal module: its API may change between minor versions.+-} module Codec.Picture.Blp.Internal.Convert(     fromBlpJpeg   , jpegAlphaIsUsable   , toBlpCMYK8+  , opaqueRGBA8   ) where  import Codec.Picture-import Codec.Picture.Types (pixelFold)+import Data.Bits ((.&.)) import Data.Word +import qualified Data.Vector.Storable as VS+ -- | Convert a decoded mipmap of a JPEG compressed BLP1 into an image that can -- be written out directly. --@@ -22,9 +31,7 @@ -- 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+  ImageCMYK8 p -> ImageRGBA8 $ swapRedBlue (not useAlpha) p   _ -> ImageRGBA8 $ convertRGBA8 i  -- | Whether the alpha plane of a decoded BLP1 JPEG mipmap carries information.@@ -40,39 +47,41 @@ -- 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+  ImageCMYK8 p+    | VS.null planes -> False+    | otherwise -> varies 7 || (a0 /= 0 && a0 /= 255)+    where+      -- The fourth component of every pixel; stops at the first that differs.+      planes = imageData p+      a0 = VS.unsafeIndex planes 3+      varies j+        | j >= VS.length planes = False+        | VS.unsafeIndex planes j /= a0 = True+        | otherwise = varies (j + 4)   _ -> True --- | 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-    PixelRGBA8 _ _ _ a0 = pixelAt img 0 0-    same acc _ _ (PixelRGBA8 _ _ _ a) = acc && a == a0- -- | 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 (PixelCMYK8 c m y k) = PixelRGBA8 y m c k+-- actually are, optionally making every pixel opaque. This inverts+-- 'toBlpCMYK8'.+swapRedBlue :: Bool -> Image PixelCMYK8 -> Image PixelRGBA8+swapRedBlue opaque img = Image (imageWidth img) (imageHeight img) (swapBytes opaque (imageData img)) -forceOpaque :: Image PixelRGBA8 -> Image PixelRGBA8-forceOpaque = pixelMap convert-  where-  convert (PixelRGBA8 r g b _) = PixelRGBA8 r g b 255+-- | Swap the first and third byte of every four, optionally setting the+-- fourth to 255.+swapBytes :: Bool -> VS.Vector Word8 -> VS.Vector Word8+swapBytes opaque src = VS.generate (VS.length src) $ \i -> case i .&. 3 of+  0 -> VS.unsafeIndex src (i + 2)+  2 -> VS.unsafeIndex src (i - 2)+  3 | opaque -> 255+  _ -> VS.unsafeIndex src i +-- | Set the alpha of every pixel to 255.+opaqueRGBA8 :: Image PixelRGBA8 -> Image PixelRGBA8+opaqueRGBA8 img = img { imageData = VS.imap (\i v -> if i .&. 3 == 3 then 255 else v) (imageData img) }+ -- | 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@.+-- 'swapRedBlue'. toBlpCMYK8 :: Image PixelRGBA8 -> Image PixelCMYK8-toBlpCMYK8 = pixelMap convert-  where-  convert (PixelRGBA8 r g b a) = PixelCMYK8 b g r a+toBlpCMYK8 img = Image (imageWidth img) (imageHeight img) (swapBytes False (imageData img))

@@ -1,9 +1,17 @@+{-|+The structure of a BLP1 file as the parser reads it and the encoder writes+it. See @docs/format.md@ in the source repository for the full format.++This is an internal module: its API may change between minor versions.+-} module Codec.Picture.Blp.Internal.Data(     BlpStruct(..)+  , blpCompression   , BlpCompression(..)-  , BlpFlag(..)-  , BlpPictureType(..)   , BlpExt(..)+  , BlpFormat(..)+  , BlpEncodeOptions(..)+  , BlpEncodeError(..)   ) where  import Codec.Picture@@ -12,41 +20,78 @@ import Data.Word import GHC.Generics +-- | A parsed BLP1 file: the 156 byte header and the image data after it. The+-- content type (header dword @0x04@) follows from 'blpExt', see+-- 'blpCompression'. data BlpStruct = BlpStruct {-  blpCompression :: !BlpCompression-, blpFlags :: ![BlpFlag]+  -- | Header dword @0x08@: alpha bits per pixel. 0, 1, 4 and 8 are valid for+  -- paletted content, 0 and 8 for JPEG; any other value means no alpha.+  blpAlphaBits :: !Word32+  -- | Width of mip 0 in pixels. , blpWidth :: !Word32+  -- | Height of mip 0 in pixels. , blpHeight :: !Word32-, blpPictureType :: !BlpPictureType-, blpPictureSubType :: !Word32 -- is not used+  -- | Header dword @0x14@. It has no known effect and is kept as read.+, blpExtra :: !Word32+  -- | Header dword @0x18@: zero means only mip 0 is present.+, blpHasMipmaps :: !Word32+  -- | Everything after the header, including the mip levels. , blpExt :: BlpExt } deriving (Show, Generic) +-- | The part of the file after the header. data BlpExt =+    -- | JPEG content. Each mip level is @blpJpegHeader <> level@, a+    -- four-component JPEG whose components are B, G, R and A.     BlpJpeg {-      blpJpegHeader :: !ByteString-    , blpJpegData :: ![ByteString]-    }-  | BlpUncompressed1 {-      blpU1Palette :: !(Vector PixelRGBA8)-    , blpU1MipMaps :: ![(ByteString, ByteString)]+      blpJpegHeader :: !ByteString -- ^ Shared JPEG header, at most 624 bytes+    , blpJpegData :: ![ByteString] -- ^ Rest of each mip level, mip 0 first     }-  | BlpUncompressed2 {-      blpU2Palette :: !(Vector PixelRGBA8)-    , blpU2MipMaps :: ![ByteString]+    -- | Paletted content. Each mip level holds the index list followed by the+    -- alpha list, packed at 'blpAlphaBits' bits per pixel; the level's size+    -- tells where one ends and the other begins.+  | BlpPaletted {+      blpPalette :: !(Vector PixelRGBA8) -- ^ 256 entries stored as B, G, R and padding+    , blpPalettedMipMaps :: ![ByteString] -- ^ Raw data of each mip level, mip 0 first     }   deriving (Show, Generic) +-- | Header dword @0x04@. data BlpCompression =-    BlpCompressionJPEG-  | BlpCompressionUncompressed+    BlpCompressionJPEG -- ^ 0: JPEG+  | BlpCompressionUncompressed -- ^ 1: 256 colour palette   deriving (Eq, Ord, Enum, Bounded, Show, Generic) -data BlpFlag = BlpFlagAlphaChannel-  deriving (Eq, Ord, Enum, Bounded, Show, Generic)+-- | Header dword @0x04@ (@content@ in the specification) of a file.+blpCompression :: BlpStruct -> BlpCompression+blpCompression blp = case blpExt blp of+  BlpJpeg {} -> BlpCompressionJPEG+  BlpPaletted {} -> BlpCompressionUncompressed -data BlpPictureType =-    JPEGType-  | UncompressedWithAlpha-  | UncompressedWithoutAlpha-  deriving (Eq, Ord, Enum, Bounded, Show, Generic)+-- | How to encode a texture.+data BlpFormat =+    -- | JPEG with the given quality, from 1 to 100. The texture gets alpha+    -- when the image has an alpha channel.+    BlpFormatJpeg !Int+    -- | 256 colour palette, with 8-bit alpha or without alpha. Colours are+    -- quantised with dithering.+  | BlpFormatPaletted !Bool+  deriving (Eq, Show)++-- | Options for encoding a texture.+data BlpEncodeOptions = BlpEncodeOptions {+  -- | Content type and its settings.+  blpFormat :: !BlpFormat+  -- | Number of mip levels to write, mip 0 included. Values below 1 mean 1,+  -- and values above what the image has mean the full chain down to 1x1+  -- (at most 16 levels).+, blpMipLevels :: !Int+} deriving (Eq, Show)++-- | Why an image cannot be encoded.+data BlpEncodeError =+    BlpEmptyImage -- ^ The image has a side of zero pixels.+  | BlpImageTooLarge !Int !Int -- ^ Width or height is above 65535, the format's limit.+  | BlpInvalidJpegQuality !Int -- ^ JPEG quality outside 1 to 100.+  | BlpFileTooLarge -- ^ The file would exceed 4 GiB, the most its offsets can address.+  deriving (Eq, Show)

@@ -1,11 +1,16 @@+{-|+Building and serialising BLP1 files: palette quantisation, the mip chain, the+shared JPEG header and the binary layout.++This is an internal module: its API may change between minor versions.+-} module Codec.Picture.Blp.Internal.Encoder(     encodeBlp   , blpEncoder+  , toBlpStruct   , createMipMaps   , createMipMapsIndexed   , scanHeader-  , toBlpStruct-  , toBlpExt   ) where  import Codec.Picture@@ -13,97 +18,56 @@ import Codec.Picture.Jpg import Codec.Picture.Types import Data.Binary.Put-import Data.Bits import Data.ByteString.Lazy (ByteString, toStrict) import Data.Foldable (traverse_) import Data.Word -import qualified Codec.Picture.Metadata as CM import qualified Data.ByteString 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+import qualified Data.Vector.Storable.Mutable as MVS  import Codec.Picture.Blp.Internal.Convert import Codec.Picture.Blp.Internal.Data --- | Convert spare BLP structure into compact stream of bytes-encodeBlp :: Int -> BlpStruct -> ByteString-encodeBlp numMips = runPut . blpEncoder numMips+-- | Serialise a BLP structure. The content type follows from 'blpExt'; at+-- most 16 mip levels are written, and unused slots are zero.+encodeBlp :: BlpStruct -> ByteString+encodeBlp = runPut . blpEncoder  -- | Raw encoder for BLP-blpEncoder :: Int -> BlpStruct -> Put-blpEncoder requestedMips BlpStruct{..} = do-  putBlpVersion-  putCompression-  putFlags-  putWidth-  putHeight-  putPictureType-  putPictureSubType-  putMipMapOffsets-  putMipMapSizes-  putBlpExt+blpEncoder :: BlpStruct -> Put+blpEncoder BlpStruct{..} = do+  putByteString "BLP1"+  putWord32le $ case blpExt of+    BlpJpeg {} -> 0+    BlpPaletted {} -> 1+  putWord32le blpAlphaBits+  putWord32le blpWidth+  putWord32le blpHeight+  putWord32le blpExtra+  putWord32le blpHasMipmaps+  traverse_ putWord32le . slots $ take (length levels) (scanl (+) contentStart levelSizes)+  traverse_ putWord32le $ slots levelSizes+  case blpExt of+    BlpJpeg {..} -> do+      putWord32le . fromIntegral $ BS.length blpJpegHeader+      putByteString blpJpegHeader+    BlpPaletted {..} ->+      traverse_ putRgba8 . V.take 256 $ blpPalette <> V.replicate 256 (PixelRGBA8 0 0 0 0)+  traverse_ putByteString levels   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-      BlpCompressionUncompressed -> 1-    putFlags = let-      addFlag acc flag = (acc +) $ case flag of-         BlpFlagAlphaChannel -> 1 `shiftL` 3-      in putWord32le $ F.foldl' addFlag 0 blpFlags-    putWidth = putWord32le blpWidth-    putHeight = putWord32le blpHeight-    putPictureType = putWord32le $ case blpPictureType of-      JPEGType -> 2-      UncompressedWithAlpha -> 3-      -- UncompressedWithAlpha -> 4-      UncompressedWithoutAlpha -> 5-    putPictureSubType = putWord32le blpPictureSubType-    headerSize = 4 -- BLP1-      + 4 -- Compression-      + 4 -- Flags-      + 4 -- Width-      + 4 -- Height-      + 4 -- Picture type-      + 4 -- Picture subtype-      + 16 * 4 -- Mipmaps offsets-      + 16 * 4 -- Mipmaps sizes-    mipmaps = let-      mkOffsetSize :: BS.ByteString -> (Int, [(Word32, Word32)]) ->  (Int, [(Word32, Word32)])-      mkOffsetSize bs (!offset, !acc) = (offset + BS.length bs, (fromIntegral offset, fromIntegral $ BS.length bs) : acc)-      uncomprStartOffset = headerSize + 4 * 256-      in reverse . snd $ case blpExt of-        BlpJpeg{..} -> let-          startOffset = headerSize + 4 + BS.length blpJpegHeader-          in F.foldr' mkOffsetSize (startOffset, []) $ reverse blpJpegData-        BlpUncompressed1{..} -> let-          mkOffsetSizeU (indbs, alpbs) (!offset, !acc) = (offset + BS.length indbs + BS.length alpbs, (fromIntegral offset, fromIntegral $ BS.length indbs + BS.length alpbs) : acc)-          in F.foldr' mkOffsetSizeU (uncomprStartOffset, []) $ reverse blpU1MipMaps-        BlpUncompressed2{..} -> F.foldr' mkOffsetSize (uncomprStartOffset, []) $ reverse blpU2MipMaps-    ensureLength _ [] = []-    ensureLength n xs = if length xs < n-      then xs ++ replicate (n - length xs) (last xs)-      else take n xs-    ensureLengthV n a xs = if V.length xs < n then xs <> V.replicate (n - V.length xs) a else V.take n xs-    putMipMapOffsets = traverse_ putWord32le . ensureLength 16 . take numMips . fmap fst $ mipmaps-    putMipMapSizes = traverse_ putWord32le . ensureLength 16 . take numMips . fmap snd $ mipmaps+    headerSize = 156+    levels = take 16 $ case blpExt of+      BlpJpeg {..} -> blpJpegData+      BlpPaletted {..} -> blpPalettedMipMaps+    levelSizes = BS.length <$> levels+    contentStart = case blpExt of+      BlpJpeg {..} -> headerSize + 4 + BS.length blpJpegHeader+      BlpPaletted {} -> headerSize + 4 * 256+    slots xs = take 16 $ (fromIntegral <$> xs) ++ repeat 0     putRgba8 (PixelRGBA8 r g b a) = putWord8 r >> putWord8 g >> putWord8 b >> putWord8 a-    putBlpExt = case blpExt of -- TODO: check sync of compression flag and BlpExt-       BlpJpeg{..} -> do-         putWord32le $ fromIntegral $ BS.length blpJpegHeader-         putByteString blpJpegHeader-         traverse_ putByteString $ take numMips blpJpegData-       BlpUncompressed1{..} -> do-         traverse_ putRgba8 . ensureLengthV 256 (PixelRGBA8 0 0 0 0) $ blpU1Palette-         traverse_ (\(indbs, alpbs) -> putByteString indbs >> putByteString alpbs) $ take numMips blpU1MipMaps-       BlpUncompressed2{..} -> do-         traverse_ putRgba8 . ensureLengthV 256 (PixelRGBA8 0 0 0 0) $ blpU2Palette-         traverse_ putByteString $ take numMips blpU2MipMaps  -- | Return 'True' if given picture format has alpha channel hasAlpha :: DynamicImage -> Bool@@ -114,111 +78,114 @@   ImageRGBA16 _ -> True   _ -> False --- | Convert to BLP structure some image with given BLP options and quality (for JPEG compression)-toBlpStruct :: BlpCompression -> Int -> Int -> DynamicImage -> BlpStruct-toBlpStruct compression quality numMips img = BlpStruct {-    blpCompression = compression-  , blpFlags = if hasAlpha img-      then [BlpFlagAlphaChannel]-      else []-  , blpWidth = fromIntegral $ dynamicMap imageWidth img-  , blpHeight = fromIntegral $ dynamicMap imageHeight img-  , blpPictureType = pictype-  , blpPictureSubType = 5 -- world edit use this for war3mapMap.blp-  , blpExt = toBlpExt compression pictype quality numMips img'+-- | Build the BLP structure for an image with the given format and number of+-- mip levels. The number is clamped to between 1 and the image's full chain,+-- at most 16. The image's size is not checked.+toBlpStruct :: BlpFormat -> Int -> DynamicImage -> BlpStruct+toBlpStruct format requestedLevels img = BlpStruct {+    blpAlphaBits = if alpha then 8 else 0+  , blpWidth = fromIntegral width+  , blpHeight = fromIntegral height+  -- Readers that follow the old description of the format pick alpha by+  -- this field (3 or 4 with alpha, 5 without), so keep it consistent.+  , blpExtra = if alpha then 3 else 5+  -- WorldEdit writes 5; a single level says it has no mipmaps.+  , blpHasMipmaps = if numLevels > 1 then 5 else 0+  , blpExt = case format of+      BlpFormatJpeg quality -> toBlpJpg (fromIntegral quality) numLevels alpha rgba+      BlpFormatPaletted _ -> toBlpPaletted alpha numLevels (convertRGB8 img) rgba   }   where-    pictype = if hasAlpha img-      then UncompressedWithAlpha-      else UncompressedWithoutAlpha-    img' = convertRGBA8 img---- | Take only first N mipmaps in list, fill rest with last non-fake mipmap-fakeMipMaps :: Int -- ^ How much true values to preserve (if <= 0, the function does nothing)-  -> [a] -- ^ List of mimpaps-  -> [a] -- ^ Result with fakes-fakeMipMaps = go Nothing-  where-    go mprev n xs-      | n <= 0 = case mprev of-        Nothing -> xs-        Just v -> case xs of-          [] -> []-          _ : xs' -> v : go (Just v) 0 xs'-      | otherwise = case xs of-        [] -> []-        x : xs' -> x : go (Just x) (n-1) xs'+    alpha = case format of+      BlpFormatJpeg _ -> hasAlpha img+      BlpFormatPaletted withAlpha -> withAlpha+    -- Only built when needed: paletted textures without alpha go from RGB.+    rgba = convertRGBA8 img+    width = dynamicMap imageWidth img+    height = dynamicMap imageHeight img+    chainLength = length . takeWhile (>= 1) $ iterate (`div` 2) (max width height)+    numLevels = max 1 . min 16 $ min chainLength requestedLevels  -- | Scale image to form the sequence of mipmaps. The first element is always the original picture. ----- The scale procedure assumes that original image has power of 2 sides, that allows to simply pick--- average of 4 pixels.+-- Each level averages 2x2 blocks; on an odd or one-pixel side the last block+-- reuses the edge pixel. Colour is weighted by alpha, so the colour of+-- transparent pixels does not bleed into their neighbours; alpha itself is+-- a plain average. Rounding is to the nearest, ties to even. createMipMaps :: Image PixelRGBA8 -> [Image PixelRGBA8] createMipMaps img = img : go img   where-    avg' v1 v2 v3 v4 = let-      v = fromIntegral v1 + fromIntegral v2 + fromIntegral v3 + fromIntegral v4 :: Double-      in round $ v / 4-    avg i x y = let-      PixelRGBA8 p00r p00g p00b p00a = pixelAt i (x*2) (y*2)-      PixelRGBA8 p10r p10g p10b p10a = pixelAt i (x*2 + 1) (y*2)-      PixelRGBA8 p01r p01g p01b p01a = pixelAt i (x*2) (y*2 + 1)-      PixelRGBA8 p11r p11g p11b p11a = pixelAt i (x*2 + 1) (y*2 + 1)-      in PixelRGBA8 (avg' p00r p10r p01r p11r) (avg' p00g p10g p01g p11g) (avg' p00b p10b p01b p11b) (avg' p00a p10a p01a p11a)-    power2Scale i = generateImage (avg i) (downgrade $ imageWidth i) (downgrade $ imageHeight i)-    downgrade v = max 1 $ v `div` 2-    go i | imageWidth i <= 1 || imageHeight i <= 1 = []-         | otherwise = let i' = power2Scale i in i' : go i'+    go i | imageWidth i <= 1 && imageHeight i <= 1 = []+         | otherwise = let i' = halveRGBA8 i in i' : go i' --- | Scale image to form the sequence of mipmaps. The first element is always the original picture.------ The scale procedure assumes that original image has power of 2 sides, that allows to simply pick--- 1 of 4 pixels.+-- | One step of 'createMipMaps': halve both sides, but not below one pixel.+-- On a side that is already one pixel (or odd) the second sample of a block+-- is clamped to the edge.+halveRGBA8 :: Image PixelRGBA8 -> Image PixelRGBA8+halveRGBA8 (Image w h src) = Image w' h' $ VS.create $ do+  dst <- MVS.new (w' * h' * 4)+  let pixel x y = do+        let x0 = 2 * x+            x1 = min (w - 1) (x0 + 1)+            y0 = 2 * y+            y1 = min (h - 1) (y0 + 1)+            o00 = (y0 * w + x0) * 4+            o10 = (y0 * w + x1) * 4+            o01 = (y1 * w + x0) * 4+            o11 = (y1 * w + x1) * 4+            at o = fromIntegral (VS.unsafeIndex src o) :: Int+            a00 = at (o00 + 3)+            a10 = at (o10 + 3)+            a01 = at (o01 + 3)+            a11 = at (o11 + 3)+            alphaSum = a00 + a10 + a01 + a11+            -- Colour weighted by alpha, or a plain average if all four are+            -- transparent.+            channel c+              | alphaSum == 0 = roundDiv (at (o00 + c) + at (o10 + c) + at (o01 + c) + at (o11 + c)) 4+              | otherwise = roundDiv (at (o00 + c) * a00 + at (o10 + c) * a10 + at (o01 + c) * a01 + at (o11 + c) * a11) alphaSum+            out = (y * w' + x) * 4+        MVS.unsafeWrite dst out (channel 0)+        MVS.unsafeWrite dst (out + 1) (channel 1)+        MVS.unsafeWrite dst (out + 2) (channel 2)+        MVS.unsafeWrite dst (out + 3) (roundDiv alphaSum 4)+      loop y x+        | y >= h' = return ()+        | x >= w' = loop (y + 1) 0+        | otherwise = pixel x y >> loop y (x + 1)+  loop 0 0+  return dst+  where+    w' = max 1 (w `div` 2)+    h' = max 1 (h `div` 2)+    -- Nearest, ties to even.+    roundDiv :: Int -> Int -> Word8+    roundDiv n d = let+      (q, r) = n `divMod` d+      in fromIntegral $ if 2 * r > d || (2 * r == d && odd q) then q + 1 else q++-- | Scale image to form the sequence of mipmaps, down to 1x1. The first+-- element is always the original picture. Each level takes the top-left pixel+-- of every 2x2 block, as averaging palette indices makes no sense. createMipMapsIndexed :: Pixel a => Image a -> [Image a] createMipMapsIndexed img = img : go img   where     power2Scale i = generateImage (\x y -> pixelAt i (x*2) (y*2)) (downgrade $ imageWidth i) (downgrade $ imageHeight i)     downgrade v = max 1 $ v `div` 2-    go i | imageWidth i <= 1 || imageHeight i <= 1 = []+    go i | imageWidth i <= 1 && imageHeight i <= 1 = []          | otherwise = let i' = power2Scale i in i' : go i' --- | 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 keepAlpha img-  BlpCompressionUncompressed -> case pictype of-    UncompressedWithAlpha -> toBlpUncompressed1 numMips img-    UncompressedWithoutAlpha -> toBlpUncompressed2 numMips img-    JPEGType -> toBlpUncompressed2 numMips img -- Consider this as without alpha-  where-    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 keepAlpha img = BlpJpeg {+toBlpJpg quality numLevels keepAlpha img = BlpJpeg {     blpJpegHeader = header-  , blpJpegData = mipmapsRawWithoutHeader+  , blpJpegData = BS.drop (BS.length header) <$> streams   }   where-    processAlpha :: Image PixelRGBA8 -> Image PixelRGBA8-    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)--    metadata :: CM.Metadatas-    metadata = CM.insert (CM.Unknown "JPEG Quality") (CM.Int $ fromIntegral quality) mempty--    mipmapsRaw :: [BS.ByteString]-    mipmapsRaw = toStrict . encodeDirectJpegAtQualityWithMetadata quality metadata <$> mipmaps--    header :: BS.ByteString-    header = scanHeader 624 mipmapsRaw--    mipmapsRawWithoutHeader :: [BS.ByteString]-    mipmapsRawWithoutHeader = BS.drop (BS.length header) <$> mipmapsRaw+    opaque = if keepAlpha then id else opaqueRGBA8+    levels = take numLevels . createMipMaps . opaque $ img+    streams = toStrict . encodeDirectJpegAtQualityWithMetadata quality mempty . toBlpCMYK8 <$> levels+    header = scanHeader 624 streams  -- | Manually scan shared prefix of each mipmap scanHeader :: Int -> [BS.ByteString] -> BS.ByteString@@ -234,8 +201,8 @@     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+makePallette :: Image PixelRGB8 -> (Image Pixel8, Palette)+makePallette = palettize defaultPaletteOptions  -- | Convert palette to format that we need for BLP convertPalette :: Palette -> V.Vector PixelRGBA8@@ -249,36 +216,23 @@   -- 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-toBlpUncompressed1 numMips img =  BlpUncompressed1 {-    blpU1Palette = convertPalette palette-  , blpU1MipMaps = fmap convertIndexed mipmaps `zip` fmap convertIndexed alphaMaps+-- | Quantise a picture to a 256 colour palette and create mipmaps, with an+-- 8-bit alpha list after each index list when asked to keep alpha.+toBlpPaletted :: Bool -> Int -> Image PixelRGB8 -> Image PixelRGBA8 -> BlpExt+toBlpPaletted keepAlpha numLevels rgb rgba = BlpPaletted {+    blpPalette = convertPalette palette+  , blpPalettedMipMaps = if keepAlpha+      then zipWith (<>) (convertIndexed <$> mipmaps) (convertIndexed <$> alphaMaps)+      else convertIndexed <$> mipmaps   }   where     img'    :: Image Pixel8     palette :: Palette-    (img', palette) = makePallette img--    alphaImg :: Image Pixel8-    alphaImg = extractComponent PlaneAlpha img+    (img', palette) = makePallette rgb      mipmaps :: [Image Pixel8]-    mipmaps = fakeMipMaps numMips $ createMipMapsIndexed img'+    mipmaps = take numLevels $ createMipMapsIndexed img' +    -- Alpha is coverage, not an index, so its mipmaps are averaged.     alphaMaps :: [Image Pixel8]-    alphaMaps = fakeMipMaps numMips $ createMipMapsIndexed alphaImg---- | Convert picture to BLP uncompressed without alpha and create mipmaps-toBlpUncompressed2 :: Int -> Image PixelRGBA8 -> BlpExt-toBlpUncompressed2 numMips img = BlpUncompressed2 {-    blpU2Palette = convertPalette palette-  , blpU2MipMaps = convertIndexed <$> mipmaps-  }-  where-    img'    :: Image Pixel8-    palette :: Palette-    (img', palette) = makePallette img--    mipmaps :: [Image Pixel8]-    mipmaps = fakeMipMaps numMips $ createMipMapsIndexed img'+    alphaMaps = take numLevels $ extractComponent PlaneAlpha <$> createMipMaps rgba

@@ -1,98 +1,104 @@+{-|+Parser for BLP1 files. It reads the header with attoparsec and takes the+content (JPEG header, palette, mip levels) straight from the slots the header+points at; turning the content into images is done in "Codec.Picture.Blp".++This is an internal module: its API may change between minor versions.+-} module Codec.Picture.Blp.Internal.Parser(-    blpParser+    parseBlp   , blpVersion   , dword   , compressionParser-  , flagsParser-  , pictureTypeParser-  , blpJpegParser-  , getPos-  , skipToOffset-  , blpUncompressed1Parser-  , blpUncompressed2Parser-  , parseBlp+  , maxSide+  , mipChainLength+  , mipLevels+  , jpegFrameSize   ) where  import Codec.Picture-import Control.Monad-import Data.Attoparsec.ByteString as AT+import Data.Attoparsec.ByteString (Parser, parseOnly, string, count, (<?>))+import qualified Data.Attoparsec.ByteString as AT import Data.Bits import Data.ByteString (ByteString)-import Data.List (nub, sortOn) import Data.Word  import qualified Data.Vector as V-import qualified Data.Attoparsec.Internal.Types as AT import qualified Data.ByteString as BS  import Codec.Picture.Blp.Internal.Data -blpParser :: Int -> Parser BlpStruct-blpParser inputLen = do+-- | Size of the fixed BLP1 header in bytes.+headerSize :: Int+headerSize = 156++-- | Largest width or height the format allows.+maxSide :: Int+maxSide = 65535++-- | Parse a BLP1 file into its header and raw content.+--+-- Width and height must be between 1 and 'maxSide'. Mip levels are taken+-- slot by slot, see 'mipLevels'.+parseBlp :: ByteString -> Either String BlpStruct+parseBlp input = do+  (mkStruct, compression, width, height, slots) <- parseOnly headerParser input+  let w = fromIntegral width+      h = fromIntegral height+  if w < 1 || h < 1 || w > maxSide || h > maxSide+    then Left $ "Invalid image size " ++ show width ++ "x" ++ show height+    else Right ()+  let levelsFrom start = mipLevels (BS.length input) start (mipChainLength w h) slots+      slice (offset, size) = BS.take size (BS.drop offset input)+  fmap mkStruct $ case compression of+    BlpCompressionJPEG -> do+      jpegHeaderSize <- parseOnly (AT.take headerSize *> dword <?> "jpeg header size") input+      let headerEnd = headerSize + 4 + fromIntegral jpegHeaderSize+      if headerEnd > BS.length input+        then Left "jpeg header: not enough input"+        else Right BlpJpeg {+            blpJpegHeader = slice (headerSize + 4, fromIntegral jpegHeaderSize)+          , blpJpegData = slice <$> levelsFrom headerEnd+          }+    BlpCompressionUncompressed -> do+      let levels = levelsFrom headerSize+          -- Some tools write only the palette entries they use, so the+          -- palette ends where mip 0 starts. Missing entries are padded+          -- with transparent black, so any index stays valid.+          paletteEnd = case levels of+            (offset, _) : _ -> min offset (headerSize + 1024)+            [] -> headerSize + 1024+          paletteBytes = slice (headerSize, paletteEnd - headerSize)+          entries = BS.length paletteBytes `div` 4+          entry i = let b k = BS.index paletteBytes (4 * i + k)+                    in PixelRGBA8 (b 0) (b 1) (b 2) (b 3)+      Right BlpPaletted {+          blpPalette = V.generate 256 $ \i ->+            if i < entries then entry i else PixelRGBA8 0 0 0 0+        , blpPalettedMipMaps = slice <$> levels+        }++-- | The fixed header: a function completing the struct with its content,+-- plus the fields needed to read the content.+headerParser :: Parser (BlpExt -> BlpStruct, BlpCompression, Word32, Word32, [(Word32, Word32)])+headerParser = do   _ <- blpVersion-  blpCompression <- compressionParser-  blpFlags <- flagsParser+  compression <- compressionParser+  blpAlphaBits <- dword <?> "alpha bits"   blpWidth <- dword <?> "width"   blpHeight <- dword <?> "height"-  blpPictureType <- pictureTypeParser-  blpPictureSubType <- dword <?> "picture subtype"-  blpMipMapOffset <- replicateM 16 dword <?> "mipmaps offsets"-  blpMipMapSize <- replicateM 16 dword <?> "mipmaps sizes"-  -- 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 effectivePictureType of-      JPEGType -> fail "JPEG type with Uncompressed type mix"-      UncompressedWithAlpha -> blpUncompressed1Parser mipMapsInfo-      UncompressedWithoutAlpha -> blpUncompressed2Parser mipMapsInfo--  return $ BlpStruct {..}+  blpExtra <- dword <?> "extra"+  blpHasMipmaps <- dword <?> "has mipmaps"+  offsets <- count 16 dword <?> "mipmaps offsets"+  sizes <- count 16 dword <?> "mipmaps sizes"+  let mkStruct blpExt = BlpStruct {..}+  return (mkStruct, compression, blpWidth, blpHeight, offsets `zip` sizes) +-- | The @BLP1@ magic. BLP0 and BLP2 files fail here. blpVersion :: Parser ByteString blpVersion = string "BLP1" <?> "BLP1 version tag" +-- | A little-endian 32-bit word. dword :: Parser Word32 dword = do   bs <- AT.take 4@@ -100,9 +106,7 @@   where   pack = BS.foldl' (\n h -> (n `shiftL` 8) .|. fromIntegral h) 0 -rgba8 :: Parser PixelRGBA8-rgba8 = PixelRGBA8 <$> anyWord8 <*> anyWord8 <*> anyWord8 <*> anyWord8-+-- | Header dword @0x04@ (@content@): 0 is JPEG, 1 is paletted. compressionParser :: Parser BlpCompression compressionParser = (<?> "compression") $ do   i <- dword@@ -111,86 +115,59 @@     1 -> return BlpCompressionUncompressed     _ -> fail $ "Unknown compression " ++ show i -flagsParser :: Parser [BlpFlag]-flagsParser = (<?> "flags") $ do-  i <- dword-  return $ if i `testBit` 3-    then [BlpFlagAlphaChannel]-    else []--pictureTypeParser :: Parser BlpPictureType-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-blpJpegParser mps = (<?> "blp jpeg") $ do-  headerSize <- dword <?> "jpeg header size"-  blpJpegHeader <- AT.take (fromIntegral headerSize) <?> "jpeg header"-  blpJpegData <- forM mps $ \(offset, size) -> do-    skipToOffset offset-    AT.take $ fromIntegral size-  return $ BlpJpeg {..}--getPos :: Parser Int-getPos = AT.Parser $ \t pos more _ succ' -> succ' t pos more (AT.fromPos pos)--skipToOffset :: Word32 -> Parser ()-skipToOffset i = do-  pos <- getPos-  let diff = fromIntegral i - pos-  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 <- paletteParser mps-  blpU1MipMaps <- forM mps $ \(offset, size) -> do-    skipToOffset offset-    let halfSize = fromIntegral size `div` 2-    indexList <- AT.take halfSize <?> "index list"-    alphaList <- AT.take halfSize <?> "alpha list"-    return (indexList, alphaList)-  return $ BlpUncompressed1 {..}+-- | Number of levels in a full mip chain: halving the larger side down to 1,+-- at most 16.+mipChainLength :: Int -> Int -> Int+mipChainLength w h = min 16 . length . takeWhile (>= 1) $ iterate (`div` 2) (max w h) -blpUncompressed2Parser :: [(Word32, Word32)] -> Parser BlpExt-blpUncompressed2Parser mps = do-  blpU2Palette <- paletteParser mps-  blpU2MipMaps <- forM mps $ \(offset, size) -> do-    skipToOffset offset-    AT.take (fromIntegral size) <?> "index list"-  return $ BlpUncompressed2 {..}+-- | The mip levels a file holds, as (offset, size) in the input. Slots are+-- read in order from slot 0, and the chain ends at the first slot that is+-- empty, does not fit in the input, starts before the given content offset,+-- or overlaps an earlier level, and after the given number of levels.+--+-- Unused slots should be zero, but tools leave garbage there: offsets past+-- the end of the file, or copies of an earlier slot. Ending the chain there+-- keeps element @i@ of the result level @i@.+mipLevels :: Int -- ^ Length of the input+  -> Int -- ^ Offset where the content starts+  -> Int -- ^ Most levels to take+  -> [(Word32, Word32)] -- ^ Mipmap slots: offset and size+  -> [(Int, Int)]+mipLevels inputLen start maxLevels = go [] . take maxLevels+  where+    go used ((offset, size) : rest)+      | s > 0 && o >= toInteger start && o + s <= toInteger inputLen && not (any (overlaps (o, s)) used) =+          (fromInteger o, fromInteger s) : go ((o, s) : used) rest+      where+        o = toInteger offset+        s = toInteger size+    go _ _ = []+    overlaps (o, s) (o', s') = o < o' + s' && o' < o + s -parseBlp :: ByteString -> Either String BlpStruct-parseBlp bs = parseOnly (blpParser (BS.length bs)) bs+-- | Width and height from the frame header (SOFn) of a JPEG stream, read+-- without decoding the stream.+jpegFrameSize :: ByteString -> Maybe (Int, Int)+jpegFrameSize bs+  | BS.take 2 bs == BS.pack [0xFF, 0xD8] = go 2+  | otherwise = Nothing+  where+    go i = do+      0xFF <- byte i+      marker <- byte (i + 1)+      if | marker == 0xFF -> go (i + 1) -- fill byte+         | marker == 0x01 || (marker >= 0xD0 && marker <= 0xD7) -> go (i + 2) -- no length+         | marker == 0xD9 || marker == 0xDA -> Nothing -- end of image or start of scan+         | isFrameHeader marker -> do+             height <- word16 (i + 5)+             width <- word16 (i + 7)+             return (width, height)+         | otherwise -> do+             len <- word16 (i + 2)+             if len < 2 then Nothing else go (i + 2 + len)+    byte i = if i < BS.length bs then Just (BS.index bs i) else Nothing+    word16 i = do+      hi <- byte i+      lo <- byte (i + 1)+      return (fromIntegral hi * 256 + fromIntegral lo)+    -- SOF0 to SOF15, except DHT (C4), JPG (C8) and DAC (CC).+    isFrameHeader m = m >= 0xC0 && m <= 0xCF && m `notElem` [0xC4, 0xC8, 0xCC]

@@ -0,0 +1,31 @@+{-# OPTIONS_GHC -Wno-deprecations #-}+-- | Tests for the encoders that 'encodeBlpWith' replaced. They live in their+-- own module so that deprecation warnings stay errors everywhere else.+module Deprecated(deprecatedTests) where++import Codec.Picture+import Codec.Picture.Blp+import Control.Exception (ErrorCall, evaluate, try)+import Data.Either (isLeft)+import Data.Int (Int64)+import Test.Tasty+import Test.Tasty.HUnit++import qualified Data.ByteString.Lazy as BSL++deprecatedTests :: TestTree+deprecatedTests = testGroup "deprecated encoders"+  [ testCase "match encodeBlpWith" $ do+      let with f n = either (error . show) id $ encodeBlpWith (BlpEncodeOptions f n) img+      encodeBlpJpeg 90 3 img @?= with (BlpFormatJpeg 90) 3+      encodeBlpUncompressedWithAlpha 3 img @?= with (BlpFormatPaletted True) 3+      encodeBlpUncompressedWithoutAlpha 3 img @?= with (BlpFormatPaletted False) 3+  , testCase "clamp the JPEG quality" $ do+      encodeBlpJpeg 300 1 img @?= encodeBlpJpeg 100 1 img+      encodeBlpJpeg (-5) 1 img @?= encodeBlpJpeg 1 1 img+  , testCase "throw on an empty image" $ do+      r <- try (evaluate . BSL.length $ encodeBlpJpeg 90 1 (ImageRGBA8 $ generateImage (\_ _ -> PixelRGBA8 0 0 0 0) 0 3))+      assertBool "expected an error" (isLeft (r :: Either ErrorCall Int64))+  ]+  where+    img = ImageRGBA8 $ generateImage (\x y -> PixelRGBA8 (fromIntegral $ x * 16) (fromIntegral $ y * 16) 128 200) 16 16

@@ -2,6 +2,7 @@  import Codec.Picture import Codec.Picture.Blp+import Codec.Picture.Blp.Internal.Encoder (createMipMaps) import Codec.Picture.Types (convertImage) import Control.Exception (bracket_, try) import Control.Monad (forM_)@@ -16,6 +17,7 @@ import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BSL +import Deprecated import Fixture  main :: IO ()@@ -25,6 +27,7 @@   , jpegTests   , encoderTests   , fileTests+  , deprecatedTests   ]  -- | 4x4 test texture: pixel (x, y) is palette index @y*4+x@.@@ -76,6 +79,23 @@   [ 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 "alphaBits 8 keeps alpha whatever extra says (#25)" $+      assertPixels withAlphaPixel $ uncompressed defHeader { hPictureType = 5 } (palette 256) [indices <> alphaPlane]+  , testCase "extra has no effect (#25)" $+      forM_ [0, 1, 2, 3, 4, 5, 6, 7, 99] $ \extra ->+        assertPixels withAlphaPixel (withAlphaFile extra)+  , testCase "alphaBits 0 ignores a trailing alpha list (#25)" $+      assertPixels withoutAlphaPixel $ uncompressed defHeader { hFlags = 0, hPictureType = 4 } (palette 256) [indices <> alphaPlane]+  , testCase "1-bit alpha, least significant bit first (#25)" $ do+      let bs = uncompressed defHeader { hFlags = 1 } (palette 256) [indices <> BS.pack [0x0f, 0xf0]]+          on k = k < 4 || k >= 12+      assertPixels (\k -> setAlpha (if on k then 255 else 0) (withoutAlphaPixel k)) bs+  , testCase "4-bit alpha, low nibble first (#25)" $ do+      let nibbles = BS.pack [fromIntegral (2 * j) + 16 * fromIntegral (2 * j + 1) | j <- [0 .. 7 :: Int]]+          bs = uncompressed defHeader { hFlags = 4 } (palette 256) [indices <> nibbles]+      assertPixels (\k -> setAlpha (k * 17) (withoutAlphaPixel k)) bs+  , testCase "invalid alphaBits counts as no alpha (#25)" $+      assertPixels withoutAlphaPixel $ uncompressed defHeader { hFlags = 3 } (palette 256) [indices <> alphaPlane]   , 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 }@@ -128,10 +148,6 @@       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" $@@ -140,6 +156,16 @@       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 "width or height outside 1..65535 is an error" $ do+      let sized w h = uncompressed defHeader { hFlags = 0, hWidth = w, hHeight = h } (palette 256) [BS.replicate 4 0]+      assertLeft "Invalid image size" . decodeBlp $ sized 0xFFFFFFFF 0xFFFFFFFF+      assertLeft "Invalid image size" . decodeBlp $ sized 0 4+      assertLeft "Invalid image size" . decodeBlp $ sized 4 65536+  , testCase "garbage slot before mip 0 leaves the palette intact" $ do+      let bs = setDword (offsetSlot 1) 200 . setDword (sizeSlot 1) 4 $ withAlphaFile 4+      assertPixels withAlphaPixel bs+      levels <- decodeLevels bs+      length levels @?= 1   , testCase "uncompressed file without mipmaps" $       assertLeft "No data" . decodeBlp $ blpFile defHeader [] (paletteBytes $ palette 256)   , testCase "JPEG file without mipmaps" $@@ -157,7 +183,7 @@ opaqueGradient = pixelMap (\(PixelRGBA8 r g b _) -> PixelRGBA8 r g b 255) gradient  jpegFile :: ByteString-jpegFile = BSL.toStrict $ encodeBlpJpeg 100 3 (ImageRGBA8 gradient)+jpegFile = BSL.toStrict $ enc (BlpFormatJpeg 100) 3 (ImageRGBA8 gradient)  -- | Largest per-channel difference between two equally sized images. maxDiff :: Image PixelRGBA8 -> Image PixelRGBA8 -> Int@@ -173,12 +199,15 @@ jpegTests :: TestTree jpegTests = testGroup "jpeg"   [ testCase "opaque texture round-trips through the encoder (#11)" $ do-      img <- decodeRGBA . BSL.toStrict $ encodeBlpJpeg 100 1 (ImageRGBA8 opaqueGradient)+      img <- decodeRGBA . BSL.toStrict $ enc (BlpFormatJpeg 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 "JPEG with alphaBits 0 decodes opaque (#25)" $ do+      img <- decodeRGBA (setDword 8 0 jpegFile)+      assertBool "every pixel opaque" $ all (\(PixelRGBA8 _ _ _ a) -> a == 255) (pixelsOf img)   , testCase "picture type 6 decodes like the original (#5)" $ do       orig <- decodeRGBA jpegFile       img <- decodeRGBA (setDword pictureTypeOffset 6 jpegFile)@@ -189,6 +218,29 @@   , 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 "JPEG frame larger than its level is rejected before decoding" $ do+      let sof = frameHeaderAt (fromIntegral headerSize + 4) jpegFile+          huge = foldr (\(i, v) bs -> setByte i v bs) jpegFile [(sof + k, 0xFF) | k <- [5 .. 8]]+      assertLeft "larger than its level size" $ decodeBlp huge+  , testCase "JPEG frame smaller than its level is padded with transparent black" $ do+      let big = setDword 12 32 (setDword 16 32 jpegFile)+      levels <- decodeLevels big+      sizes (take 2 levels) @?= [(32, 32), (16, 16)]+      orig <- decodeRGBA jpegFile+      case levels of+        mip0 : _ -> do+          pixelAt mip0 3 5 @?= pixelAt orig 3 5+          pixelAt mip0 20 20 @?= PixelRGBA8 0 0 0 0+        [] -> assertFailure "no levels"+  , testCase "a missing middle slot ends the chain" $ do+      levels <- decodeLevels (setDword (sizeSlot 1) 0 jpegFile)+      sizes levels @?= [(16, 16)]+  , testCase "a JPEG decoder error in mip 0 is a Left" $+      assertLeft "JPEG decoding failed" . decodeBlp $ jpegBlp 1 1 [badJpeg]+  , testCase "a JPEG decoder error in a tail mip ends the list" $ do+      let good = BSL.toStrict . encodeJpeg $ (convertImage (generateImage (\_ _ -> PixelRGB8 10 20 30) 2 2 :: Image PixelRGB8) :: Image PixelYCbCr8)+      levels <- decodeLevels (jpegBlp 2 2 [good, badJpeg])+      sizes levels @?= [(2, 2)]   , testCase "broken mip 0 fails the file" $       assertLeft "" . decodeBlp $ setDword (sizeSlot 0) 12 jpegFile   , testCase "three-component JPEG decodes to RGBA" $ do@@ -203,18 +255,18 @@           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)+      img <- decodeRGBA . BSL.toStrict $ enc (BlpFormatJpeg 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)+      img <- decodeRGBA . BSL.toStrict $ enc (BlpFormatJpeg 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)+      img <- decodeRGBA . BSL.toStrict $ enc (BlpFormatJpeg 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@@ -224,7 +276,7 @@       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)+      img <- decodeRGBA . BSL.toStrict $ enc (BlpFormatJpeg 100) 1 (ImageRGBA8 tiny)       let d = maxDiff tiny img       assertBool ("max channel difference " ++ show d) (d <= 4)   ]@@ -232,29 +284,29 @@ encoderTests :: TestTree encoderTests = testGroup "encoder"   [ testCase "with alpha writes the expected header" $ do-      let bs = BSL.toStrict $ encodeBlpUncompressedWithAlpha 3 (ImageRGBA8 gradient)+      let bs = BSL.toStrict $ enc (BlpFormatPaletted True) 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))+      let bs = BSL.toStrict $ enc (BlpFormatPaletted False) 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)+      img <- decodeRGBA . BSL.toStrict $ enc (BlpFormatPaletted True) 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)+      img <- decodeRGBA . BSL.toStrict $ enc (BlpFormatPaletted False) 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)+      levels <- decodeLevels . BSL.toStrict $ enc (BlpFormatPaletted True) 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+      let header dyn = let bs = BSL.toStrict $ enc (BlpFormatJpeg 90) 1 dyn                        in (getDword 8 bs, getDword pictureTypeOffset bs)           rgba = convertRGBA8 (ImageRGBA8 gradient)       header (ImageY8 $ pixelMap (\(PixelRGBA8 r _ _ _) -> r) rgba) @?= (0, 5)@@ -262,44 +314,99 @@       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)+      let bs = BSL.toStrict $ enc (BlpFormatPaletted False) 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))+      let bs = BSL.toStrict $ enc (BlpFormatPaletted True) 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))+      let bs = BSL.toStrict $ enc (BlpFormatJpeg 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)+      levels <- decodeLevels . BSL.toStrict $ enc (BlpFormatPaletted True) 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+  , testCase "non-square mip chain goes on to 1x1 (#26)" $ 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+      levels <- decodeLevels . BSL.toStrict $ enc (BlpFormatJpeg 90) 16 (ImageRGBA8 wide)+      sizes levels @?= [(64, 16), (32, 8), (16, 4), (8, 2), (4, 1), (2, 1), (1, 1)]+      odd' <- decodeLevels . BSL.toStrict $ enc (BlpFormatPaletted True) 16 (ImageRGBA8 $ generateImage (\_ _ -> PixelRGBA8 1 2 3 4) 5 3)+      sizes odd' @?= [(5, 3), (2, 1), (1, 1)]+  , testCase "single-row texture keeps halving its width (#26)" $ do+      let row = ImageRGBA8 $ generateImage (\x _ -> PixelRGBA8 (fromIntegral x) 0 0 255) 8 1+      forM_ [enc (BlpFormatJpeg 90) 16 row, enc (BlpFormatPaletted True) 16 row] $ \bs -> do+        levels <- decodeLevels (BSL.toStrict bs)+        sizes levels @?= [(8, 1), (4, 1), (2, 1), (1, 1)]+  , testCase "a solid texture stays solid down to 1x1 (#26)" $ do+      let solid = PixelRGBA8 200 100 50 128+          img = ImageRGBA8 $ generateImage (\_ _ -> solid) 6 3+      levels <- decodeLevels . BSL.toStrict $ enc (BlpFormatPaletted True) 16 img+      sizes levels @?= [(6, 3), (3, 1), (1, 1)]+      forM_ levels $ \level -> assertBool "every pixel unchanged" (all (== solid) (pixelsOf level))+  , testCase "slots repeating the last level add no levels" $ do+      let bs = BSL.toStrict $ enc (BlpFormatPaletted True) 5 (ImageRGBA8 gradient)+          lastSlot = (getDword (offsetSlot 4) bs, getDword (sizeSlot 4) bs)+          padded = foldr (\i b -> setDword (offsetSlot i) (fst lastSlot) (setDword (sizeSlot i) (snd lastSlot) b)) bs [5 .. 15]+      levels <- decodeLevels padded+      sizes levels @?= [(16, 16), (8, 8), (4, 4), (2, 2), (1, 1)]+  , testCase "unused mipmap slots are zero" $ do+      let bs = BSL.toStrict $ enc (BlpFormatPaletted True) 2 (ImageRGBA8 gradient)+      [(getDword (offsetSlot i) bs, getDword (sizeSlot i) bs) | i <- [2 .. 15]] @?= replicate 14 (0, 0)+  , testCase "hasMipmaps is 0 for a single level" $ do+      let hasMipmaps n = getDword 24 . BSL.toStrict $ enc (BlpFormatJpeg 90) n (ImageRGBA8 gradient)+      hasMipmaps 1 @?= 0+      hasMipmaps 3 @?= 5+  , testCase "encodeBlpWith rejects what it cannot encode" $ do+      let opts f = BlpEncodeOptions f 16+          blank w h = ImageRGBA8 $ generateImage (\_ _ -> PixelRGBA8 0 0 0 0) w h+          errorOf o img = either Just (const Nothing) (encodeBlpWith o img)+      errorOf (opts (BlpFormatJpeg 90)) (blank 0 4) @?= Just BlpEmptyImage+      errorOf (opts (BlpFormatPaletted True)) (blank 4 0) @?= Just BlpEmptyImage+      errorOf (opts (BlpFormatJpeg 90)) (blank 65536 1) @?= Just (BlpImageTooLarge 65536 1)+      errorOf (opts (BlpFormatJpeg 0)) (blank 4 4) @?= Just (BlpInvalidJpegQuality 0)+      errorOf (opts (BlpFormatJpeg 101)) (blank 4 4) @?= Just (BlpInvalidJpegQuality 101)+      errorOf defaultBlpEncodeOptions (blank 4 4) @?= Nothing+  , testCase "colour of transparent pixels does not bleed into mipmaps" $ do+      let px x y = if (x, y) == (0, 0) then PixelRGBA8 255 255 255 255 else PixelRGBA8 0 0 0 0+          img = generateImage px 2 2+      case createMipMaps img of+        _ : level1 : _ -> pixelAt level1 0 0 @?= PixelRGBA8 255 255 255 64+        _ -> assertFailure "expected two levels"+  , testCase "paletted alpha mipmaps are averaged" $ do+      let checker = generateImage (\x y -> PixelRGBA8 200 100 50 (if even (x + y) then 0 else 255)) 16 16+      levels <- decodeLevels . BSL.toStrict $ enc (BlpFormatPaletted True) 2 (ImageRGBA8 checker)+      case levels of+        _ : level1 : _ -> assertBool "alpha around half" $+          all (\(PixelRGBA8 _ _ _ a) -> a == 128) (pixelsOf level1)+        _ -> assertFailure "expected two levels"+  , testCase "opaque mipmaps average plainly" $ do+      let img = generateImage (\x _ -> PixelRGBA8 (fromIntegral $ 10 * x) 7 0 255) 4 1+      case createMipMaps img of+        _ : level1 : _ -> pixelsOf level1 @?= [PixelRGBA8 5 7 0 255, PixelRGBA8 25 7 0 255]+        _ -> assertFailure "expected two levels"+  , testCase "mipMapsUpTo is at most 16" $+      mipMapsUpTo 1 (ImageRGBA8 $ generateImage (\_ _ -> PixelRGBA8 0 0 0 0) 65535 1) @?= 16+  , testCase "mipMapsUpTo counts levels by the larger side (#26)" $ 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 64 16) @?= 7+      mipMapsUpTo 16 (img 64 16) @?= 3       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+      let encs n = [ enc (BlpFormatJpeg 90) n (ImageRGBA8 gradient)+                   , enc (BlpFormatPaletted True) n (ImageRGBA8 gradient) ]+      forM_ (concatMap encs [0, -1]) $ \bs -> do         levels <- decodeLevels (BSL.toStrict bs)         sizes levels @?= [(16, 16)]   ]@@ -316,9 +423,9 @@             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)+      check $ \p -> writeOk p (BlpFormatJpeg 100) img+      check $ \p -> writeOk p (BlpFormatPaletted True) img+      check $ \p -> writeOk p (BlpFormatPaletted False) (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)@@ -329,3 +436,37 @@  w16 :: Word8 -> Word16 w16 v = fromIntegral v * 257++setAlpha :: Word8 -> PixelRGBA8 -> PixelRGBA8+setAlpha a (PixelRGBA8 r g b _) = PixelRGBA8 r g b a++setByte :: Int -> Word8 -> ByteString -> ByteString+setByte i v bs = BS.take i bs <> BS.singleton v <> BS.drop (i + 1) bs++-- | Offset of the first JPEG frame header (FF C0) at or after the given offset.+frameHeaderAt :: Word32 -> ByteString -> Int+frameHeaderAt from bs = fromIntegral from + BS.length (fst (BS.breakSubstring (BS.pack [0xFF, 0xC0]) (BS.drop (fromIntegral from) bs)))++-- | A 1x1 JPEG whose scan selects a component the frame does not have.+-- JuicyPixels 3.3.9 raises an error on it instead of returning Left.+badJpeg :: ByteString+badJpeg = BS.pack+  [ 0xff, 0xd8, 0xff, 0xc0, 0x00, 0x0b, 0x08, 0x00, 0x01, 0x00, 0x01, 0x01, 0x01, 0x11, 0x00+  , 0xff, 0xda, 0x00, 0x08, 0x01, 0x02, 0x00, 0x00, 0x3f, 0x00, 0xff, 0xd9 ]++-- | JPEG BLP without alpha and with an empty shared header, holding the given+-- streams as its mip levels.+jpegBlp :: Word32 -> Word32 -> [ByteString] -> ByteString+jpegBlp w h mips = blpFile defHeader { hCompression = 0, hFlags = 0, hWidth = w, hHeight = h } slots ("\0\0\0\0" <> BS.concat mips)+  where+    sizes' = map (fromIntegral . BS.length) mips+    slots = zip (scanl (+) (fromIntegral headerSize + 4) sizes') sizes'++-- | Encode with the given format and number of levels, failing the test on+-- an encoding error.+enc :: BlpFormat -> Int -> DynamicImage -> BSL.ByteString+enc format levels = either (error . show) id . encodeBlpWith (BlpEncodeOptions format levels)++-- | Write a file with two mip levels, failing the test on an encoding error.+writeOk :: FilePath -> BlpFormat -> DynamicImage -> IO ()+writeOk path format img = writeBlpWith path (BlpEncodeOptions format 2) img >>= either (assertFailure . show) return