JuicyPixels-blp 0.5.0.0 → 0.6.0.0

raw patch · 18 files changed

+1220/−268 lines, 18 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +41/−7
• JuicyPixels-blp.cabal +14/−6
• README.md +15/−10
• bench/Main.hs +10/−0
• blp2any/Main.hs +1/−1
• docs/format.md +83/−8
• src/Codec/Picture/Blp.hs +11/−163
• src/Codec/Picture/Blp/Internal/Data.hs +69/−39
• src/Codec/Picture/Blp/Internal/Decoder.hs +220/−0
• src/Codec/Picture/Blp/Internal/Dxt.hs +182/−0
• src/Codec/Picture/Blp/Internal/Encoder.hs +1/−2
• src/Codec/Picture/Blp/Internal/Parser.hs +94/−25
• src/Codec/Picture/Blp/Types.hs +100/−0
• test/Blp2.hs +147/−0
• test/Dxt.hs +142/−0
• test/Fixture.hs +78/−1
• test/Main.hs +9/−5
• test/Properties.hs +3/−1

@@ -1,3 +1,44 @@+0.6.0.0 (2026-10-16)+====================++BLP2, the World of Warcraft variant, can be read. `BlpInfo` and+`BlpCompression` change for it; see the breaking change below.++- `decodeBlp`, `decodeBlpMipmaps`, their `With` and `read` variants and+  `blpInfo` read BLP2 files: DXT1, DXT3, DXT5, BGRA and paletted content,+  with mipmaps (#3). Damaged levels are handled as in BLP1, and the size+  limit applies. An alpha depth of 0 makes the image opaque. BLP2 files+  with JPEG content (`type` 0) are rejected; no known file uses them.+  `blp2any convert` reads BLP2 too.+- Decoding was checked pixel by pixel against the BLP2 sample files of+  Pillow and of the Pinta365/blp library. BGRA and paletted content match+  exactly. DXT colours differ by at most 2 per channel from Pinta365/blp,+  from rounding, and by up to 6 from Pillow, whose BLP plugin skips the+  bit replication of RGB565 endpoints. See `docs/format.md`.+- **Breaking:** `BlpInfo` has a new first field, `blpInfoVersion ::+  BlpVersion` (`Blp1` or `Blp2`), and `BlpCompression` new constructors+  `BlpCompressionDxt1`, `BlpCompressionDxt3`, `BlpCompressionDxt5` and+  `BlpCompressionBgra`. Code that builds `BlpInfo` positionally or matches+  `BlpCompression` exhaustively needs updating.+- BLP1 decoding is unchanged, and files whose magic is neither `BLP1` nor+  `BLP2` are still rejected with the BLP1 parser's error.+- The option, result and error types of `Codec.Picture.Blp` are now defined+  outside the internal modules, so changes to the internal file structure+  cannot change them. `Codec.Picture.Blp.Internal.Data` still re-exports+  the ones it exported before.+- The benchmarks accept `tasty-bench` 0.5. 0.5.0.0 has the same bound in a+  Hackage revision.+- Internal modules:+  - New `Codec.Picture.Blp.Internal.Dxt`, a DXT1, DXT3 and DXT5 block+    decoder (`decodeDxt`, `dxtLevelBytes`).+  - New `Codec.Picture.Blp.Internal.Decoder`, which turns a parsed file+    into images: `decodeBlpFile`, `decodeBlpStruct`, `decodeBlp2Struct`+    and the matching `...Info` functions.+  - `Internal.Data`: `Blp2Struct`, `Blp2Content`, `BlpFile`, and+    `mipChainLength` (moved from `Internal.Parser`, which still re-exports+    it) next to the new `mipLevelsDownTo`.+  - `Internal.Parser`: `parseBlp2`, `parseBlpFile` and `readPalette`.+ 0.5.0.0 (2026-10-16) ==================== @@ -188,36 +229,29 @@ `hashable`, `text-show`, `vector` and `filepath`. Minimum supported GHC is now 9.4.  0.2.1.0-=======  Relax upper boundary for `text-show-3.9`.  0.2.0.0-=======  Implement #1. Tool now preserves subfolder structure.  0.1.3.0-=======  Fix #2 index error.   0.1.2.0-=======  Relax upper boundary for `hashable` and `text-show`.  0.1.1.0-=======  Relax upper boundary for `JuicyPixels-3.3`.  0.1.0.1-=======  Relax upper boundary for `binary-0.9.0.0`.  0.1.0.0-=======  Initial release.

@@ -1,13 +1,15 @@ cabal-version:       2.2 name:                JuicyPixels-blp-version:             0.5.0.0+version:             0.6.0.0 synopsis:            BLP format decoder/encoder over JuicyPixels library description:-  Read and write BLP1, the texture format of Warcraft III, with images as+  Read and write BLP1, the texture format of Warcraft III, and read BLP2,+  its World of Warcraft variant, 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.+  Supports JPEG, paletted, DXT1/3/5 and BGRA 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.@@ -42,8 +44,12 @@     Codec.Picture.Blp     Codec.Picture.Blp.Internal.Convert     Codec.Picture.Blp.Internal.Data+    Codec.Picture.Blp.Internal.Decoder+    Codec.Picture.Blp.Internal.Dxt     Codec.Picture.Blp.Internal.Encoder     Codec.Picture.Blp.Internal.Parser+  other-modules:+    Codec.Picture.Blp.Types    default-language:    Haskell2010   build-depends:@@ -102,7 +108,7 @@     , deepseq     , JuicyPixels     , JuicyPixels-blp-    , tasty-bench           >= 0.3    && < 0.5+    , tasty-bench           >= 0.3    && < 0.6  test-suite spec   import:              warnings@@ -112,7 +118,9 @@   -- No test needs more; a decoder that allocates without bound fails loudly.   ghc-options:         -rtsopts -with-rtsopts=-M1g   other-modules:+    Blp2     Deprecated+    Dxt     Fixture     Properties   default-language:    Haskell2010

@@ -4,7 +4,8 @@ [![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) -Read and write BLP1, the texture format of Warcraft III, with images as+Read and write BLP1, the texture format of Warcraft III, and read BLP2, its+World of Warcraft variant, 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.@@ -30,7 +31,7 @@   either print return result ``` -- `readBlp` / `decodeBlp` return the full size image.+- `readBlp` / `decodeBlp` return the full size image of a BLP1 or BLP2 file. - `readBlpMipmaps` / `decodeBlpMipmaps` return the image followed by its   mipmaps. - `encodeBlpWith` / `writeBlpWith` encode with `BlpEncodeOptions`:@@ -54,14 +55,17 @@   `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.+The `Codec.Picture.Blp.Internal.*` modules expose the parser, decoder,+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.+- **Decoding BLP2** (World of Warcraft): DXT1, DXT3, DXT5, BGRA and+  paletted content, including mipmaps. `blpInfo` tells the versions and+  content types apart. - **Damaged and non-standard files** that are common in community maps and   ports of World of Warcraft assets:   - odd header values;@@ -83,9 +87,9 @@  ## 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)).+- **BLP0, writing BLP2, and BLP2 with JPEG content.** BLP0 keeps mipmaps in+  separate `.b00`–`.b15` files. BLP2 is read only, and its JPEG variant,+  which no known file uses, is rejected. - **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.@@ -131,9 +135,10 @@       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+- **`stats`** groups the BLP1 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.+  read, BLP2 files included, are reported and skipped. It helps when+  hunting for unusual files.  ``` blp2any convert war3/ textures-png/ -f png

@@ -11,6 +11,7 @@ import Codec.Picture import Codec.Picture.Blp import Codec.Picture.Blp.Internal.Convert (jpegAlphaIsUsable)+import Codec.Picture.Blp.Internal.Dxt (DxtFormat(..), decodeDxt, dxtLevelBytes) import Codec.Picture.Blp.Internal.Encoder (createMipMaps) import Codec.Picture.Jpg (encodeDirectJpegAtQualityWithMetadata) import Control.DeepSeq@@ -47,6 +48,10 @@         bench "jpegAlphaIsUsable/2048 varying" $ nf jpegAlphaIsUsable img     , env (return . force $ cmykLevel (convertRGBA8 (opaque 2048))) $ \img ->         bench "jpegAlphaIsUsable/2048 opaque" $ nf jpegAlphaIsUsable img+    , env (return . force $ dxtBlocks (Dxt1 True) 2048) $ \blocks ->+        bench "decodeDxt/2048 dxt1" $ nf (fmap imageData . decodeDxt (Dxt1 True) 2048 2048) blocks+    , env (return . force $ dxtBlocks Dxt5 2048) $ \blocks ->+        bench "decodeDxt/2048 dxt5" $ nf (fmap imageData . decodeDxt Dxt5 2048 2048) blocks     ]   ] @@ -109,3 +114,8 @@ 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)++-- | Pseudo-random blocks for an n x n DXT image: every colour and alpha+-- mode occurs.+dxtBlocks :: DxtFormat -> Int -> ByteString+dxtBlocks fmt n = BS.pack [fromIntegral ((i * 2654435761) `shiftR` 13) | i <- [0 .. dxtLevelBytes fmt n n - 1]]

@@ -55,4 +55,4 @@   where     ver = showVersion Paths.version     headerDesc = ""-    desc = "Converting BLP1 Warcraft III textures to/from PNG, JPEG, TIFF, GIF and BMP"+    desc = "Converting BLP textures to and from PNG, JPEG, TIFF, GIF and BMP. Reads BLP1 (Warcraft III) and BLP2 (World of Warcraft), writes BLP1"

