JuicyPixels-blp 0.4.1.0 → 0.5.0.0

raw patch · 13 files changed

+274/−51 lines, 13 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +27/−0
• JuicyPixels-blp.cabal +1/−1
• README.md +32/−10
• bench/Main.hs +1/−1
• blp2any/Convert.hs +8/−4
• blp2any/Main.hs +2/−0
• docs/format.md +7/−4
• src/Codec/Picture/Blp.hs +14/−9
• src/Codec/Picture/Blp/Internal/Data.hs +7/−0
• src/Codec/Picture/Blp/Internal/Encoder.hs +99/−17
• test/Deprecated.hs +1/−1
• test/Main.hs +74/−3
• test/Properties.hs +1/−1

@@ -1,3 +1,30 @@+0.5.0.0 (2026-10-16)+====================++Paletted textures look better, and encoding takes new options. The+encoder's output changes, and `BlpEncodeOptions` has new fields.++- Paletted mipmaps after the first are averaged and mapped to the nearest+  palette colour, instead of taking one pixel of the dithered image per+  block. Measured against exact downscaling, levels 1 to 5 gain 8–17 dB on a+  smooth gradient, about 11 dB on a noisy texture (15–16 dB to 26–27 dB),+  and up to 25 dB on the small levels of a soft-edged sprite. Mip 0 is+  unchanged. Paletted encoding is 20–30% slower for it.+- Fully transparent pixels count as black when the palette is built, so+  colours hidden under them no longer take palette entries.+- `BlpEncodeOptions` gains `blpDither` (on by default) and `blpMaxSize`,+  which halves the image until its larger side fits; Warcraft III shows+  mip levels up to 512 pixels only. `blp2any` has `--no-dither` and+  `--max-size PIXELS`. Build options from `defaultBlpEncodeOptions`; code+  that applied the `BlpEncodeOptions` constructor to two arguments needs+  updating. `BlpInvalidMaxSize` is a new `BlpEncodeError`.+- JPEG textures made from RGBA images whose pixels are all opaque are+  written without alpha.+- Ready-made `blp2any` binaries for Windows, macOS (Apple Silicon) and+  Linux are attached to the GitHub release (#45).+- `Codec.Picture.Blp.Internal.Encoder`: `toBlpStruct` takes+  `BlpEncodeOptions`; `shrinkTo` is new.+ 0.4.1.0 (2026-10-15) ==================== 

@@ -1,6 +1,6 @@ cabal-version:       2.2 name:                JuicyPixels-blp-version:             0.4.1.0+version:             0.5.0.0 synopsis:            BLP format decoder/encoder over JuicyPixels library description:   Read and write BLP1, the texture format of Warcraft III, with images as

@@ -39,10 +39,17 @@     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.+  - `blpDither`: whether paletted textures are dithered (on by default;+    turn it off for icons and pixel art).+  - `blpMaxSize`: halve the image until its larger side is at most this.+    Warcraft III shows mip levels up to 512 pixels only, so larger ones only+    make the file bigger. +  Start from `defaultBlpEncodeOptions` and change the fields you need.+   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.+  empty image, a side above 65535 (after `blpMaxSize`), an invalid JPEG+  quality or size limit, or a file over 4 GiB. - The older `encodeBlpJpeg`, `encodeBlpUncompressedWithAlpha`,   `encodeBlpUncompressedWithoutAlpha` and their `write` variants are   deprecated wrappers around `encodeBlpWith`.@@ -79,17 +86,26 @@ - **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.+- **Lossy palette.** Uncompressed encoding quantises to 256 colours, so it is+  lossy for images with more colours. Mipmaps after the first are mapped to+  the first level's palette. - **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 +Ready-made binaries for Windows, macOS (Apple Silicon) and Linux are+attached to each [GitHub release](https://github.com/NCrashed/JuicyPixels-blp/releases)+from 0.5.0.0 on. The Linux binary needs glibc 2.35 or newer (Ubuntu 22.04,+Debian 12 and later), plus zlib and GMP, which almost every distribution+has. To build it yourself instead, use `cabal install JuicyPixels-blp`+(from Hackage) or `nix run github:NCrashed/JuicyPixels-blp`.+ ``` blp2any convert INPUT_PATH OUTPUT_PATH [-i FORMAT] [-f FORMAT] [-q QUALITY]                 [-b jpg|uncompressedWithAlpha|uncompressedWithoutAlpha]-                [--min-mipmap-size N] [-s|--shallow] [-p|--flatten] [--timeout SECONDS]+                [--min-mipmap-size N] [--max-size PIXELS] [--no-dither]+                [-s|--shallow] [-p|--flatten] [--timeout SECONDS] blp2any stats DIRECTORY OUTPUT_PATH ``` @@ -104,11 +120,17 @@   - `--timeout SECONDS` gives up on a file that takes longer; use it on     untrusted input, where some corrupt JPEG data makes decoding hang. The     output never overwrites its input.-  - 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.+  - When writing BLP:+    - `-b` picks the internal format, JPEG by default.+    - `--max-size PIXELS` halves the image until its larger side fits;+      Warcraft III shows mip levels up to 512 pixels only.+    - `--no-dither` turns off dithering for paletted output, which suits+      icons and pixel art.+    - `--min-mipmap-size` is 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.

