diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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. diff --git a/JuicyPixels-blp.cabal b/JuicyPixels-blp.cabal --- a/JuicyPixels-blp.cabal +++ b/JuicyPixels-blp.cabal @@ -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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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 diff --git a/bench/Main.hs b/bench/Main.hs --- a/bench/Main.hs +++ b/bench/Main.hs @@ -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]] diff --git a/blp2any/Main.hs b/blp2any/Main.hs --- a/blp2any/Main.hs +++ b/blp2any/Main.hs @@ -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" diff --git a/docs/format.md b/docs/format.md --- a/docs/format.md +++ b/docs/format.md @@ -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`. diff --git a/src/Codec/Picture/Blp.hs b/src/Codec/Picture/Blp.hs --- a/src/Codec/Picture/Blp.hs +++ b/src/Codec/Picture/Blp.hs @@ -1,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 diff --git a/src/Codec/Picture/Blp/Internal/Data.hs b/src/Codec/Picture/Blp/Internal/Data.hs --- a/src/Codec/Picture/Blp/Internal/Data.hs +++ b/src/Codec/Picture/Blp/Internal/Data.hs @@ -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) diff --git a/src/Codec/Picture/Blp/Internal/Decoder.hs b/src/Codec/Picture/Blp/Internal/Decoder.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Picture/Blp/Internal/Decoder.hs @@ -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) + } diff --git a/src/Codec/Picture/Blp/Internal/Dxt.hs b/src/Codec/Picture/Blp/Internal/Dxt.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Picture/Blp/Internal/Dxt.hs @@ -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 diff --git a/src/Codec/Picture/Blp/Internal/Encoder.hs b/src/Codec/Picture/Blp/Internal/Encoder.hs --- a/src/Codec/Picture/Blp/Internal/Encoder.hs +++ b/src/Codec/Picture/Blp/Internal/Encoder.hs @@ -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 diff --git a/src/Codec/Picture/Blp/Internal/Parser.hs b/src/Codec/Picture/Blp/Internal/Parser.hs --- a/src/Codec/Picture/Blp/Internal/Parser.hs +++ b/src/Codec/Picture/Blp/Internal/Parser.hs @@ -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 diff --git a/src/Codec/Picture/Blp/Types.hs b/src/Codec/Picture/Blp/Types.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Picture/Blp/Types.hs @@ -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) diff --git a/test/Blp2.hs b/test/Blp2.hs new file mode 100644 --- /dev/null +++ b/test/Blp2.hs @@ -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" diff --git a/test/Dxt.hs b/test/Dxt.hs new file mode 100644 --- /dev/null +++ b/test/Dxt.hs @@ -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] diff --git a/test/Fixture.hs b/test/Fixture.hs --- a/test/Fixture.hs +++ b/test/Fixture.hs @@ -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]] diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -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) ] diff --git a/test/Properties.hs b/test/Properties.hs --- a/test/Properties.hs +++ b/test/Properties.hs @@ -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)