@@ -1,9 +1,11 @@-# The BLP1 format+# The BLP 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.+World of Warcraft (BLP2). This library reads and writes **BLP1** and reads+**BLP2**. 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. The sections up to [BLP2](#blp2-world-of-warcraft) are about+BLP1.  Primary sources: @@ -37,8 +39,9 @@  What the library does with these fields: -- **Magic.** Only `BLP1` is accepted. BLP0 and BLP2 are rejected (see-  [Not supported](#not-supported)).+- **Magic.** `BLP2` files are read as described in+  [BLP2](#blp2-world-of-warcraft); anything else that is not `BLP1`, such+  as BLP0, is 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@@ -159,6 +162,79 @@   black when building the palette, so colours hidden under them take no   entries; they are invisible in the decoded texture either way. +## BLP2 (World of Warcraft)++The library reads BLP2 files; it does not write them. The sections above+apply where noted.++### Header++The header is 148 bytes (`0x94`) long, followed by a 256 entry palette+(1024 bytes) whether the content uses it or not.++| Offset | Type | Name | Library field | Meaning |+|---|---|---|---|---|+| `0x00` | `char[4]` | magic | – | `"BLP2"` |+| `0x04` | `uint32` | type | – | `0` = JPEG, `1` = everything else |+| `0x08` | `uint8` | encoding | `blp2Content` | `1` = paletted, `2` = DXT, `3` = BGRA |+| `0x09` | `uint8` | alphaDepth | `blp2AlphaDepth` | Alpha bits per pixel: 0, 1, 4 or 8 |+| `0x0A` | `uint8` | alphaType | `blp2AlphaType` | DXT format: `0` = DXT1, `1` = DXT3, `7` = DXT5; 8 on other content |+| `0x0B` | `uint8` | hasMips | `blp2HasMips` | `0` = only mip 0 |+| `0x0C` | `uint32` | width | `blp2Width` | Width of mip 0 in pixels |+| `0x10` | `uint32` | height | `blp2Height` | Height of mip 0 in pixels |+| `0x14` | `uint32[16]` | mipmapOffset | – | File offset of each mip level |+| `0x54` | `uint32[16]` | mipmapSize | – | Size in bytes of each mip level |+| `0x94` | `uint32[256]` | palette | – | B, G, R and padding, as in BLP1 |++What the library does with these fields:++- **type.** Only 1 is read. Type 0 holds JPEG content, which no known file+  uses; it is rejected.+- **encoding** and **alphaType.** Decide the content, below. Other values+  are rejected.+- **alphaDepth.** 0 makes every level opaque, whatever the content holds;+  this is what Pillow does. For DXT1 it also decides what index 3 of a+  three-colour block means: transparent with 1, opaque black with 0.+- **hasMips** is ignored, and the mipmap slots are read as in+  [Mipmaps](#mipmaps), with the same checks. Levels may start right after+  the header; the palette is only read for paletted content, and is cut+  short where mip 0 starts, as in BLP1.++### Paletted content (`encoding = 1`)++Laid out and decoded as [paletted BLP1](#paletted-content-content--1), with+alphaDepth in place of alphaBits.++### DXT content (`encoding = 2`)++Each level is cut into 4×4 blocks, stored row by row; levels whose sides are+not a multiple of 4 are padded to whole blocks, and the padding is dropped+when decoding. A DXT1 block is 8 bytes of colour; DXT3 and DXT5 blocks put 8+bytes of alpha first.++- **Colour.** Two RGB565 endpoints and a 2-bit index per pixel. Endpoints+  expand to 8 bits by bit replication (31 becomes 255). If the first+  endpoint is larger, or the block is DXT3 or DXT5, indices 2 and 3 are+  `(2·c0 + c1) / 3` and `(c0 + 2·c1) / 3`; otherwise index 2 is+  `(c0 + c1) / 2` and index 3 is black.+- **DXT3 alpha.** 4 bits per pixel, times 17.+- **DXT5 alpha.** Two 8-bit endpoints and a 3-bit index per pixel: six+  interpolated values between them if the first is larger, otherwise four,+  plus 0 and 255.++Divisions round down, as in Pillow. Graphics hardware is not consistent+about this, so other decoders can differ by one. Pillow's BLP plugin skips+the bit replication, so its output is up to 7 lower per channel.++### BGRA content (`encoding = 3`)++Four bytes per pixel: blue, green, red and alpha.++### Damaged levels++As in BLP1, a level 0 too short for its size fails the file, and the list of+levels stops at the first damaged mipmap.+ ## Deviations found in real files  The decoder accepts these, besides the ones mentioned above:@@ -173,8 +249,7 @@ ## 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 BLP2**, and BLP2 files with JPEG content (`type = 0`). - **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`.

@@ -1,10 +1,12 @@ {-|-Decoding and encoding of BLP1, the texture format of Warcraft III, on top of-JuicyPixels.+Decoding and encoding of BLP, the texture format of Warcraft III (BLP1) and+World of Warcraft (BLP2), on top of JuicyPixels. BLP1 is read and written,+BLP2 is read.  BLP1 comes in two flavours: JPEG compressed and uncompressed with a 256 colour palette. Uncompressed textures either carry an alpha plane or not.-A file holds the full size image followed by its mipmaps, each half the size+BLP2 adds DXT1, DXT3 and DXT5 block compression and plain BGRA pixels. A+file holds the full size image followed by its mipmaps, each half the size of the previous one.  Decoding always yields 'ImageRGBA8'. Files from the wild are often slightly@@ -33,6 +35,7 @@   -- * Inspecting   , blpInfo   , BlpInfo(..)+  , BlpVersion(..)   , BlpCompression(..)   -- * Encoding   , encodeBlpWith@@ -54,21 +57,16 @@   ) where  import Codec.Picture-import Control.DeepSeq (force)-import Control.Exception-import Control.Monad (when)-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-import qualified Data.Vector as V -import Codec.Picture.Blp.Internal.Convert import Codec.Picture.Blp.Internal.Data+import Codec.Picture.Blp.Internal.Decoder import Codec.Picture.Blp.Internal.Encoder import Codec.Picture.Blp.Internal.Parser+import Codec.Picture.Blp.Types  -- | Read a BLP file and decode its full size image. IO errors, such as a -- missing file, are thrown; malformed contents give 'Left'.@@ -98,157 +96,19 @@ decodeBlpMipmaps :: ByteString -> Either String [DynamicImage] decodeBlpMipmaps = decodeBlpMipmapsWith defaultBlpDecodeOptions --- | Options for decoding.-newtype BlpDecodeOptions = BlpDecodeOptions {-  -- | Largest full size image to decode, in pixels. Larger files are-  -- rejected before anything is allocated; decoding takes about four bytes-  -- per pixel.-  blpMaxPixels :: Int-} deriving (Eq, Show)---- | Up to 8192x8192 pixels, about 256 MiB for the full size image.-defaultBlpDecodeOptions :: BlpDecodeOptions-defaultBlpDecodeOptions = BlpDecodeOptions { blpMaxPixels = 8192 * 8192 }- -- | Decode the full size image followed by its mipmaps, all 'ImageRGBA8'. -- -- Element @i@ is always mip level @i@. Mipmaps are decoded lazily, and the -- list stops at the first one that is damaged, so a broken mipmap never -- costs the levels before it. A damaged full size image fails the file. decodeBlpMipmapsWith :: BlpDecodeOptions -> ByteString -> Either String [DynamicImage]-decodeBlpMipmapsWith opts bs = do-  blp <- parseBlp bs-  let width = fromIntegral $ blpWidth blp-      height = fromIntegral $ blpHeight blp-  when (width * height > blpMaxPixels opts) . Left $-    "Image size " ++ show width ++ "x" ++ show height ++ " is above the limit of "-    ++ show (blpMaxPixels opts) ++ " pixels"-  case blpExt blp of-    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-      -- 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--    BlpPaletted {..} -> palettedLevels width height alphaBits blpPalette blpPalettedMipMaps-      where-      -- 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---- | 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)---- | What a BLP file holds, read from its header without decoding any pixels.-data BlpInfo = BlpInfo {-    blpInfoCompression :: !BlpCompression -- ^ JPEG or paletted content-  , blpInfoWidth :: !Int -- ^ Width of the full size image-  , blpInfoHeight :: !Int -- ^ Height of the full size image-  , blpInfoAlphaBits :: !Int -- ^ The @alphaBits@ header field, as stored-  , blpInfoMipLevels :: !Int -- ^ Mip levels with usable slots, the full size image included-  } deriving (Eq, Show)+decodeBlpMipmapsWith opts bs = parseBlpFile bs >>= decodeBlpFile opts  -- | Read the header of a BLP file. This checks what 'decodeBlp' checks before -- decoding (format, size, mipmap slots) but decodes no pixels, so it is cheap -- on any input. Use it to reject textures that are too large. blpInfo :: ByteString -> Either String BlpInfo-blpInfo bs = do-  blp <- parseBlp bs-  return BlpInfo {-      blpInfoCompression = blpCompression blp-    , blpInfoWidth = fromIntegral $ blpWidth blp-    , blpInfoHeight = fromIntegral $ blpHeight blp-    , blpInfoAlphaBits = fromIntegral $ blpAlphaBits blp-    , blpInfoMipLevels = case blpExt blp of-        BlpJpeg {..} -> length blpJpegData-        BlpPaletted {..} -> length blpPalettedMipMaps-    }---- | 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)-      | 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, h) = levelSize width height l-    go _ _ = []--    -- 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+blpInfo bs = blpFileInfo <$> parseBlpFile bs  -- | 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'.@@ -257,19 +117,7 @@ mipMapsUpTo :: Int -- ^ Smallest side length to keep (2, 4, 16, ...)   -> DynamicImage -- ^ Image the mipmaps are made for   -> Int-mipMapsUpTo minSize img = max 1 . min 16 . length . takeWhile (>= max 1 minSize) $ iterate (`div` 2) larger-  where-    larger = max (dynamicMap imageWidth img) (dynamicMap imageHeight img)---- | 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-  }+mipMapsUpTo minSize img = max 1 $ mipLevelsDownTo minSize (dynamicMap imageWidth img) (dynamicMap imageHeight img)  -- | Encode an image as a BLP1 file. encodeBlpWith :: BlpEncodeOptions -> DynamicImage -> Either BlpEncodeError BSL.ByteString