@@ -69,7 +69,7 @@   | n <- sizes ]  encodeWith :: BlpFormat -> Int -> DynamicImage -> BSL.ByteString-encodeWith format levels = either (error . show) id . encodeBlpWith (BlpEncodeOptions format levels)+encodeWith format levels = either (error . show) id . encodeBlpWith defaultBlpEncodeOptions { blpFormat = format, blpMipLevels = levels }  -- | Square test texture with varying alpha. texture :: Int -> DynamicImage

@@ -97,6 +97,8 @@ , convertBlpKind        :: BlpKind , convertBlpMinMipSize  :: Int , convertTimeout        :: Maybe Int+, convertDither         :: Bool+, convertMaxSize        :: Maybe Int }  convertFiles :: ConvertOptions -> IO ()@@ -163,7 +165,8 @@   liftIO . createDirectoryIfMissing True $ takeDirectory outputFile    let mipsCount = mipMapsUpTo convertBlpMinMipSize img-  ExceptT $ convertionFunction distFormat convertQuality convertBlpKind outputFile mipsCount img+  let encodeOptions = defaultBlpEncodeOptions { blpMipLevels = mipsCount, blpDither = convertDither, blpMaxSize = convertMaxSize }+  ExceptT $ convertionFunction distFormat convertQuality convertBlpKind encodeOptions outputFile img   pure $ inputFile <> ": Success"  -- | A readable message for an encoding error.@@ -173,6 +176,7 @@   BlpImageTooLarge w h -> "the image is " <> show w <> "x" <> show h <> ", above the 65535 pixel limit of BLP"   BlpInvalidJpegQuality q -> "JPEG quality must be 1 to 100, got " <> show q   BlpFileTooLarge -> "the BLP file would be larger than 4 GiB"+  BlpInvalidMaxSize n -> "--max-size must be at least 1, got " <> show n  -- | Run a conversion, giving up after the given number of seconds. withTimeout :: Maybe Int -> IO (Either String a) -> IO (Either String a)@@ -180,14 +184,14 @@ withTimeout (Just seconds) action =   fromMaybe (Left $ "gave up after " <> show seconds <> " s") <$> timeout (seconds * 1000000) action -convertionFunction :: ConvertFormat -> Int -> BlpKind -> FilePath -> Int -> DynamicImage -> IO (Either String ())-convertionFunction f quality blpKind path mipsCount img = case f of+convertionFunction :: ConvertFormat -> Int -> BlpKind -> BlpEncodeOptions -> FilePath -> DynamicImage -> IO (Either String ())+convertionFunction f quality blpKind encodeOptions path 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+    res <- writeBlpWith path encodeOptions { blpFormat = format } img     pure $ either (Left . describeEncodeError) Right res   Png -> do     res <- writeDynamicPng path img

@@ -46,6 +46,8 @@       <*> 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)")       <*> optional (option auto (long "timeout" <> metavar "SECONDS" <> help "Give up on a file after this many seconds; some corrupt JPEG data makes decoding hang"))+      <*> fmap not (switch (long "no-dither" <> help "Do not dither paletted BLP textures; better for icons and pixel art"))+      <*> optional (option auto (long "max-size" <> metavar "PIXELS" <> help "When writing BLP, halve the image until its larger side is at most this; Warcraft III shows mip levels up to 512 only"))     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")