@@ -1,14 +1,24 @@ {-|-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.+The structure of BLP1 and BLP2 files as the parser reads them, and of BLP1+files as the encoder writes them. See @docs/format.md@ in the source+repository for the full format. +'BlpCompression', 'BlpFormat', t'BlpEncodeOptions' and 'BlpEncodeError' are+re-exported from "Codec.Picture.Blp", where they belong to the stable API.+ This is an internal module: its API may change between minor versions. -} module Codec.Picture.Blp.Internal.Data(     BlpStruct(..)   , blpCompression+  , mipChainLength+  , mipLevelsDownTo   , BlpCompression(..)   , BlpExt(..)+  , Blp2Struct(..)+  , blp2Compression+  , Blp2Content(..)+  , BlpFile(..)   , BlpFormat(..)   , BlpEncodeOptions(..)   , BlpEncodeError(..)@@ -20,6 +30,9 @@ import Data.Word import GHC.Generics +import Codec.Picture.Blp.Internal.Dxt (DxtFormat(..))+import Codec.Picture.Blp.Types+ -- | 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'.@@ -56,49 +69,66 @@     }   deriving (Show, Generic) --- | Header dword @0x04@.-data BlpCompression =-    BlpCompressionJPEG -- ^ 0: JPEG-  | BlpCompressionUncompressed -- ^ 1: 256 colour palette-  deriving (Eq, Ord, Enum, Bounded, Show, Generic)+-- | A parsed BLP2 file, the World of Warcraft variant: the 148 byte header,+-- the palette and the raw mip levels.+data Blp2Struct = Blp2Struct {+  -- | Header byte @0x09@: alpha bits per pixel. 0 means the image is+  -- opaque, whatever the content holds.+  blp2AlphaDepth :: !Word8+  -- | Header byte @0x0A@: which DXT format, for DXT content (0, 1 or 7);+  -- kept as read.+, blp2AlphaType :: !Word8+  -- | Header byte @0x0B@: zero means only mip 0 is present. Kept as read;+  -- the slots decide which levels are read, as in BLP1.+, blp2HasMips :: !Word8+  -- | Width of mip 0 in pixels.+, blp2Width :: !Word32+  -- | Height of mip 0 in pixels.+, blp2Height :: !Word32+  -- | How the levels are stored, from header bytes @0x08@ and @0x0A@.+, blp2Content :: !Blp2Content+  -- | Raw data of each mip level, mip 0 first.+, blp2MipMaps :: ![ByteString]+} deriving (Show, Generic) +-- | The content of a BLP2 file.+data Blp2Content =+    -- | Encoding 1: palette indices then alpha, as in paletted BLP1. 256+    -- entries stored as B, G, R and padding.+    Blp2Paletted !(Vector PixelRGBA8)+    -- | Encoding 2: DXT blocks.+  | Blp2Dxt !DxtFormat+    -- | Encoding 3: four bytes per pixel, B, G, R and A.+  | Blp2Bgra+  deriving (Show, Generic)++-- | How a BLP2 file stores its pixels.+blp2Compression :: Blp2Struct -> BlpCompression+blp2Compression blp = case blp2Content blp of+  Blp2Paletted _ -> BlpCompressionUncompressed+  Blp2Dxt (Dxt1 _) -> BlpCompressionDxt1+  Blp2Dxt Dxt3 -> BlpCompressionDxt3+  Blp2Dxt Dxt5 -> BlpCompressionDxt5+  Blp2Bgra -> BlpCompressionBgra++-- | A parsed BLP1 or BLP2 file.+data BlpFile = BlpFile1 !BlpStruct | BlpFile2 !Blp2Struct+  deriving (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 --- | 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-  -- | 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)+-- | Number of levels in a full mip chain: halving the larger side down to 1,+-- at most 16.+mipChainLength :: Int -> Int -> Int+mipChainLength = mipLevelsDownTo 1 --- | 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.-  | BlpInvalidMaxSize !Int -- ^ A 'blpMaxSize' below 1.-  deriving (Eq, Show)+-- | Number of mip levels of a @w@ x @h@ texture, mip 0 included, whose+-- larger side is at least the given length (taken as 1 when smaller), at+-- most 16. Zero when the texture itself is smaller.+mipLevelsDownTo :: Int -> Int -> Int -> Int+mipLevelsDownTo minSide w h = min 16 . length . takeWhile (>= max 1 minSide) $ iterate (`div` 2) (max w h)

@@ -0,0 +1,220 @@+{-|+Turning a parsed BLP1 or BLP2 file into images: the size limit, JPEG levels+with their shared header and alpha decision, paletted levels with packed+alpha, and BLP2's DXT and BGRA levels. "Codec.Picture.Blp" parses the file+and calls 'decodeBlpFile'.++This is an internal module: its API may change between minor versions.+-}+module Codec.Picture.Blp.Internal.Decoder(+    decodeBlpFile+  , blpFileInfo+  , decodeBlpStruct+  , decodeBlp2Struct+  , blpStructInfo+  , blp2StructInfo+  ) where++import Codec.Picture+import Control.DeepSeq (force)+import Control.Exception+import Control.Monad (when)+import Data.Bits ((.&.), shiftR)+import Data.ByteString (ByteString)+import Data.Either (isRight)+import System.IO.Unsafe (unsafeDupablePerformIO)++import qualified Data.ByteString as BS+import qualified Data.Vector as V++import Codec.Picture.Blp.Internal.Convert+import Codec.Picture.Blp.Internal.Data+import Codec.Picture.Blp.Internal.Dxt+import Codec.Picture.Blp.Internal.Parser+import Codec.Picture.Blp.Types++-- | Decode the full size image of a parsed file followed by its mipmaps, all+-- 'ImageRGBA8'. See 'Codec.Picture.Blp.decodeBlpMipmapsWith'.+decodeBlpStruct :: BlpDecodeOptions -> BlpStruct -> Either String [DynamicImage]+decodeBlpStruct opts blp = do+  let width = fromIntegral $ blpWidth blp+      height = fromIntegral $ blpHeight blp+  checkSize opts width height+  case blpExt blp of+    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+      -- 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++    BlpPaletted {..} -> palettedImages width height (fromIntegral (blpAlphaBits blp)) blpPalette blpPalettedMipMaps++-- | Decode the full size image of a parsed BLP2 file followed by its+-- mipmaps, all 'ImageRGBA8'. Levels are taken as in BLP1: a damaged level 0+-- fails the file, and the list stops at the first damaged mipmap. An alpha+-- depth of 0 makes every level opaque.+decodeBlp2Struct :: BlpDecodeOptions -> Blp2Struct -> Either String [DynamicImage]+decodeBlp2Struct opts blp = do+  checkSize opts width height+  case blp2Content blp of+    Blp2Paletted palette -> palettedImages width height (fromIntegral (blp2AlphaDepth blp)) palette (blp2MipMaps blp)+    Blp2Dxt fmt -> levels (\(lw, lh) -> decodeDxt fmt lw lh)+    Blp2Bgra -> levels bgraLevel+  where+    width = fromIntegral $ blp2Width blp+    height = fromIntegral $ blp2Height blp+    finish = if blp2AlphaDepth blp == 0 then setOpaque else id+    levels decode = case blp2MipMaps blp of+      [] -> Left "No mipmap data in BLP2"+      mips -> case [decode (levelSize width height l) mip | (l, mip) <- zip [0 ..] mips] of+        Left e : _ -> Left $ "Mipmap 0: " ++ e+        decoded -> Right [ImageRGBA8 (finish img) | Right img <- takeWhile isRight decoded]++-- | A level of four bytes per pixel, B, G, R and A.+bgraLevel :: (Int, Int) -> ByteString -> Either String (Image PixelRGBA8)+bgraLevel (w, h) bytes+  | BS.length bytes < 4 * w * h = Left $ "BGRA data is " ++ show (BS.length bytes)+      ++ " bytes, a " ++ show w ++ "x" ++ show h ++ " level needs " ++ show (4 * w * h)+  | otherwise = Right $ generateImage pixel w h+  where+    pixel x y = let p = 4 * (y * w + x); b k = BS.index bytes (p + k)+                in PixelRGBA8 (b 2) (b 1) (b 0) (b 3)++setOpaque :: Image PixelRGBA8 -> Image PixelRGBA8+setOpaque = pixelMap (\(PixelRGBA8 r g b _) -> PixelRGBA8 r g b 255)++-- | Reject an image above the size limit before anything is allocated.+checkSize :: BlpDecodeOptions -> Int -> Int -> Either String ()+checkSize opts width height = when (width * height > blpMaxPixels opts) . Left $+  "Image size " ++ show width ++ "x" ++ show height ++ " is above the limit of "+  ++ show (blpMaxPixels opts) ++ " pixels"++-- | Paletted levels with the declared alpha depth, if it is 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.+palettedImages :: Int -> Int -> Int -> V.Vector PixelRGBA8 -> [ByteString] -> Either String [DynamicImage]+palettedImages width height declaredBits palette mips = palettedLevels width height alphaBits palette mips+  where+    declared = if declaredBits `elem` [1, 4, 8] then declaredBits else 0+    alphaBits = case mips of+      mip0 : _ | BS.length mip0 < levelBytes (width * height) declared -> 0+      _ -> declared++-- | Decode a parsed BLP1 or BLP2 file.+decodeBlpFile :: BlpDecodeOptions -> BlpFile -> Either String [DynamicImage]+decodeBlpFile opts (BlpFile1 blp) = decodeBlpStruct opts blp+decodeBlpFile opts (BlpFile2 blp) = decodeBlp2Struct opts blp++-- | What 'Codec.Picture.Blp.blpInfo' reports for a parsed BLP1 or BLP2 file.+blpFileInfo :: BlpFile -> BlpInfo+blpFileInfo (BlpFile1 blp) = blpStructInfo blp+blpFileInfo (BlpFile2 blp) = blp2StructInfo blp++-- | 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)+++-- | What 'Codec.Picture.Blp.blpInfo' reports for a parsed file.+blpStructInfo :: BlpStruct -> BlpInfo+blpStructInfo blp = BlpInfo {+    blpInfoVersion = Blp1+  , blpInfoCompression = blpCompression blp+  , blpInfoWidth = fromIntegral $ blpWidth blp+  , blpInfoHeight = fromIntegral $ blpHeight blp+  , blpInfoAlphaBits = fromIntegral $ blpAlphaBits blp+  , blpInfoMipLevels = case blpExt blp of+      BlpJpeg {..} -> length blpJpegData+      BlpPaletted {..} -> length blpPalettedMipMaps+  }++-- | 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)+      | 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, h) = levelSize width height l+    go _ _ = []++    -- 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+++-- | What 'Codec.Picture.Blp.blpInfo' reports for a parsed BLP2 file.+blp2StructInfo :: Blp2Struct -> BlpInfo+blp2StructInfo blp = BlpInfo {+    blpInfoVersion = Blp2+  , blpInfoCompression = blp2Compression blp+  , blpInfoWidth = fromIntegral $ blp2Width blp+  , blpInfoHeight = fromIntegral $ blp2Height blp+  , blpInfoAlphaBits = fromIntegral $ blp2AlphaDepth blp+  , blpInfoMipLevels = length (blp2MipMaps blp)+  }

@@ -0,0 +1,182 @@+{-|+Decoding of S3TC (DXT1, DXT3 and DXT5) block compressed images, the+compressed content of BLP2 textures.++The image is cut into 4x4 blocks, stored row by row. A DXT1 block is 8 bytes+of colour; DXT3 and DXT5 blocks put 8 bytes of alpha before the colour. A+colour block holds two RGB565 endpoints and a 2-bit index per pixel, pixel+@(x, y)@ of the block at bits @2 * (4 * y + x)@:++* endpoints expand to 8 bits by bit replication, so 31 becomes 255;+* if the first endpoint is larger, or the block is part of DXT3 or DXT5,+  indices 2 and 3 are @(2 * c0 + c1) / 3@ and @(c0 + 2 * c1) / 3@;+* otherwise index 2 is @(c0 + c1) / 2@ and index 3 is black, transparent in+  DXT1 with alpha.++DXT3 alpha is a 4-bit value per pixel, times 17. DXT5 alpha has two 8-bit+endpoints and a 3-bit index per pixel: six interpolated values between them+if the first is larger, otherwise four plus 0 and 255.++Divisions round down, as in Pillow. Graphics hardware is not consistent+about this, so other decoders can differ by one.++This is an internal module: its API may change between minor versions.+-}+module Codec.Picture.Blp.Internal.Dxt(+    DxtFormat(..)+  , dxtLevelBytes+  , decodeDxt+  ) where++import Codec.Picture+import Control.Monad (when)+import Control.Monad.ST (ST)+import Data.Bits+import Data.ByteString (ByteString)+import Data.Word++import qualified Data.ByteString as BS+import qualified Data.ByteString.Unsafe as BSU+import qualified Data.Vector.Storable as VS+import qualified Data.Vector.Storable.Mutable as MVS++-- | Block compression formats.+data DxtFormat =+    -- | 8-byte blocks of colour only. With 'True', index 3 of a three-colour+    -- block is transparent; with 'False', it is opaque black.+    Dxt1 !Bool+    -- | 16-byte blocks: explicit 4-bit alpha, then a DXT1 colour block.+  | Dxt3+    -- | 16-byte blocks: interpolated alpha, then a DXT1 colour block.+  | Dxt5+  deriving (Eq, Show)++-- | Bytes of one block.+blockBytes :: DxtFormat -> Int+blockBytes (Dxt1 _) = 8+blockBytes _ = 16++-- | Bytes a @w@ x @h@ image takes: every side is rounded up to whole blocks.+dxtLevelBytes :: DxtFormat -> Int -> Int -> Int+dxtLevelBytes fmt w h = ((w + 3) `div` 4) * ((h + 3) `div` 4) * blockBytes fmt++-- | Decode a @w@ x @h@ image. Bytes after 'dxtLevelBytes' are ignored; fewer+-- bytes, or a side below 1, give 'Left'.+decodeDxt :: DxtFormat -> Int -> Int -> ByteString -> Either String (Image PixelRGBA8)+decodeDxt fmt w h bs+  | w < 1 || h < 1 = Left $ "Invalid DXT image size " ++ show w ++ "x" ++ show h+  | BS.length bs < needed = Left $ "DXT data is " ++ show (BS.length bs)+      ++ " bytes, a " ++ show w ++ "x" ++ show h ++ " image needs " ++ show needed+  | otherwise = Right . Image w h $ VS.create $ do+      -- Every pixel belongs to a block, so every byte is written.+      dst <- MVS.unsafeNew (w * h * 4)+      -- The four colours of the current block as RGBA, then its eight DXT5+      -- alpha values. Pixels are copied from here by index: choosing with+      -- branches is several times slower, as indices are unpredictable.+      table <- MVS.unsafeNew 24+      let rows by = if by >= blocksHigh then return () else cols by 0 >> rows (by + 1)+          cols by bx = if bx >= blocksWide then return () else do+            decodeBlock fmt bs ((by * blocksWide + bx) * blockBytes fmt) w h (bx * 4) (by * 4) table dst+            cols by (bx + 1)+      rows 0+      return dst+  where+    needed = dxtLevelBytes fmt w h+    blocksWide = (w + 3) `div` 4+    blocksHigh = (h + 3) `div` 4++-- | Decode the block at byte offset @o@ into the pixels from @(x0, y0)@ that+-- fall inside the image, using @table@ as scratch space.+decodeBlock :: DxtFormat -> ByteString -> Int -> Int -> Int -> Int -> Int+  -> MVS.MVector s Word8 -> MVS.MVector s Word8 -> ST s ()+decodeBlock fmt bs o w h x0 y0 table dst = do+  colour 0 r0 g0 b0 255+  colour 1 r1 g1 b1 255+  colour 2 (mix r0 r1) (mix g0 g1) (mix b0 b1) 255+  colour 3 (last3 r0 r1) (last3 g0 g1) (last3 b0 b1) alpha3+  case fmt of+    Dxt5 -> mapM_ (\j -> MVS.unsafeWrite table (16 + j) (fromIntegral (dxt5Alpha j))) [0 .. 7]+    _ -> return ()+  pixels 0+  where+    byte i = fromIntegral (BSU.unsafeIndex bs i) :: Int+    -- Little-endian word of n bytes from offset i.+    word :: Int -> Int -> Word64+    word i n = loop (n - 1) 0+      where+        loop j !acc+          | j < 0 = acc+          | otherwise = loop (j - 1) (acc `shiftL` 8 .|. fromIntegral (byte (i + j)))++    !colourAt = case fmt of+      Dxt1 _ -> o+      _ -> o + 8+    !c0 = byte colourAt .|. byte (colourAt + 1) `shiftL` 8+    !c1 = byte (colourAt + 2) .|. byte (colourAt + 3) `shiftL` 8+    !indices = word (colourAt + 4) 4+    !fourColours = case fmt of+      Dxt1 _ -> c0 > c1+      _ -> True+    !r0 = expand5 (c0 `shiftR` 11)+    !g0 = expand6 (c0 `shiftR` 5)+    !b0 = expand5 c0+    !r1 = expand5 (c1 `shiftR` 11)+    !g1 = expand6 (c1 `shiftR` 5)+    !b1 = expand5 c1+    mix a b = if fourColours then (2 * a + b) `quot` 3 else (a + b) `quot` 2+    last3 a b = if fourColours then (a + 2 * b) `quot` 3 else 0+    !alpha3 = case fmt of+      Dxt1 True | not fourColours -> 0+      _ -> 255 :: Int++    colour k r g b a = do+      MVS.unsafeWrite table (4 * k) (fromIntegral r)+      MVS.unsafeWrite table (4 * k + 1) (fromIntegral g)+      MVS.unsafeWrite table (4 * k + 2) (fromIntegral b)+      MVS.unsafeWrite table (4 * k + 3) (fromIntegral (a `asTypeOf` r))++    -- DXT3: 4-bit alpha per pixel. DXT5: two endpoints and 3-bit indices.+    !alphaWord = case fmt of+      Dxt1 _ -> 0+      Dxt3 -> word o 8+      Dxt5 -> word (o + 2) 6+    !a0 = byte o+    !a1 = byte (o + 1)+    dxt5Alpha :: Int -> Int+    dxt5Alpha j = case j of+      0 -> a0+      1 -> a1+      _ | a0 > a1 -> ((8 - j) * a0 + (j - 1) * a1) `quot` 7+        | j < 6 -> ((6 - j) * a0 + (j - 1) * a1) `quot` 5+        | j == 6 -> 0+        | otherwise -> 255++    -- Copying a pixel as one 32-bit word keeps its bytes in order on any+    -- platform.+    table32 = asWord32 table+    dst32 = asWord32 dst++    pixels !i+      | i >= 16 = return ()+      | otherwise = do+          let x = x0 + i .&. 3+              y = y0 + i `shiftR` 2+              k = fromIntegral (indices `unsafeShiftR` (2 * i)) .&. 3+              p = y * w + x+          when (x < w && y < h) $ do+            MVS.unsafeRead table32 k >>= MVS.unsafeWrite dst32 p+            case fmt of+              Dxt1 _ -> return ()+              Dxt3 -> MVS.unsafeWrite dst (4 * p + 3) (17 * (fromIntegral (alphaWord `unsafeShiftR` (4 * i)) .&. 15))+              Dxt5 -> MVS.unsafeRead table (16 + fromIntegral (alphaWord `unsafeShiftR` (3 * i)) .&. 7)+                >>= MVS.unsafeWrite dst (4 * p + 3)+          pixels (i + 1)++-- | Widen a 5 or 6-bit channel, taken from the low bits, to 8 bits by+-- repeating its high bits.+expand5, expand6 :: Int -> Int+expand5 v = let c = v .&. 31 in c `shiftL` 3 .|. c `shiftR` 2+expand6 v = let c = v .&. 63 in c `shiftL` 2 .|. c `shiftR` 4++asWord32 :: MVS.MVector s Word8 -> MVS.MVector s Word32+asWord32 = MVS.unsafeCast

@@ -107,8 +107,7 @@     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 blpMipLevels+    numLevels = max 1 $ min (mipChainLength width height) blpMipLevels  -- | Whether any pixel is less than fully opaque. anyTransparent :: Image PixelRGBA8 -> Bool

@@ -1,12 +1,16 @@ {-|-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".+Parser for BLP1 and BLP2 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.Internal.Decoder".  This is an internal module: its API may change between minor versions. -} module Codec.Picture.Blp.Internal.Parser(     parseBlp+  , parseBlp2+  , parseBlpFile+  , readPalette   , blpVersion   , dword   , compressionParser@@ -27,6 +31,7 @@ import qualified Data.ByteString as BS  import Codec.Picture.Blp.Internal.Data+import Codec.Picture.Blp.Internal.Dxt (DxtFormat(..))  -- | Size of the fixed BLP1 header in bytes. headerSize :: Int@@ -49,7 +54,6 @@     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@@ -57,27 +61,97 @@       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+            blpJpegHeader = slice input (headerSize + 4, fromIntegral jpegHeaderSize)+          , blpJpegData = slice input <$> levelsFrom headerEnd           }-    BlpCompressionUncompressed -> do+    _ -> do+      -- compressionParser gives JPEG or paletted only.       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+          blpPalette = readPalette input headerSize levels+        , blpPalettedMipMaps = slice input <$> levels         } +-- | The 256 entry palette that starts at the given offset. 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.+readPalette :: ByteString -> Int -> [(Int, Int)] -> V.Vector PixelRGBA8+readPalette input start levels = V.generate 256 $ \i ->+  if i < entries then entry i else PixelRGBA8 0 0 0 0+  where+    paletteEnd = case levels of+      (offset, _) : _ -> min offset (start + 1024)+      [] -> start + 1024+    paletteBytes = slice input (start, paletteEnd - start)+    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)++-- | The bytes at an offset and size, cut short at the end of the input.+slice :: ByteString -> (Int, Int) -> ByteString+slice input (offset, size) = BS.take size (BS.drop offset input)++-- | Parse a BLP1 or BLP2 file, told apart by their magic. Anything that is+-- not BLP2 is parsed, and rejected, as BLP1.+parseBlpFile :: ByteString -> Either String BlpFile+parseBlpFile input+  | BS.take 4 input == "BLP2" = BlpFile2 <$> parseBlp2 input+  | otherwise = BlpFile1 <$> parseBlp input++-- | Size of the fixed BLP2 header, before the palette: tag, type, four+-- bytes, width, height, 16 offsets and 16 sizes.+blp2HeaderSize :: Int+blp2HeaderSize = 148++-- | Parse a BLP2 file into its header and raw content.+--+-- Only type 1 files are read; type 0 holds JPEG content, which no known+-- file uses. Width and height must be between 1 and 'maxSide', and mip+-- levels are taken slot by slot, as in BLP1 (see 'mipLevels'). Levels may+-- start right after the header: the palette that follows it is only read+-- for paletted content, and cut short where mip 0 starts.+parseBlp2 :: ByteString -> Either String Blp2Struct+parseBlp2 input = do+  (blpType, encoding, blp2AlphaDepth, blp2AlphaType, blp2HasMips, blp2Width, blp2Height, slots) <-+    parseOnly blp2HeaderParser input+  let w = fromIntegral blp2Width+      h = fromIntegral blp2Height+  case blpType of+    1 -> Right ()+    0 -> Left "BLP2 files with JPEG content are not supported"+    t -> Left $ "Unknown BLP2 type " ++ show t+  if w < 1 || h < 1 || w > maxSide || h > maxSide+    then Left $ "Invalid image size " ++ show blp2Width ++ "x" ++ show blp2Height+    else Right ()+  let levels = mipLevels (BS.length input) blp2HeaderSize (mipChainLength w h) slots+  blp2Content <- case encoding of+    1 -> Right . Blp2Paletted $ readPalette input blp2HeaderSize levels+    2 -> case blp2AlphaType of+      0 -> Right . Blp2Dxt $ Dxt1 (blp2AlphaDepth /= 0)+      1 -> Right $ Blp2Dxt Dxt3+      7 -> Right $ Blp2Dxt Dxt5+      t -> Left $ "Unknown BLP2 DXT format (alpha type " ++ show t ++ ")"+    3 -> Right Blp2Bgra+    e -> Left $ "Unknown BLP2 encoding " ++ show e+  return Blp2Struct { blp2MipMaps = slice input <$> levels, .. }++-- | The BLP2 header: type, encoding, alpha depth, alpha type, has mips,+-- width, height and the mipmap slots.+blp2HeaderParser :: Parser (Word32, Word8, Word8, Word8, Word8, Word32, Word32, [(Word32, Word32)])+blp2HeaderParser = do+  _ <- string "BLP2" <?> "BLP2 version tag"+  blpType <- dword <?> "type"+  encoding <- AT.anyWord8 <?> "encoding"+  alphaDepth <- AT.anyWord8 <?> "alpha depth"+  alphaType <- AT.anyWord8 <?> "alpha type"+  hasMips <- AT.anyWord8 <?> "has mips"+  width <- dword <?> "width"+  height <- dword <?> "height"+  offsets <- count 16 dword <?> "mipmaps offsets"+  sizes <- count 16 dword <?> "mipmaps sizes"+  return (blpType, encoding, alphaDepth, alphaType, hasMips, width, height, offsets `zip` sizes)+ -- | 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)])@@ -114,11 +188,6 @@     0 -> return BlpCompressionJPEG     1 -> return BlpCompressionUncompressed     _ -> fail $ "Unknown compression " ++ show i---- | 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)  -- | 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

@@ -0,0 +1,100 @@+{-|+The option, result and error types of the public API. They are re-exported+from "Codec.Picture.Blp", and the ones the internal modules use from+"Codec.Picture.Blp.Internal.Data" as well; this module is not exposed.+-}+module Codec.Picture.Blp.Types(+    BlpDecodeOptions(..)+  , defaultBlpDecodeOptions+  , BlpInfo(..)+  , BlpVersion(..)+  , BlpCompression(..)+  , BlpFormat(..)+  , BlpEncodeOptions(..)+  , defaultBlpEncodeOptions+  , BlpEncodeError(..)+  ) where++import GHC.Generics++-- | Options for decoding.+newtype BlpDecodeOptions = BlpDecodeOptions {+  -- | Largest full size image to decode, in pixels. Larger files are+  -- rejected before anything is allocated; decoding takes about four bytes+  -- per pixel.+  blpMaxPixels :: Int+} deriving (Eq, Show)++-- | Up to 8192x8192 pixels, about 256 MiB for the full size image.+defaultBlpDecodeOptions :: BlpDecodeOptions+defaultBlpDecodeOptions = BlpDecodeOptions { blpMaxPixels = 8192 * 8192 }++-- | What a BLP file holds, read from its header without decoding any pixels.+data BlpInfo = BlpInfo {+    blpInfoVersion :: !BlpVersion -- ^ BLP1 or BLP2+  , blpInfoCompression :: !BlpCompression -- ^ How the pixels are stored+  , blpInfoWidth :: !Int -- ^ Width of the full size image+  , blpInfoHeight :: !Int -- ^ Height of the full size image+  , blpInfoAlphaBits :: !Int -- ^ The alpha depth header field (@alphaBits@ in BLP1, @alphaDepth@ in BLP2), as stored+  , blpInfoMipLevels :: !Int -- ^ Mip levels with usable slots, the full size image included+  } deriving (Eq, Show)++-- | Version of a BLP file: BLP1 is used by Warcraft III, BLP2 by World of+-- Warcraft.+data BlpVersion = Blp1 | Blp2+  deriving (Eq, Ord, Enum, Bounded, Show, Generic)++-- | How the pixels of a BLP file are stored.+data BlpCompression =+    BlpCompressionJPEG -- ^ JPEG (BLP1 only)+  | BlpCompressionUncompressed -- ^ 256 colour palette+  | BlpCompressionDxt1 -- ^ DXT1 blocks (BLP2 only)+  | BlpCompressionDxt3 -- ^ DXT3 blocks (BLP2 only)+  | BlpCompressionDxt5 -- ^ DXT5 blocks (BLP2 only)+  | BlpCompressionBgra -- ^ 32-bit BGRA pixels (BLP2 only)+  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+  -- | 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)++-- | 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+  }++-- | 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.+  | BlpInvalidMaxSize !Int -- ^ A 'blpMaxSize' below 1.+  deriving (Eq, Show)