@@ -87,9 +87,9 @@   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)).+  of paletted textures, is a plain average. Paletted levels after mip 0 are+  averaged this way and then mapped to the nearest colour of mip 0's+  palette ([#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@@ -154,7 +154,10 @@   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.+  palette, with dithering unless `blpDither` is off, and writes 8-bit alpha+  or none. With alpha, the colour of fully transparent pixels is treated as+  black when building the palette, so colours hidden under them take no+  entries; they are invisible in the decoded texture either way.  ## Deviations found in real files 

@@ -261,25 +261,30 @@   where     larger = max (dynamicMap imageWidth img) (dynamicMap imageHeight img) --- | JPEG at quality 90 with the full mip chain.+-- | JPEG at quality 90 with the full mip chain, dithered palettes, and no+-- size limit. defaultBlpEncodeOptions :: BlpEncodeOptions defaultBlpEncodeOptions = BlpEncodeOptions {     blpFormat = BlpFormatJpeg 90   , blpMipLevels = 16+  , blpDither = True+  , blpMaxSize = Nothing   }  -- | Encode an image as a BLP1 file. encodeBlpWith :: BlpEncodeOptions -> DynamicImage -> Either BlpEncodeError BSL.ByteString-encodeBlpWith BlpEncodeOptions{..} img-  | w < 1 || h < 1 = Left BlpEmptyImage+encodeBlpWith opts@BlpEncodeOptions{..} img+  | dynamicMap imageWidth img < 1 || dynamicMap imageHeight img < 1 = Left BlpEmptyImage+  | Just limit <- blpMaxSize, limit < 1 = Left $ BlpInvalidMaxSize limit   | 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)+    source = maybe img (`shrinkTo` img) blpMaxSize+    w = dynamicMap imageWidth source+    h = dynamicMap imageHeight source+    file = encodeBlp (toBlpStruct opts source)  -- | Encode an image with 'encodeBlpWith' and write it to a file. writeBlpWith :: FilePath -> BlpEncodeOptions -> DynamicImage -> IO (Either BlpEncodeError ())@@ -307,7 +312,7 @@   -> DynamicImage   -> BSL.ByteString encodeBlpJpeg quality numMips =-  orThrow "encodeBlpJpeg" . encodeBlpWith (BlpEncodeOptions (BlpFormatJpeg (max 1 (min 100 quality))) numMips)+  orThrow "encodeBlpJpeg" . encodeBlpWith defaultBlpEncodeOptions { blpFormat = BlpFormatJpeg (max 1 (min 100 quality)), blpMipLevels = numMips } {-# DEPRECATED encodeBlpJpeg "Use encodeBlpWith with BlpFormatJpeg" #-}  -- | Encode with a 256 colour palette and 8-bit alpha; see 'BlpFormatPaletted'.@@ -315,7 +320,7 @@   -> DynamicImage   -> BSL.ByteString encodeBlpUncompressedWithAlpha numMips =-  orThrow "encodeBlpUncompressedWithAlpha" . encodeBlpWith (BlpEncodeOptions (BlpFormatPaletted True) numMips)+  orThrow "encodeBlpUncompressedWithAlpha" . encodeBlpWith defaultBlpEncodeOptions { blpFormat = BlpFormatPaletted True, blpMipLevels = numMips } {-# DEPRECATED encodeBlpUncompressedWithAlpha "Use encodeBlpWith with BlpFormatPaletted True" #-}  -- | Encode with a 256 colour palette and no alpha; see 'BlpFormatPaletted'.@@ -323,7 +328,7 @@   -> DynamicImage   -> BSL.ByteString encodeBlpUncompressedWithoutAlpha numMips =-  orThrow "encodeBlpUncompressedWithoutAlpha" . encodeBlpWith (BlpEncodeOptions (BlpFormatPaletted False) numMips)+  orThrow "encodeBlpUncompressedWithoutAlpha" . encodeBlpWith defaultBlpEncodeOptions { blpFormat = BlpFormatPaletted False, blpMipLevels = numMips } {-# DEPRECATED encodeBlpUncompressedWithoutAlpha "Use encodeBlpWith with BlpFormatPaletted False" #-}  orThrow :: String -> Either BlpEncodeError a -> a

@@ -86,6 +86,12 @@   -- and values above what the image has mean the full chain down to 1x1   -- (at most 16 levels). , blpMipLevels :: !Int+  -- | Whether paletted textures are dithered. Dithering makes gradients+  -- smoother and spoils icons and pixel art.+, blpDither :: !Bool+  -- | Shrink the image, halving both sides, until the larger side is at most+  -- this many pixels. Warcraft III shows mip levels up to 512 pixels only.+, blpMaxSize :: !(Maybe Int) } deriving (Eq, Show)  -- | Why an image cannot be encoded.@@ -94,4 +100,5 @@   | 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.+  | BlpInvalidMaxSize !Int -- ^ A 'blpMaxSize' below 1.   deriving (Eq, Show)