@@ -0,0 +1,147 @@+-- | BLP2 files, built byte by byte: every content type, alpha depths, and+-- damaged or unsupported files.+module Blp2(blp2Tests, blp2Seeds) where++import Codec.Picture+import Codec.Picture.Blp+import Data.ByteString (ByteString)+import Data.List (isInfixOf)+import Data.Word+import Test.Tasty+import Test.Tasty.HUnit++import qualified Data.ByteString as BS++import Fixture++blp2Tests :: TestTree+blp2Tests = testGroup "blp2"+  [ testCase "DXT1: every level, block by block" $ do+      levels <- decoded dxt1File+      map size levels @?= [(8, 8), (4, 4), (2, 2), (1, 1)]+      let corners = [pixelAt (level0 levels) x y | (x, y) <- [(0, 0), (7, 0), (0, 7), (7, 7)]]+      corners @?= [red, green, blue, white]+      [pixelAt l 0 0 | l <- drop 1 levels] @?= [white, green, blue]+  , testCase "blpInfo reads the BLP2 header" $ do+      blpInfo dxt1File @?= Right (BlpInfo Blp2 BlpCompressionDxt1 8 8 0 4)+      fmap blpInfoCompression (blpInfo dxt3File) @?= Right BlpCompressionDxt3+      fmap blpInfoCompression (blpInfo dxt5File) @?= Right BlpCompressionDxt5+      blpInfo (bgraFile 8) @?= Right (BlpInfo Blp2 BlpCompressionBgra 2 1 8 2)+      blpInfo (palettedFile 8) @?= Right (BlpInfo Blp2 BlpCompressionUncompressed 2 2 8 1)+  , testCase "DXT1 with alpha depth 1: index 3 of a three-colour block is transparent" $ do+      let file depth = blp2 defHeader2 { h2AlphaDepth = depth } blankPalette [colourBlock 0x001F 0xF800 [3]]+      levels <- decoded (file 1)+      [pixelAt (level0 levels) x 0 | x <- [0, 1]] @?= [PixelRGBA8 0 0 0 0, blue]+      opaque <- decoded (file 0)+      pixelAt (level0 opaque) 0 0 @?= PixelRGBA8 0 0 0 255+  , testCase "DXT3 and DXT5 keep their alpha" $ do+      dxt3 <- decoded dxt3File+      [a | y <- [0 .. 3], x <- [0 .. 3], let PixelRGBA8 _ _ _ a = pixelAt (level0 dxt3) x y] @?= [17 * n | n <- [0 .. 15]]+      dxt5 <- decoded dxt5File+      [pixelAt (level0 dxt5) x 0 | x <- [0, 1]] @?= [PixelRGBA8 255 0 0 0, red]+  , testCase "alpha depth 0 makes DXT5 and BGRA levels opaque" $ do+      dxt5 <- decoded $ setByte 9 0 dxt5File+      pixelAt (level0 dxt5) 0 0 @?= red+      bgra <- decoded (bgraFile 0)+      map (\l -> pixelAt l 0 0) bgra @?= [PixelRGBA8 30 20 10 255, PixelRGBA8 3 2 1 255]+  , testCase "BGRA is stored blue first" $ do+      levels <- decoded (bgraFile 8)+      map size levels @?= [(2, 1), (1, 1)]+      [pixelAt (level0 levels) x 0 | x <- [0, 1]] @?= [PixelRGBA8 30 20 10 40, PixelRGBA8 70 60 50 80]+      pixelAt (levels !! 1) 0 0 @?= PixelRGBA8 3 2 1 4+  , testCase "paletted content decodes as in BLP1" $ do+      levels <- decoded (palettedFile 8)+      [pixelAt (level0 levels) x y | (x, y) <- [(0, 0), (1, 0), (0, 1), (1, 1)]]+        @?= [PixelRGBA8 0 0 255 255, PixelRGBA8 255 0 0 128, PixelRGBA8 255 0 0 64, PixelRGBA8 0 0 255 0]+      noAlpha <- decoded (palettedFile 0)+      pixelAt (level0 noAlpha) 1 0 @?= red+      oneBit <- decoded (palettedFile 1)+      [pixelAt (level0 oneBit) x y | (x, y) <- [(0, 0), (1, 0), (0, 1), (1, 1)]]+        @?= [PixelRGBA8 0 0 255 0, red, red, PixelRGBA8 0 0 255 0]+  , testCase "a damaged mipmap ends the list, a damaged level 0 fails the file" $ do+      levels <- decoded $ blp2 dxt1Header blankPalette [dxt1Mip0, BS.take 4 (colourBlock 0xFFFF 0 []), dxt1Block 0x07E0, dxt1Block 0x001F]+      map size levels @?= [(8, 8)]+      assertLeft "Mipmap 0" . decodeBlp $ blp2 dxt1Header blankPalette [BS.take 31 dxt1Mip0]+      assertLeft "BGRA" . decodeBlp $ blp2 defHeader2 { h2Encoding = 3, h2Width = 2, h2Height = 1 } blankPalette [BS.pack [1 .. 7]]+  , testCase "unsupported and malformed headers are errors" $ do+      assertLeft "JPEG" . decodeBlp $ setDword 4 0 dxt1File+      assertLeft "type" . decodeBlp $ setDword 4 5 dxt1File+      assertLeft "encoding" . decodeBlp $ setByte 8 4 dxt1File+      assertLeft "alpha type" . decodeBlp $ setByte 10 3 dxt1File+      assertLeft "Invalid image size" . decodeBlp $ setDword 12 0 dxt1File+      assertLeft "No mipmap data" . decodeBlp $ blp2 dxt1Header blankPalette []+      assertLeft "not enough input" . decodeBlp $ BS.take 100 dxt1File+      assertLeft "JPEG" . blpInfo $ setDword 4 0 dxt1File+  , testCase "the size limit applies to BLP2" $+      assertLeft "limit" $ decodeBlpWith (BlpDecodeOptions 63) dxt1File+  ]++-- | Valid BLP2 files of every content type, for the fuzz properties.+blp2Seeds :: [ByteString]+blp2Seeds = [dxt1File, dxt3File, dxt5File, bgraFile 8, palettedFile 8]++decoded :: ByteString -> IO [Image PixelRGBA8]+decoded file = case decodeBlpMipmaps file of+  Left e -> assertFailure e+  Right levels -> return (map convertRGBA8 levels)++size :: Image a -> (Int, Int)+size img = (imageWidth img, imageHeight img)++assertLeft :: String -> Either String a -> Assertion+assertLeft needle r = case r of+  Left e -> assertBool ("error " ++ show e ++ " should mention " ++ show needle) (needle `isInfixOf` e)+  Right _ -> assertFailure "expected a decoding error"++setByte :: Int -> Word8 -> ByteString -> ByteString+setByte o v bs = BS.take o bs <> BS.singleton v <> BS.drop (o + 1) bs++red, green, blue, white :: PixelRGBA8+red = PixelRGBA8 255 0 0 255+green = PixelRGBA8 0 255 0 255+blue = PixelRGBA8 0 0 255 255+white = PixelRGBA8 255 255 255 255++-- | A DXT1 block of one colour.+dxt1Block :: Int -> ByteString+dxt1Block c = colourBlock c 0 []++dxt1Header :: Header2+dxt1Header = defHeader2 { h2Width = 8, h2Height = 8 }++-- | 8x8: red, green / blue, white.+dxt1Mip0 :: ByteString+dxt1Mip0 = BS.concat (map dxt1Block [0xF800, 0x07E0, 0x001F, 0xFFFF])++dxt1File :: ByteString+dxt1File = blp2 dxt1Header blankPalette [dxt1Mip0, dxt1Block 0xFFFF, dxt1Block 0x07E0, dxt1Block 0x001F]++-- | 4x4, alpha 17 * i at pixel i.+dxt3File :: ByteString+dxt3File = blp2 defHeader2 { h2AlphaDepth = 8, h2AlphaType = 1 } blankPalette [dxt3Alpha [0 .. 15] <> dxt1Block 0xF800]++-- | 4x4 red, transparent at pixel 0.+dxt5File :: ByteString+dxt5File = blp2 defHeader2 { h2AlphaDepth = 8, h2AlphaType = 7 } blankPalette [dxt5Alpha 255 0 [1] <> dxt1Block 0xF800]++-- | 2x1 and 1x1 levels with the given alpha depth.+bgraFile :: Word8 -> ByteString+bgraFile depth = blp2 defHeader2 { h2Encoding = 3, h2AlphaDepth = depth, h2AlphaType = 8, h2Width = 2, h2Height = 1 }+  blankPalette [BS.pack [10, 20, 30, 40, 50, 60, 70, 80], BS.pack [1, 2, 3, 4]]++-- | 2x2, blue and red entries, with 8-bit alpha 255, 128, 64, 0, 1-bit+-- alpha on pixels 1 and 2, or none. The alpha type is 8, as in real files.+palettedFile :: Word8 -> ByteString+palettedFile depth = blp2 defHeader2 { h2Encoding = 1, h2AlphaDepth = depth, h2AlphaType = 8, h2Width = 2, h2Height = 2, h2HasMips = 0 }+  ([(255, 0, 0, 0), (0, 0, 255, 0)] ++ replicate 254 (0, 0, 0, 0))+  [BS.pack ([0, 1, 1, 0] ++ alphaList)]+  where+    alphaList = case depth of+      8 -> [255, 128, 64, 0]+      1 -> [0x06] -- pixels 1 and 2+      _ -> []++-- | The full size image of a decoded file.+level0 :: [Image PixelRGBA8] -> Image PixelRGBA8+level0 (l : _) = l+level0 [] = error "no levels decoded"

@@ -0,0 +1,142 @@+-- | DXT block decoding: hand-built blocks with values worked out from the+-- format description, and a property comparing the decoder with a direct,+-- slow transcription of that description.+module Dxt(dxtTests) where++import Codec.Picture+import Codec.Picture.Blp.Internal.Dxt+import Fixture (colourBlock, dxt3Alpha, dxt5Alpha)+import Data.ByteString (ByteString)+import Data.Either (isLeft)+import Data.Word+import Test.QuickCheck+import Test.Tasty+import Test.Tasty.HUnit+import Test.Tasty.QuickCheck (testProperty)++import qualified Data.ByteString as BS++dxtTests :: TestTree+dxtTests = testGroup "dxt"+  [ testCase "level sizes round up to whole blocks" $ do+      dxtLevelBytes (Dxt1 False) 1 1 @?= 8+      dxtLevelBytes Dxt5 5 3 @?= 32+      dxtLevelBytes Dxt3 4 4 @?= 16+      dxtLevelBytes (Dxt1 True) 256 256 @?= 32768+  , testCase "DXT1 four-colour block: endpoints and thirds" $ do+      let img = decode1 (Dxt1 True) 4 4 $ colourBlock 0xF800 0x001F [0, 1, 2, 3]+      row0 img @?= [rgba 255 0 0 255, rgba 0 0 255 255, rgba 170 0 85 255, rgba 85 0 170 255]+  , testCase "DXT1 three-colour block: half way and black" $ do+      let block = colourBlock 0x001F 0xF800 [0, 1, 2, 3]+      row0 (decode1 (Dxt1 False) 4 4 block) @?= [rgba 0 0 255 255, rgba 255 0 0 255, rgba 127 0 127 255, rgba 0 0 0 255]+      row0 (decode1 (Dxt1 True) 4 4 block) @?= [rgba 0 0 255 255, rgba 255 0 0 255, rgba 127 0 127 255, rgba 0 0 0 0]+  , testCase "DXT1 equal endpoints use three-colour mode" $+      row0 (decode1 (Dxt1 True) 4 4 $ colourBlock 0x1234 0x1234 [3, 0]) @?= [rgba 0 0 0 0, rgba 16 69 165 255, rgba 16 69 165 255, rgba 16 69 165 255]+  , testCase "565 endpoints expand by bit replication" $+      -- r = 16, g = 32, b = 16: 16 << 3 | 16 >> 2 = 132, 32 << 2 | 32 >> 4 = 130.+      pixelAt (decode1 (Dxt1 False) 4 4 $ colourBlock 0x8410 0 []) 0 0 @?= rgba 132 130 132 255+  , testCase "DXT3: 4-bit alpha per pixel, colour always four-colour" $ do+      let img = decode1 Dxt3 4 4 $ dxt3Alpha [0 .. 15] <> colourBlock 0x001F 0xF800 (replicate 15 0 ++ [3])+      [a | y <- [0 .. 3], x <- [0 .. 3], let PixelRGBA8 _ _ _ a = pixelAt img x y] @?= [17 * n | n <- [0 .. 15]]+      pixelAt img 3 3 @?= rgba 170 0 85 255+  , testCase "DXT5 with a0 > a1: six interpolated values" $ do+      let img = decode1 Dxt5 4 4 $ dxt5Alpha 255 0 [i `mod` 8 | i <- [0 .. 15]] <> colourBlock 0 0 []+      alphas img @?= concat (replicate 2 [255, 0, 218, 182, 145, 109, 72, 36])+  , testCase "DXT5 with a0 <= a1: four interpolated values, 0 and 255" $ do+      let img = decode1 Dxt5 4 4 $ dxt5Alpha 0 255 [i `mod` 8 | i <- [0 .. 15]] <> colourBlock 0 0 []+      alphas img @?= concat (replicate 2 [0, 255, 51, 102, 153, 204, 0, 255])+  , testCase "blocks are stored row by row, partial blocks are cropped" $ do+      -- 5x6: two blocks across, two down.+      let red = colourBlock 0xF800 0 []+          green = colourBlock 0x07E0 0 []+          blue = colourBlock 0x001F 0 []+          white = colourBlock 0xFFFF 0 []+          img = decode1 (Dxt1 False) 5 6 $ BS.concat [red, green, blue, white]+          colour (PixelRGBA8 r g b _) = (r, g, b)+      (imageWidth img, imageHeight img) @?= (5, 6)+      [colour (pixelAt img x y) | (x, y) <- [(3, 3), (4, 3), (3, 4), (4, 5)]] @?= [(255, 0, 0), (0, 255, 0), (0, 0, 255), (255, 255, 255)]+  , testCase "short data and empty sizes are errors, extra bytes are ignored" $ do+      let block = colourBlock 0xF800 0 []+      assertBool "short" . isLeft $ decodeDxt (Dxt1 False) 5 1 block+      assertBool "zero width" . isLeft $ decodeDxt (Dxt1 False) 0 4 block+      fmap imageData (decodeDxt (Dxt1 False) 4 4 (block <> BS.replicate 9 0xAB))+        @?= fmap imageData (decodeDxt (Dxt1 False) 4 4 block)+  , testProperty "matches a direct transcription of the format" matchesReference+  ]++rgba :: Word8 -> Word8 -> Word8 -> Word8 -> PixelRGBA8+rgba = PixelRGBA8++decode1 :: DxtFormat -> Int -> Int -> ByteString -> Image PixelRGBA8+decode1 fmt w h = either error id . decodeDxt fmt w h++row0 :: Image PixelRGBA8 -> [PixelRGBA8]+row0 img = [pixelAt img x 0 | x <- [0 .. 3]]++alphas :: Image PixelRGBA8 -> [Word8]+alphas img = [a | y <- [0 .. 3], x <- [0 .. 3], let PixelRGBA8 _ _ _ a = pixelAt img x y]++-- | A random image in every format: random bytes of exactly the right size.+data Case = Case DxtFormat Int Int ByteString++instance Show Case where+  show (Case fmt w h bs) = show fmt ++ " " ++ show w ++ "x" ++ show h ++ " " ++ show (BS.unpack bs)++instance Arbitrary Case where+  arbitrary = do+    fmt <- elements [Dxt1 False, Dxt1 True, Dxt3, Dxt5]+    w <- choose (1, 13)+    h <- choose (1, 13)+    -- Few distinct bytes make equal endpoints and edge cases common.+    bytes <- vectorOf (dxtLevelBytes fmt w h) (oneof [arbitrary, elements [0, 0xFF, 0x80, 0x7F]])+    return $ Case fmt w h (BS.pack bytes)++matchesReference :: Case -> Property+matchesReference (Case fmt w h bs) =+  fmap (\img -> [pixelAt img x y | y <- [0 .. h - 1], x <- [0 .. w - 1]]) (decodeDxt fmt w h bs)+    === Right (reference fmt w h bs)++-- | The format description, transcribed pixel by pixel with lists and+-- integer arithmetic.+reference :: DxtFormat -> Int -> Int -> ByteString -> [PixelRGBA8]+reference fmt w h bs = [pixel x y | y <- [0 .. h - 1], x <- [0 .. w - 1]]+  where+    size = case fmt of+      Dxt1 _ -> 8+      _ -> 16+    number = foldr (\b acc -> acc * 256 + toInteger b) 0 . BS.unpack+    pixel x y = PixelRGBA8 (fromIntegral r) (fromIntegral g) (fromIntegral b) (fromIntegral a)+      where+        start = ((y `div` 4) * ((w + 3) `div` 4) + x `div` 4) * size+        block = BS.take size (BS.drop start bs)+        (alphaPart, colourPart) = case fmt of+          Dxt1 _ -> (BS.empty, block)+          _ -> BS.splitAt 8 block+        i = 4 * (y `mod` 4) + x `mod` 4+        c0 = number (BS.take 2 colourPart)+        c1 = number (BS.take 2 (BS.drop 2 colourPart))+        k = fromInteger $ (number (BS.drop 4 colourPart) `div` (4 ^ i)) `mod` 4+        rgb c = (5 `bitsAt` 11, 6 `bitsAt` 5, 5 `bitsAt` 0)+          where+            bitsAt n from = let v = fromInteger ((c `div` (2 ^ (from :: Int))) `mod` (2 ^ (n :: Int))) :: Int+                            in v * 2 ^ (8 - n) + v `div` 2 ^ (2 * n - 8)+        (p0, p1) = (rgb c0, rgb c1)+        four = case fmt of+          Dxt1 _ -> c0 > c1+          _ -> True+        mixed m n = let f u v = (m * u + n * v) `div` (m + n) in zip3' f p0 p1+        zip3' f (u0, v0, w0) (u1, v1, w1) = (f u0 u1, f v0 v1, f w0 w1)+        colours+          | four = [p0, p1, mixed 2 1, mixed 1 2]+          | otherwise = [p0, p1, mixed 1 1, (0, 0, 0)]+        (r, g, b) = colours !! k+        a = case fmt of+          Dxt1 True | not four && k == 3 -> 0+          Dxt1 _ -> 255+          Dxt3 -> 17 * fromInteger ((number alphaPart `div` (16 ^ i)) `mod` 16)+          Dxt5 -> table !! fromInteger ((number (BS.drop 2 alphaPart) `div` (8 ^ i)) `mod` 8)+        a0 = fromIntegral (BS.index alphaPart 0) :: Int+        a1 = fromIntegral (BS.index alphaPart 1)+        table+          | a0 > a1 = [a0, a1] ++ [((7 - j) * a0 + j * a1) `div` 7 | j <- [1 .. 6]]+          | otherwise = [a0, a1] ++ [((5 - j) * a0 + j * a1) `div` 5 | j <- [1 .. 4]] ++ [0, 255]