@@ -8,6 +8,7 @@     encodeBlp   , blpEncoder   , toBlpStruct+  , shrinkTo   , createMipMaps   , createMipMapsIndexed   , scanHeader@@ -20,12 +21,14 @@ import Data.Binary.Put import Data.ByteString.Lazy (ByteString, toStrict) import Data.Foldable (traverse_)+import Data.List (sortOn) import Data.Word  import qualified Data.ByteString as BS import qualified Data.ByteString.Internal as BI import qualified Data.Vector as V import qualified Data.Vector.Storable as VS+import qualified Data.Vector.Unboxed as VU import qualified Data.Vector.Storable.Mutable as MVS  import Codec.Picture.Blp.Internal.Convert@@ -78,11 +81,11 @@   ImageRGBA16 _ -> True   _ -> False --- | 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 {+-- | Build the BLP structure for an image. The number of mip levels is clamped+-- to between 1 and the image's full chain, at most 16. The image's size is+-- not checked, and 'blpMaxSize' is applied by the caller (see 'shrinkTo').+toBlpStruct :: BlpEncodeOptions -> DynamicImage -> BlpStruct+toBlpStruct BlpEncodeOptions{..} img = BlpStruct {     blpAlphaBits = if alpha then 8 else 0   , blpWidth = fromIntegral width   , blpHeight = fromIntegral height@@ -91,21 +94,45 @@   , 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+  , blpExt = case blpFormat of       BlpFormatJpeg quality -> toBlpJpg (fromIntegral quality) numLevels alpha rgba-      BlpFormatPaletted _ -> toBlpPaletted alpha numLevels (convertRGB8 img) rgba+      BlpFormatPaletted _ -> toBlpPaletted blpDither alpha numLevels (convertRGB8 img) rgba   }   where-    alpha = case format of-      BlpFormatJpeg _ -> hasAlpha img+    -- JPEG keeps alpha only if some pixel is not fully opaque.+    alpha = case blpFormat of+      BlpFormatJpeg _ -> hasAlpha img && anyTransparent rgba       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+    numLevels = max 1 . min 16 $ min chainLength blpMipLevels +-- | Whether any pixel is less than fully opaque.+anyTransparent :: Image PixelRGBA8 -> Bool+anyTransparent img = go 3+  where+    src = imageData img+    go i+      | i >= VS.length src = False+      | VS.unsafeIndex src i /= 255 = True+      | otherwise = go (i + 4)++-- | Halve an image, as its mipmaps are made, until its larger side is at most+-- the given number of pixels. An image without alpha stays without alpha.+shrinkTo :: Int -> DynamicImage -> DynamicImage+shrinkTo limit img+  | max width height <= limit = img+  | otherwise = case dropWhile tooLarge (createMipMaps (convertRGBA8 img)) of+      level : _ -> if hasAlpha img then ImageRGBA8 level else ImageRGB8 (convertRGB8 (ImageRGBA8 level))+      [] -> img+  where+    width = dynamicMap imageWidth img+    height = dynamicMap imageHeight img+    tooLarge level = max (imageWidth level) (imageHeight level) > limit+ -- | Scale image to form the sequence of mipmaps. The first element is always the original picture. -- -- Each level averages 2x2 blocks; on an odd or one-pixel side the last block@@ -200,9 +227,9 @@     -- Safe to index: every stream is longer than the limit.     sameAt i = all (\m -> BS.index m i == BS.index m0 i) mipmaps --- | Helper to quantise colors to 256 colour pallete-makePallette :: Image PixelRGB8 -> (Image Pixel8, Palette)-makePallette = palettize defaultPaletteOptions+-- | Quantise to a 256 colour palette, with or without dithering.+makePallette :: Bool -> Image PixelRGB8 -> (Image Pixel8, Palette)+makePallette dither = palettize defaultPaletteOptions { enableImageDithering = dither }  -- | Convert palette to format that we need for BLP convertPalette :: Palette -> V.Vector PixelRGBA8@@ -218,8 +245,8 @@  -- | 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 {+toBlpPaletted :: Bool -> Bool -> Int -> Image PixelRGB8 -> Image PixelRGBA8 -> BlpExt+toBlpPaletted dither keepAlpha numLevels rgb rgba = BlpPaletted {     blpPalette = convertPalette palette   , blpPalettedMipMaps = if keepAlpha       then zipWith (<>) (convertIndexed <$> mipmaps) (convertIndexed <$> alphaMaps)@@ -228,11 +255,66 @@   where     img'    :: Image Pixel8     palette :: Palette-    (img', palette) = makePallette rgb+    -- Fully transparent pixels are made black, so the colours hidden under+    -- them take no palette entries.+    (img', palette) = makePallette dither $ if keepAlpha then fillTransparent rgba else rgb +    -- Smaller levels are averaged in RGBA and mapped to the nearest palette+    -- entry; picking one index per block would sample the dithering noise.     mipmaps :: [Image Pixel8]-    mipmaps = take numLevels $ createMipMapsIndexed img'+    mipmaps = take numLevels $ img' : (nearestIndices palette <$> drop 1 (createMipMaps averaged))+    averaged = if keepAlpha then rgba else opaqueRGBA8 rgba      -- Alpha is coverage, not an index, so its mipmaps are averaged.     alphaMaps :: [Image Pixel8]     alphaMaps = take numLevels $ extractComponent PlaneAlpha <$> createMipMaps rgba++-- | The RGB of an image, with every fully transparent pixel made black.+-- Whatever colour those pixels had is invisible, and leaving it in would+-- spend palette entries on it; a single colour costs at most one entry.+fillTransparent :: Image PixelRGBA8 -> Image PixelRGB8+fillTransparent = pixelMap $ \(PixelRGBA8 r g b a) -> if a == 0 then PixelRGB8 0 0 0 else PixelRGB8 r g b++-- | Index of the palette entry nearest to each pixel's colour (squared RGB+-- distance; alpha is stored separately; ties go to the lower index).+--+-- The entries are searched in order of red, outwards from the pixel's red,+-- and a direction stops once the red difference alone is no better than the+-- best match. That gives the same answer as trying every entry, with far+-- fewer tries.+nearestIndices :: Palette -> Image PixelRGBA8 -> Image Pixel8+nearestIndices palette img = pixelMap nearest img+  where+    entries = imageData palette+    count = VS.length entries `div` 3+    channel i k = fromIntegral (VS.unsafeIndex entries (i * 3 + k)) :: Int+    -- Entry indices sorted by red, and their reds.+    byRed = VU.fromList . map snd . sortOn fst $ [((channel i 0, i), i) | i <- [0 .. count - 1]]+    reds = VU.map (`channel` 0) byRed+    nearest (PixelRGBA8 r8 g8 b8 _) = fromIntegral . snd $ down (start - 1) (up start (maxBound, 0))+      where+        r = fromIntegral r8 :: Int+        g = fromIntegral g8 :: Int+        b = fromIntegral b8 :: Int+        -- First position whose red is at least the pixel's.+        start = search 0 count+        search lo hi+          | lo >= hi = lo+          | VU.unsafeIndex reds mid < r = search (mid + 1) hi+          | otherwise = search lo mid+          where mid = (lo + hi) `div` 2+        consider j best@(bestDist, bestIndex) = let+          i = VU.unsafeIndex byRed j+          dr = channel i 0 - r+          dg = channel i 1 - g+          db = channel i 2 - b+          dist = dr * dr + dg * dg + db * db+          in if dist < bestDist || (dist == bestDist && i < bestIndex) then (dist, i) else best+        up j best@(bestDist, _)+          | j >= count = best+          | let dr = VU.unsafeIndex reds j - r, dr * dr > bestDist = best+          | otherwise = up (j + 1) (consider j best)+        down j best@(bestDist, _)+          | j < 0 = best+          | let dr = r - VU.unsafeIndex reds j, dr * dr > bestDist = best+          | otherwise = down (j - 1) (consider j best)

@@ -16,7 +16,7 @@ deprecatedTests :: TestTree deprecatedTests = testGroup "deprecated encoders"   [ testCase "match encodeBlpWith" $ do-      let with f n = either (error . show) id $ encodeBlpWith (BlpEncodeOptions f n) img+      let with f n = either (error . show) id $ encodeBlpWith defaultBlpEncodeOptions { blpFormat = f, blpMipLevels = n } img       encodeBlpJpeg 90 3 img @?= with (BlpFormatJpeg 90) 3       encodeBlpUncompressedWithAlpha 3 img @?= with (BlpFormatPaletted True) 3       encodeBlpUncompressedWithoutAlpha 3 img @?= with (BlpFormatPaletted False) 3

@@ -27,6 +27,7 @@   , malformedTests   , jpegTests   , limitTests+  , qualityTests   , encoderTests   , fileTests   , deprecatedTests@@ -368,7 +369,7 @@       hasMipmaps 1 @?= 0       hasMipmaps 3 @?= 5   , testCase "encodeBlpWith rejects what it cannot encode" $ do-      let opts f = BlpEncodeOptions f 16+      let opts f = defaultBlpEncodeOptions { blpFormat = f }           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@@ -468,11 +469,11 @@ -- | 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)+enc format levels = either (error . show) id . encodeBlpWith defaultBlpEncodeOptions { blpFormat = format, blpMipLevels = 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+writeOk path format img = writeBlpWith path defaultBlpEncodeOptions { blpFormat = format, blpMipLevels = 2 } img >>= either (assertFailure . show) return  -- | A 1x1 JPEG texture whose header claims the given size. inflated :: Word32 -> ByteString@@ -498,4 +499,74 @@   , testCase "blpInfo rejects what decodeBlp rejects" $ do       assertLeft "BLP1" . blpInfo $ "BLP2" <> BS.drop 4 (withAlphaFile 4)       assertLeft "Invalid image size" . blpInfo $ setDword 12 0 (withAlphaFile 4)+  ]++-- | PSNR in dB between two equally sized images, on premultiplied RGBA so+-- that the colour of invisible pixels does not count.+psnr :: Image PixelRGBA8 -> Image PixelRGBA8 -> Double+psnr a b+  | mse == 0 = 99+  | otherwise = 10 * logBase 10 (255 * 255 / mse)+  where+    premul (PixelRGBA8 r g bl al) = let f c = fromIntegral c * fromIntegral al / 255 in [f r, f g, f bl, fromIntegral al] :: [Double]+    errs = concat (zipWith (\p q -> zipWith (\x y -> (x - y) ^ (2 :: Int)) (premul p) (premul q)) (pixelsOf a) (pixelsOf b))+    mse = sum errs / fromIntegral (length errs)++-- | PSNR of mip level 1 of an encoded texture against the exact reference.+level1Psnr :: BlpFormat -> Image PixelRGBA8 -> IO Double+level1Psnr format img = do+  levels <- decodeLevels . BSL.toStrict $ enc format 2 (ImageRGBA8 img)+  case (levels, createMipMaps img) of+    (_ : decoded : _, _ : reference : _) -> return $ psnr reference decoded+    _ -> assertFailure "expected two levels"++noisyTexture, smoothTexture :: Image PixelRGBA8+noisyTexture = generateImage (\x y -> let n = fromIntegral (((x * 7919 + y * 104729) * 2654435761) `div` 8192 `mod` 256) in PixelRGBA8 (fromIntegral x + n `div` 8) (fromIntegral y + n `div` 16) n 255) 128 128+smoothTexture = generateImage (\x y -> PixelRGBA8 (fromIntegral x) (fromIntegral y) (fromIntegral ((x + y) `div` 2)) 255) 256 256++-- | A soft-edged disc on a transparent background.+disc :: (Int -> Int -> PixelRGBA8) -> Image PixelRGBA8+disc background = generateImage px 64 64+  where+    px x y = let d = sqrt (fromIntegral ((x - 32) ^ (2 :: Int) + (y - 32) ^ (2 :: Int))) :: Double+                 a = max 0 (min 255 (round ((22 - d) * 64))) :: Int+             in if a == 0 then background x y else PixelRGBA8 (fromIntegral (150 + x)) (fromIntegral (60 + y)) 40 (fromIntegral a)++premultiplied :: Image PixelRGBA8 -> [PixelRGBA8]+premultiplied = map (\(PixelRGBA8 r g b a) -> let f c = fromIntegral (fromIntegral c * fromIntegral a `div` 255 :: Int) in PixelRGBA8 (f r) (f g) (f b) a) . pixelsOf++qualityTests :: TestTree+qualityTests = testGroup "encoder quality and options"+  [ testCase "paletted mipmaps are averaged, not sampled" $ do+      noisy <- level1Psnr (BlpFormatPaletted False) noisyTexture+      assertBool ("noisy level 1 at " ++ show noisy ++ " dB") (noisy >= 25)+      smooth <- level1Psnr (BlpFormatPaletted False) smoothTexture+      assertBool ("smooth level 1 at " ++ show smooth ++ " dB") (smooth >= 33)+  , testCase "colours hidden under full transparency do not matter" $ do+      let clean = disc (\_ _ -> PixelRGBA8 0 0 0 0)+          dirty = disc (\x y -> PixelRGBA8 (fromIntegral $ x * 4) (fromIntegral $ y * 4) (fromIntegral $ x * y) 0)+          levelsOf img = decodeLevels . BSL.toStrict $ enc (BlpFormatPaletted True) 16 (ImageRGBA8 img)+      a <- levelsOf clean+      b <- levelsOf dirty+      map premultiplied b @?= map premultiplied a+  , testCase "blpMaxSize halves the image until it fits" $ do+      let wide = ImageRGB8 . convertRGB8 . ImageRGBA8 $ generateImage (\x y -> PixelRGBA8 (fromIntegral x) (fromIntegral y) 9 255) 1024 256+          opts = defaultBlpEncodeOptions { blpMaxSize = Just 512 }+          bs = either (error . show) BSL.toStrict $ encodeBlpWith opts wide+      map (`getDword` bs) [12, 16] @?= [512, 128]+      getDword 8 bs @?= 0+      levels <- decodeLevels bs+      take 2 (sizes levels) @?= [(512, 128), (256, 64)]+  , testCase "blpMaxSize lets oversized images through and rejects nonsense" $ do+      let huge = ImageRGBA8 $ generateImage (\_ _ -> PixelRGBA8 1 2 3 255) 70000 1+      fmap (BS.take 4 . BSL.toStrict) (encodeBlpWith defaultBlpEncodeOptions { blpMaxSize = Just 512 } huge) @?= Right "BLP1"+      either Just (const Nothing) (encodeBlpWith defaultBlpEncodeOptions { blpMaxSize = Just 0 } huge) @?= Just (BlpInvalidMaxSize 0)+  , testCase "dithering can be switched off" $ do+      let encodeWith dither img = encodeBlpWith defaultBlpEncodeOptions { blpFormat = BlpFormatPaletted False, blpDither = dither } (ImageRGBA8 img)+          few = generateImage (\x y -> [PixelRGBA8 10 20 30 255, PixelRGBA8 200 100 50 255] !! ((x + y) `mod` 2)) 16 16+      assertBool "a smooth gradient differs" (encodeWith True smoothTexture /= encodeWith False smoothTexture)+      encodeWith True few @?= encodeWith False few+  , testCase "JPEG from fully opaque RGBA has no alpha" $ do+      let bs = BSL.toStrict $ enc (BlpFormatJpeg 90) 1 (ImageRGBA8 smoothTexture)+      (getDword 8 bs, getDword extraOffset bs) @?= (0, 5)   ]

@@ -46,7 +46,7 @@     px x y = PixelRGBA8 (fromIntegral $ x * 37) (fromIntegral $ y * 59) (fromIntegral $ x * y) (fromIntegral $ 255 - x * 13)  encode :: BlpFormat -> Int -> DynamicImage -> ByteString-encode format levels = BSL.toStrict . either (error . show) id . encodeBlpWith (BlpEncodeOptions format levels)+encode format levels = BSL.toStrict . either (error . show) id . encodeBlpWith defaultBlpEncodeOptions { blpFormat = format, blpMipLevels = levels }  -- | One way of damaging a file. data Damage