@@ -1,4 +1,4 @@--- | Byte-level BLP1 builder for tests.+-- | Byte-level BLP1 and BLP2 builders for tests. -- -- Uncompressed files are assembled here field by field rather than with the -- library's encoder, so decoder tests do not depend on the encoder being@@ -16,6 +16,14 @@   , offsetSlot   , sizeSlot   , extraOffset+  , Header2(..)+  , defHeader2+  , blp2HeaderSize+  , blp2+  , blankPalette+  , colourBlock+  , dxt3Alpha+  , dxt5Alpha   ) where  import Data.Bits@@ -95,3 +103,72 @@ offsetSlot, sizeSlot :: Int -> Int offsetSlot i = 28 + 4 * i sizeSlot i = 92 + 4 * i++-- | BLP2 header fields.+data Header2 = Header2 {+  h2Type       :: Word32+, h2Encoding   :: Word8+, h2AlphaDepth :: Word8+, h2AlphaType  :: Word8+, h2HasMips    :: Word8+, h2Width      :: Word32+, h2Height     :: Word32+}++-- | Opaque DXT1 4x4 header; override fields as needed.+defHeader2 :: Header2+defHeader2 = Header2 {+    h2Type       = 1+  , h2Encoding   = 2+  , h2AlphaDepth = 0+  , h2AlphaType  = 0+  , h2HasMips    = 1+  , h2Width      = 4+  , h2Height     = 4+  }++-- | Size of the fixed BLP2 header: tag, type, four bytes, width, height,+-- 16 offsets, 16 sizes.+blp2HeaderSize :: Int+blp2HeaderSize = 148++-- | BLP2 file: header, palette (as given; real files always have 256+-- entries), then each mipmap back to back with slots pointing at them.+blp2 :: Header2 -> [PaletteEntry] -> [ByteString] -> ByteString+blp2 Header2{..} palette mips = BS.concat+  [ "BLP2"+  , dword h2Type+  , BS.pack [h2Encoding, h2AlphaDepth, h2AlphaType, h2HasMips]+  , dwords [h2Width, h2Height]+  , dwords (map fst slots), dwords (map snd slots)+  , pal+  , BS.concat mips+  ]+  where+    pal = paletteBytes palette+    sizes = map (fromIntegral . BS.length) mips+    offsets = scanl (+) (fromIntegral $ blp2HeaderSize + BS.length pal) sizes+    slots = take 16 $ zip offsets sizes ++ repeat (0, 0)++-- | 256 transparent black entries, as DXT and BGRA files carry.+blankPalette :: [PaletteEntry]+blankPalette = replicate 256 (0, 0, 0, 0)++-- | A DXT colour block: two RGB565 endpoints and the indices of the first+-- pixels, the rest zero.+colourBlock :: Int -> Int -> [Int] -> ByteString+colourBlock c0 c1 ixs = BS.pack $ le 2 c0 ++ le 2 c1 ++ le 4 (packBits 2 ixs)++-- | DXT3 alpha block: a 4-bit value per pixel.+dxt3Alpha :: [Int] -> ByteString+dxt3Alpha = BS.pack . le 8 . packBits 4++-- | DXT5 alpha block: two endpoints and a 3-bit index per pixel.+dxt5Alpha :: Int -> Int -> [Int] -> ByteString+dxt5Alpha a0 a1 ixs = BS.pack $ map fromIntegral [a0, a1] ++ le 6 (packBits 3 ixs)++packBits :: Int -> [Int] -> Integer+packBits bits = sum . zipWith (\i v -> toInteger v `shiftL` (bits * i)) [0 ..]++le :: Integral a => Int -> a -> [Word8]+le n v = [fromIntegral (toInteger v `shiftR` (8 * k)) | k <- [0 .. n - 1]]

@@ -17,7 +17,9 @@ import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BSL +import Blp2 import Deprecated+import Dxt import Properties import Fixture @@ -31,6 +33,8 @@   , encoderTests   , fileTests   , deprecatedTests+  , dxtTests+  , blp2Tests   , propertyTests   ] @@ -149,7 +153,7 @@ malformedTests :: TestTree malformedTests = testGroup "malformed input"   [ testCase "wrong version tag" $-      assertLeft "BLP1" . decodeBlp $ "BLP2" <> BS.drop 4 (withAlphaFile 4)+      assertLeft "BLP1" . decodeBlp $ "BLP0" <> BS.drop 4 (withAlphaFile 4)   , testCase "unknown compression" $       assertLeft "compression" . decodeBlp $ uncompressed defHeader { hCompression = 7 } (palette 256) [indices]   , testCase "truncated header" $@@ -491,13 +495,13 @@       assertLeft "above the limit" $ limited 15 (withAlphaFile 4)       assertBool "4x4 paletted fits 16 pixels" . either (const False) (const True) $ limited 16 (withAlphaFile 4)   , testCase "blpInfo reads the header" $ do-      blpInfo jpegFile @?= Right (BlpInfo BlpCompressionJPEG 16 16 8 3)-      blpInfo (withAlphaFile 4) @?= Right (BlpInfo BlpCompressionUncompressed 4 4 8 1)-      blpInfo withoutAlphaFile @?= Right (BlpInfo BlpCompressionUncompressed 4 4 0 1)+      blpInfo jpegFile @?= Right (BlpInfo Blp1 BlpCompressionJPEG 16 16 8 3)+      blpInfo (withAlphaFile 4) @?= Right (BlpInfo Blp1 BlpCompressionUncompressed 4 4 8 1)+      blpInfo withoutAlphaFile @?= Right (BlpInfo Blp1 BlpCompressionUncompressed 4 4 0 1)   , testCase "blpInfo decodes no pixels" $       fmap (\i -> (blpInfoWidth i, blpInfoHeight i)) (blpInfo (inflated 16384)) @?= Right (16384, 16384)   , testCase "blpInfo rejects what decodeBlp rejects" $ do-      assertLeft "BLP1" . blpInfo $ "BLP2" <> BS.drop 4 (withAlphaFile 4)+      assertLeft "BLP1" . blpInfo $ "BLP0" <> BS.drop 4 (withAlphaFile 4)       assertLeft "Invalid image size" . blpInfo $ setDword 12 0 (withAlphaFile 4)   ] 

@@ -18,6 +18,8 @@ import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BSL +import Blp2 (blp2Seeds)+ propertyTests :: TestTree propertyTests = testGroup "properties"   [ testGroup "fuzz"@@ -30,7 +32,7 @@  -- | Valid files of every kind, to be damaged. seeds :: [ByteString]-seeds =+seeds = blp2Seeds ++   [ encode (BlpFormatJpeg 90) 16 (texture 16 8)   , encode (BlpFormatJpeg 50) 1 (texture 5 7)   , encode (BlpFormatJpeg 90) 16 (opaque 8 8)