diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,82 @@ +0.4.0.0 (2026-10-15) +==================== + +Breaking changes: + +- New encoding API: `encodeBlpWith` and `writeBlpWith` take + `BlpEncodeOptions` (a `BlpFormat` and a mip level count) and return + `Either BlpEncodeError`. Empty images, sides above 65535, JPEG quality + outside 1..100 and files over 4 GiB are errors instead of crashes or + silent wrap-around (#31). `encodeBlpJpeg`, `encodeBlpUncompressedWithAlpha`, + `encodeBlpUncompressedWithoutAlpha` and their `writeBlp*` variants still + work as deprecated wrappers; they clamp the JPEG quality, which used to + wrap modulo 256. +- The decoder takes alpha from the `alphaBits` header field, as the format + specifies, instead of from the `extra` field. Paletted files with 1-bit and + 4-bit alpha now decode, files whose `extra` field says otherwise keep their + alpha, and unknown `extra` values are no longer rejected (#25). +- Non-square textures get the full mip chain down to 1x1 instead of + stopping when the shorter side reaches one pixel, and `mipMapsUpTo` counts + levels by the larger side, capped at 16 (#26, #31). +- Mipmap colour is averaged with alpha as the weight, so transparent pixels + no longer darken the edges of sprites, and the alpha of paletted mipmaps + is averaged instead of sampled. Opaque textures encode exactly as before + (#32). +- `Codec.Picture.Blp.Internal.*`: + - `BlpStruct` keeps the raw header values in `blpAlphaBits`, `blpExtra` and + `blpHasMipmaps`; `blpCompression` is a function of `blpExt`. `BlpFlag` and + `BlpPictureType` are gone. + - Paletted content is one `BlpPaletted` constructor holding each level's + raw data. + - The parser is `parseBlp` plus `mipLevels` and `jpegFrameSize`; the + attoparsec walk over the content (`blpJpegParser`, `skipToOffset`, ...) + is gone. + - `encodeBlp` and `blpEncoder` take just the `BlpStruct`; `toBlpStruct` + takes a `BlpFormat`. + +Decoding untrusted files (#30): + +- Errors that JuicyPixels' JPEG decoder raises from pure code are returned + as `Left`; in a tail mipmap they end the list. +- Width and height must be between 1 and 65535. Larger values used to + overflow the size checks and leave an exception in the decoded image. +- Each JPEG level's frame size is read before decoding. A frame larger than + the level is rejected, so an 800-byte file can no longer demand gigabytes; + a smaller one is padded with transparent black. +- Mipmap slots are read by index. A missing or garbage slot ends the chain + instead of shifting the later levels, and a garbage slot that points into + the palette no longer breaks the file. +- Some corrupt JPEG streams still make JuicyPixels loop forever + (haskell-github-trust/Juicy.Pixels#230), so decoding untrusted files needs + a timeout. + +Encoder fixes (#31): + +- Unused mipmap slots are zero, as the format requires, and `hasMipmaps` is + 0 when only one level is written. +- Only the levels that are written are encoded; asking for one level of a + 2048x2048 JPEG texture used to encode all of them. + +Faster (#34): JPEG decoding is 2.1–2.7x and JPEG encoding 2.2–2.8x as fast, +measured with the new benchmark suite (`bench/Main.hs`). Output is +byte-identical. + +blp2any (#33): + +- `-s`/`--shallow` and `-p` (now also `--flatten`) were accepted but did + nothing; they now keep conversion to the top folder and write all output + into one folder. +- A file that fails no longer aborts a batch conversion or `stats`: it is + reported on stderr and skipped, and `convert` prints a summary and exits + with status 1 if anything failed. +- An input folder given with a trailing slash no longer sends output to the + root of the file system. +- `--version` reports the package version. + +Documentation: `docs/format.md` describes the BLP1 format and what the +library does with each part; the README covers usage, `blp2any`, +limitations and benchmarking; every module has haddock (#27). + 0.3.0.0 (2026-10-15) ==================== diff --git a/JuicyPixels-blp.cabal b/JuicyPixels-blp.cabal --- a/JuicyPixels-blp.cabal +++ b/JuicyPixels-blp.cabal @@ -1,12 +1,16 @@ cabal-version: 2.2 name: JuicyPixels-blp -version: 0.3.0.0 +version: 0.4.0.0 synopsis: BLP format decoder/encoder over JuicyPixels library description: - The library provides decoding/encoding functions for BLP1 texture format of Warcraft III game. - The result is represented in types of [JuicyPixels](http://hackage.haskell.org/package/JuicyPixels) library. - - Please see README.md for detailed description. + Read and write BLP1, the texture format of Warcraft III, with images as + [JuicyPixels](https://hackage.haskell.org/package/JuicyPixels) types. + Supports JPEG and paletted content with and without alpha, mipmaps, and + the non-standard files common in community maps. Includes @blp2any@, a + converter between BLP and PNG, JPEG, TIFF, GIF and BMP. + . + See the README for usage and limitations, and @docs/format.md@ for the + file format. homepage: https://github.com/NCrashed/JuicyPixels-blp#readme license: BSD-3-Clause license-file: LICENSE @@ -15,7 +19,7 @@ copyright: 2015-2026 Anton Gushcha category: Codec, Graphics, Image build-type: Simple -extra-doc-files: README.md, CHANGELOG.md +extra-doc-files: README.md, CHANGELOG.md, docs/format.md tested-with: GHC == 9.4.8 || == 9.6.7 @@ -47,6 +51,7 @@ , attoparsec >= 0.12 && < 0.15 , binary >= 0.8 && < 0.10 , bytestring >= 0.10 && < 0.13 + , deepseq >= 1.4 && < 1.6 , JuicyPixels >= 3.2 && < 3.4 , vector >= 0.10 && < 0.14 @@ -65,6 +70,9 @@ Convert File Statistics + Paths_JuicyPixels_blp + autogen-modules: + Paths_JuicyPixels_blp ghc-options: -threaded -rtsopts -with-rtsopts=-N default-language: Haskell2010 build-depends: @@ -76,16 +84,33 @@ , JuicyPixels , JuicyPixels-blp , optparse-simple >= 0.0.3 && < 0.2 + , transformers >= 0.5 && < 0.7 default-extensions: RecordWildCards +benchmark bench + import: warnings + type: exitcode-stdio-1.0 + hs-source-dirs: bench + main-is: Main.hs + default-language: Haskell2010 + ghc-options: -rtsopts -with-rtsopts=-A32m + build-depends: + base + , bytestring + , deepseq + , JuicyPixels + , JuicyPixels-blp + , tasty-bench >= 0.3 && < 0.5 + test-suite spec import: warnings type: exitcode-stdio-1.0 hs-source-dirs: test main-is: Main.hs other-modules: + Deprecated Fixture default-language: Haskell2010 build-depends: diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -2,18 +2,156 @@ =============== [![CI](https://github.com/NCrashed/JuicyPixels-blp/actions/workflows/ci.yml/badge.svg)](https://github.com/NCrashed/JuicyPixels-blp/actions/workflows/ci.yml) +[![Hackage](https://img.shields.io/hackage/v/JuicyPixels-blp.svg)](https://hackage.haskell.org/package/JuicyPixels-blp) -The library provides decoding/encoding functions for BLP1 texture format of Warcraft III game. -The result is represented in types of [JuicyPixels](http://hackage.haskell.org/package/JuicyPixels) library. +Read and write BLP1, the texture format of Warcraft III, with images as +[JuicyPixels](https://hackage.haskell.org/package/JuicyPixels) types. The +package also ships `blp2any`, a command-line converter between BLP and +common image formats. -Features: +For the layout of a BLP file and how the library handles each part, see +[docs/format.md](docs/format.md). -- Supported all three subtypes of BLP1: JPEG with alpha, paletted without alpha and paletted with alpha. +## Library -- Command line utility to convert BLPs from/to PNG, JPEG, BMP, TGA, TIFF, GIF, Radiance formats. +```haskell +import Codec.Picture +import Codec.Picture.Blp -TODO: +main :: IO () +main = do + -- Decode: the result is always ImageRGBA8. + Right img <- readBlp "war3mapMap.blp" + writePng "war3mapMap.png" (convertRGBA8 img) -- BLP0 support + -- Encode: JPEG at quality 90 with every mip level down to 1x1. + Right png <- readImage "icon.png" + result <- writeBlpWith "icon.blp" defaultBlpEncodeOptions png + either print return result +``` -- BLP2 support +- `readBlp` / `decodeBlp` return the full size image. +- `readBlpMipmaps` / `decodeBlpMipmaps` return the image followed by its + mipmaps. +- `encodeBlpWith` / `writeBlpWith` encode with `BlpEncodeOptions`: + - `blpFormat`: `BlpFormatJpeg quality` (1 to 100; the texture gets alpha + when the image has it) or `BlpFormatPaletted withAlpha` (256 colour + palette, with 8-bit alpha or none). + - `blpMipLevels`: how many mip levels to write, clamped to 1 and the full + chain. `mipMapsUpTo` computes it from a smallest side length. + + They return `Left` for images they cannot encode (`BlpEncodeError`): an + empty image, a side above 65535, an invalid JPEG quality, or a file over + 4 GiB. +- The older `encodeBlpJpeg`, `encodeBlpUncompressedWithAlpha`, + `encodeBlpUncompressedWithoutAlpha` and their `write` variants are + deprecated wrappers around `encodeBlpWith`. + +The `Codec.Picture.Blp.Internal.*` modules expose the parser, encoder and +file structure. They are useful for tools, but their API may change between +minor versions. + +## What works + +- **Decoding** all BLP1 variants: JPEG, and paletted with 0, 1, 4 or 8-bit + alpha, including their mipmaps. +- **Damaged and non-standard files** that are common in community maps and + ports of World of Warcraft assets: + - odd header values; + - short palettes; + - garbage in unused mipmap slots; + - truncated or corrupt mipmaps. These cost only the levels from the damaged + one onwards; a damaged full size image still fails the file. + + The decoder reports malformed input as `Left`, including errors raised + inside JuicyPixels' JPEG decoder. One known exception: some corrupt JPEG + streams make JuicyPixels loop forever + ([Juicy.Pixels#230](https://github.com/haskell-github-trust/Juicy.Pixels/issues/230)), + so decoding untrusted files needs a timeout. +- **Encoding** to JPEG or a 256 colour palette, with or without alpha. The + JPEG header is shared between mipmaps, as in Blizzard's own files. + +## Limitations + +- **BLP0 and BLP2.** Only BLP1 is supported. BLP0 keeps mipmaps in separate + `.b00`–`.b15` files; BLP2 is the World of Warcraft variant + ([#3](https://github.com/NCrashed/JuicyPixels-blp/issues/3)). +- **Lossy palette.** Uncompressed encoding quantises to 256 colours with + dithering, so it is lossy for images with more colours. +- **Fixed header values.** The encoder writes `extra` as 3 with alpha and 5 + without, and `hasMipmaps` as 5, or 0 for a single level. + +## blp2any + +``` +blp2any convert INPUT_PATH OUTPUT_PATH [-i FORMAT] [-f FORMAT] [-q QUALITY] + [-b jpg|uncompressedWithAlpha|uncompressedWithoutAlpha] + [--min-mipmap-size N] [-s|--shallow] [-p|--flatten] +blp2any stats DIRECTORY OUTPUT_PATH +``` + +- **`convert`** turns a file or a whole directory from one format into + another. Supported formats are `blp`, `png`, `jpg`, `tiff`, `gif` and + `bmp`. + - Formats are inferred from the file names, or given with `-i` and `-f`. + - With a directory it recurses unless `-s` is given, and it recreates the + subdirectories unless `-p` (`--flatten`) is given. A file that fails is + reported on stderr and skipped; at the end it prints how many files were + converted and failed, and exits with status 1 if any failed. + - When writing BLP, `-b` picks the internal format (JPEG by default) and + `--min-mipmap-size` the smallest mip level to keep. The default is 1, + which writes every level down to 1×1. A larger value leaves textures + without their smallest levels; Warcraft III draws missing levels as + transparent black, so this is only safe for interface images. +- **`stats`** groups the BLP files in a directory by their header values + and copies one example of each group to `OUTPUT_PATH`. Files it cannot + read are reported and skipped. It helps when hunting for unusual files. + +``` +blp2any convert war3/ textures-png/ -f png +blp2any convert icons/ icons-blp/ -i png -f blp -b jpg -q 85 +``` + +## Building and testing + +With [Nix](https://nixos.org) (flakes enabled), each supported GHC has its +own development shell: + +``` +nix develop .#ghc912 # or ghc94, ghc96, ghc98, ghc910, ghc914 +cabal build all +cabal test +``` + +`nix develop` without a name gives a shell with haskell-language-server. +`nix build` builds the package, and `nix run . -- --help` runs `blp2any`. +Plain `cabal` works as well. `stack.yaml` is kept for Stack users, but CI +does not test it. + +- **Test suite.** It builds its BLP fixtures in code (`test/Fixture.hs`): + paletted files byte by byte, and JPEG files from the encoder, patched where + needed. A test that pins down a fix names its PR or issue. +- **CI.** It builds and tests GHC 9.4 to 9.14 with `-Werror`. The benchmarks are built + in CI but not run. + +### Benchmarks + +`bench/Main.hs` (tasty-bench) times decoding and encoding at several sizes +for each content type, plus a few internals. The inputs are generated in +code. To compare a change against the current state: + +``` +cabal bench --ghc-options=-fproc-alignment=64 --benchmark-options '--csv before.csv' +# ... change the code ... +cabal bench --ghc-options=-fproc-alignment=64 --benchmark-options '--baseline before.csv' +``` + +Use `-p` to run a subset, for example `-p decode` or `-p '/jpeg alpha/'`. + +Two things make the numbers noisy: + +- **Code alignment.** Without `-fproc-alignment=64`, a change in one module + can move the tight loops of another and shift its timings by 20–25%. This + happened to the paletted decoder while the JPEG code was being changed. +- **Machine load.** Compare runs made under the same conditions, ideally by + alternating the two builds. diff --git a/bench/Main.hs b/bench/Main.hs new file mode 100644 --- /dev/null +++ b/bench/Main.hs @@ -0,0 +1,111 @@ +-- | Benchmarks for decoding and encoding BLP textures. +-- +-- Inputs are generated in code: a gradient with deterministic noise, so that +-- JPEG and palette quantisation have real work to do. Run with +-- +-- > cabal bench --benchmark-options '-p decode' +-- +-- and compare against an earlier run with @--csv old.csv@ / @--baseline old.csv@. +module Main(main) where + +import Codec.Picture +import Codec.Picture.Blp +import Codec.Picture.Blp.Internal.Convert (jpegAlphaIsUsable) +import Codec.Picture.Blp.Internal.Encoder (createMipMaps) +import Codec.Picture.Jpg (encodeDirectJpegAtQualityWithMetadata) +import Control.DeepSeq +import Data.Bits +import Data.ByteString (ByteString) +import Data.Word +import Test.Tasty.Bench + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BSL + +main :: IO () +main = defaultMain + [ bgroup "decode" + [ decodeGroup "jpeg alpha" (jpeg True) [64, 512, 2048] + , decodeGroup "jpeg opaque" (jpeg False) [512, 2048] + , decodeGroup "paletted alpha8" (paletted True) [64, 512, 2048] + , decodeGroup "paletted alpha4" (setAlphaBits 4 . paletted True) [512] + , decodeGroup "paletted alpha1" (setAlphaBits 1 . paletted True) [512] + , decodeGroup "paletted opaque" (paletted False) [512, 2048] + ] + , bgroup "encode" + [ encodeGroup "jpeg full chain" (BlpFormatJpeg 90) 16 texture [64, 512, 1024] + , encodeGroup "jpeg one level" (BlpFormatJpeg 90) 1 texture [512, 2048] + , encodeGroup "paletted alpha" (BlpFormatPaletted True) 16 texture [64, 512] + , encodeGroup "paletted opaque from RGB8" (BlpFormatPaletted False) 16 (\n -> ImageRGB8 . convertRGB8 $ texture n) [512] + , env (return . force $ texture2 1024 128) $ \img -> + bench "jpeg full chain/1024x128" $ nf (encodeWith (BlpFormatJpeg 90) 16) img + ] + , bgroup "internals" + [ env (return . force $ rgba 2048) $ \img -> + bench "createMipMaps/2048" $ nf (map imageData . createMipMaps) img + , env (return . force $ cmykLevel (rgba 2048)) $ \img -> + bench "jpegAlphaIsUsable/2048 varying" $ nf jpegAlphaIsUsable img + , env (return . force $ cmykLevel (convertRGBA8 (opaque 2048))) $ \img -> + bench "jpegAlphaIsUsable/2048 opaque" $ nf jpegAlphaIsUsable img + ] + ] + +-- | Decode mip 0 only, and the whole chain, of a file made for each size. +decodeGroup :: String -> (Int -> ByteString) -> [Int] -> Benchmark +decodeGroup name mkFile sizes = bgroup name + [ env (return . force $ mkFile n) $ \file -> bgroup (show n) + [ bench "mip 0" $ nf (fmap pixels . decodeBlp) file + , bench "all levels" $ nf (fmap (map pixels) . decodeBlpMipmaps) file + ] + | n <- sizes ] + where + pixels img = imageData (convertRGBA8 img) + +-- | Encode an image of each size with the given format and level count. +encodeGroup :: String -> BlpFormat -> Int -> (Int -> DynamicImage) -> [Int] -> Benchmark +encodeGroup name format levels mkImage sizes = bgroup name + [ env (return . force $ mkImage n) $ \img -> + bench (show n) $ nf (encodeWith format levels) img + | n <- sizes ] + +encodeWith :: BlpFormat -> Int -> DynamicImage -> BSL.ByteString +encodeWith format levels = either (error . show) id . encodeBlpWith (BlpEncodeOptions format levels) + +-- | Square test texture with varying alpha. +texture :: Int -> DynamicImage +texture n = texture2 n n + +texture2 :: Int -> Int -> DynamicImage +texture2 w h = ImageRGBA8 $ generateImage px w h + where + px x y = let + noise = fromIntegral (hash (x * 7919 + y * 104729)) :: Word8 + in PixelRGBA8 (fromIntegral (x * 255 `div` w) + noise `shiftR` 3) + (fromIntegral (y * 255 `div` h) + noise `shiftR` 4) + noise + (fromIntegral ((x + y) * 255 `div` (w + h))) + hash v = (v * 2654435761) `shiftR` 13 .&. 0xFF + +rgba :: Int -> Image PixelRGBA8 +rgba = convertRGBA8 . texture + +opaque :: Int -> DynamicImage +opaque = ImageRGBA8 . pixelMap (\(PixelRGBA8 r g b _) -> PixelRGBA8 r g b 255) . rgba + +jpeg :: Bool -> Int -> ByteString +jpeg withAlpha n = BSL.toStrict . encodeWith (BlpFormatJpeg 90) 16 $ + if withAlpha then texture n else opaque n + +paletted :: Bool -> Int -> ByteString +paletted withAlpha n = BSL.toStrict $ encodeWith (BlpFormatPaletted withAlpha) 16 (texture n) + +-- | Rewrite the alphaBits header field; an 8-bit alpha list is long enough +-- for 1 and 4 bits. +setAlphaBits :: Word32 -> ByteString -> ByteString +setAlphaBits bits file = BS.take 8 file <> BS.pack [fromIntegral (bits `shiftR` (8 * i)) | i <- [0 .. 3]] <> BS.drop 12 file + +-- | A texture as JuicyPixels decodes a BLP JPEG level, before conversion. +-- An opaque one is the worst case for the alpha check: it scans every pixel. +cmykLevel :: Image PixelRGBA8 -> DynamicImage +cmykLevel img = either error id . decodeJpeg . BSL.toStrict $ + encodeDirectJpegAtQualityWithMetadata 90 mempty (pixelMap (\(PixelRGBA8 r g b a) -> PixelCMYK8 b g r a) img) diff --git a/blp2any/Convert.hs b/blp2any/Convert.hs --- a/blp2any/Convert.hs +++ b/blp2any/Convert.hs @@ -1,32 +1,39 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MultiWayIf #-} module Convert( convertFiles , ConvertFormat(..) , ConvertOptions(..) , readConvertFormat - , BlpFormat(..) - , readBlpFormat + , BlpKind(..) + , readBlpKind ) where import Codec.Picture import Codec.Picture.Blp import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Trans.Except import Data.Char import Data.Maybe import System.Directory +import System.Exit import System.FilePath +import System.IO import qualified Data.ByteString as BS import File -data BlpFormat = +-- | BLP content type to write, as picked on the command line. +data BlpKind = BlpJpeg | BlpUncompressedWithAlpha | BlpUncompressedWithoutAlpha deriving (Eq, Ord, Show, Enum, Bounded) -readBlpFormat :: String -> Maybe BlpFormat -readBlpFormat s = case toLower <$> s of +readBlpKind :: String -> Maybe BlpKind +readBlpKind s = case toLower <$> s of "jpeg" -> Just BlpJpeg "jpg" -> Just BlpJpeg "uncompressed1" -> Just BlpUncompressedWithAlpha @@ -85,38 +92,40 @@ , convertQuality :: Int , convertPreservesDirs :: Bool , convertShallow :: Bool -, convertBlpFormat :: BlpFormat +, convertBlpKind :: BlpKind , convertBlpMinMipSize :: Int } convertFiles :: ConvertOptions -> IO () convertFiles opts@ConvertOptions{..} = do - efx <- doesFileExist convertInput - if efx - then convertFile opts False convertInput - else do - edx <- doesDirectoryExist convertInput - if edx then do - putStrLn $ "Converting all files from " ++ convertInput ++ " folder" - forEachFile' convertInput fileFilter $ convertFile opts True - else fail $ "Given path " ++ convertInput ++ " doesn't exsist!" + isFile <- doesFileExist convertInput + isDir <- doesDirectoryExist convertInput + if | isFile -> convertFile opts False convertInput >>= either (failWith . ((convertInput ++ ": ") ++)) putStrLn + | isDir -> do + putStrLn $ "Converting all files from " ++ convertInput ++ " folder" + (converted, failed) <- forEachFile (not convertShallow) convertInput fileFilter step (0 :: Int, 0 :: Int) + putStrLn $ show converted ++ " converted, " ++ show failed ++ " failed" + when (failed > 0) exitFailure + | otherwise -> failWith $ "Given path " ++ convertInput ++ " doesn't exist!" where + step (!converted, !failed) inputFile = do + result <- tryAll (convertFile opts True inputFile) + case join result of + Right msg -> putStrLn msg >> return (converted + 1, failed) + Left err -> hPutStrLn stderr (inputFile ++ ": " ++ err) >> return (converted, failed + 1) fileFilter s = case convertFormat of Blp -> (fmap toLower $ takeExtension s) `elem` supportedExtensions _ -> (".blp" ==) . fmap toLower . takeExtension $ s + failWith err = hPutStrLn stderr err >> exitFailure -- | Trye to guess format from name of file guessFormat :: FilePath -> Maybe ConvertFormat guessFormat = readConvertFormat . drop 1 . takeExtension -- | Try to load input file with desired format -readInputFile :: FilePath -> ConvertFormat -> IO DynamicImage +readInputFile :: FilePath -> ConvertFormat -> IO (Either String DynamicImage) readInputFile inputFile format = case format of - Blp -> do - fc <- BS.readFile inputFile - case decodeBlp fc of - Left err -> fail $ "Failed to load file " <> inputFile <> ", parse error: " <> err - Right img -> pure img + Blp -> either (Left . ("parse error: " <>)) Right . decodeBlp <$> BS.readFile inputFile Png -> loadJuicy readPng Jpeg -> loadJuicy readJpeg Tiff -> loadJuicy readTiff @@ -124,18 +133,15 @@ Bmp -> loadJuicy readBitmap UnspecifiedFormat -> case guessFormat inputFile of Just newFormat -> readInputFile inputFile newFormat - Nothing -> fail $ "Cannot infer format from filename " <> inputFile + Nothing -> pure . Left $ "cannot infer format from the file name" where - loadJuicy :: (FilePath -> IO (Either String DynamicImage)) -> IO DynamicImage - loadJuicy f = do - mres <- f inputFile - case mres of - Left err -> fail $ "Failed to load file " <> inputFile <> " as " <> show format <> ", error: " <> err - Right img -> pure img + loadJuicy :: (FilePath -> IO (Either String DynamicImage)) -> IO (Either String DynamicImage) + loadJuicy f = either (Left . (("cannot load as " <> show format <> ": ") <>)) Right <$> f inputFile -convertFile :: ConvertOptions -> Bool -> FilePath -> IO () -convertFile ConvertOptions{..} isDir inputFile = do - img <- readInputFile inputFile convertInputFormat +-- | Convert one file; the result is a line to report on success. +convertFile :: ConvertOptions -> Bool -> FilePath -> IO (Either String String) +convertFile ConvertOptions{..} isDir inputFile = runExceptT $ do + img <- ExceptT $ readInputFile inputFile convertInputFormat let distFormat = case convertFormat of UnspecifiedFormat -> if isDir then defaultFormat else case guessFormat convertOutput of @@ -143,26 +149,27 @@ Nothing -> defaultFormat _ -> convertFormat - when isDir $ createDirectoryIfMissing True convertOutput - let outputFile = if isDir - then convertOutput - drop (length convertInput + 1) (takeDirectory inputFile) - (takeBaseName inputFile <> fromMaybe "" (listToMaybe $ formatExtension distFormat)) - else convertOutput - createDirectoryIfMissing True $ takeDirectory outputFile + outputName = takeBaseName inputFile <> fromMaybe "" (listToMaybe $ formatExtension distFormat) + -- Keep the input's subdirectory unless asked to flatten the output. + outputFile + | not isDir = convertOutput + | convertPreservesDirs = convertOutput makeRelative convertInput (takeDirectory inputFile) outputName + | otherwise = convertOutput outputName + liftIO . createDirectoryIfMissing True $ takeDirectory outputFile let mipsCount = mipMapsUpTo convertBlpMinMipSize img - res <- convertionFunction distFormat convertQuality convertBlpFormat outputFile mipsCount img - case res of - Left err -> fail $ inputFile <> ": " <> err - Right _ -> putStrLn $ inputFile <> ": Success" + ExceptT $ convertionFunction distFormat convertQuality convertBlpKind outputFile mipsCount img + pure $ inputFile <> ": Success" -convertionFunction :: ConvertFormat -> Int -> BlpFormat -> FilePath -> Int -> DynamicImage -> IO (Either String ()) -convertionFunction f quality blpFormat path mipsCount img = case f of - Blp -> case blpFormat of - BlpJpeg -> writeBlpJpeg path quality mipsCount img >> pure (Right ()) - BlpUncompressedWithAlpha -> writeBlpUncompressedWithAlpha path mipsCount img >> pure (Right ()) - BlpUncompressedWithoutAlpha -> writeBlpUncompressedWithoutAlpha path mipsCount img >> pure (Right ()) +convertionFunction :: ConvertFormat -> Int -> BlpKind -> FilePath -> Int -> DynamicImage -> IO (Either String ()) +convertionFunction f quality blpKind path mipsCount img = case f of + Blp -> do + let format = case blpKind of + BlpJpeg -> BlpFormatJpeg quality + BlpUncompressedWithAlpha -> BlpFormatPaletted True + BlpUncompressedWithoutAlpha -> BlpFormatPaletted False + res <- writeBlpWith path (BlpEncodeOptions format mipsCount) img + pure $ either (Left . show) Right res Png -> do res <- writeDynamicPng path img pure $ void res diff --git a/blp2any/File.hs b/blp2any/File.hs --- a/blp2any/File.hs +++ b/blp2any/File.hs @@ -1,32 +1,37 @@ module File( forEachFile - , forEachFile' + , tryAll ) where +import Control.Exception +import Control.Monad import System.Directory import System.FilePath -import Control.Monad --- | Performs width traversion of given directory -forEachFile :: FilePath -- ^ Directory to traverse +-- | Fold over the files of a directory that pass a predicate, breadth first. +forEachFile :: Bool -- ^ Whether to descend into subdirectories + -> FilePath -- ^ Directory to traverse -> (FilePath -> Bool) -- ^ File selector - -> (a -> FilePath -> IO a) -- ^ Function to perform (mimics fold) - -> a -- ^ Start value of acum - -> IO a -- ^ Last value of accum -forEachFile path predf f acc = go acc path + -> (a -> FilePath -> IO a) -- ^ Step, called once per file + -> a -- ^ Initial accumulator + -> IO a +forEachFile recurse path predf f acc = go acc path where - go a inputPath = do - names <- fmap (\p -> inputPath ++ "/" ++ p) <$> getDirectoryContents inputPath - dirs <- filter (not . isSystemDir) <$> filterM doesDirectoryExist names + go a dir = do + names <- fmap (dir ) <$> listDirectory dir files <- filter predf <$> filterM doesFileExist names - a' <- foldM f a files - a' `seq` foldM go a' dirs - - isSystemDir s = let bs = takeFileName s in bs == "." || bs == ".." + a' <- foldM f a files + if recurse + then filterM doesDirectoryExist names >>= foldM go a' + else return a' --- | Performs width traversion of given directory, simplified versino of forEachFile -forEachFile' :: FilePath -- ^ Directory to traverse - -> (FilePath -> Bool) -- ^ File selector - -> (FilePath -> IO ()) -- ^ Function to perform - -> IO () -forEachFile' path predf f = forEachFile path predf (const f) () +-- | Run an action, turning any synchronous exception into 'Left'. +-- Asynchronous exceptions (such as Ctrl+C) are rethrown. +tryAll :: IO a -> IO (Either String a) +tryAll action = do + result <- try action + case result of + Right a -> return (Right a) + Left e + | Just async <- fromException e -> throwIO (async :: SomeAsyncException) + | otherwise -> return . Left $ displayException (e :: SomeException) diff --git a/blp2any/Main.hs b/blp2any/Main.hs --- a/blp2any/Main.hs +++ b/blp2any/Main.hs @@ -1,7 +1,10 @@ module Main where +import Data.Version (showVersion) import Options.Applicative.Simple +import qualified Paths_JuicyPixels_blp as Paths + import Statistics import Convert @@ -19,28 +22,28 @@ convertFormatR :: ReadM ConvertFormat convertFormatR = readMPure "format" readConvertFormat --- | How to parse BlpFormat -blpFormatR :: ReadM BlpFormat -blpFormatR = readMPure "blp format" readBlpFormat +-- | How to parse BlpKind +blpKindR :: ReadM BlpKind +blpKindR = readMPure "blp format" readBlpKind main :: IO () main = do (_,runCmd) <- simpleOptions ver headerDesc desc (pure ()) $ do - addCommand "convert" "Converts given blp or folder with blps to PNG" convertFiles $ (<*>) helper $ ConvertOptions + addCommand "convert" "Converts a file or a folder between BLP and PNG, JPEG, TIFF, GIF or BMP" convertFiles $ ConvertOptions <$> strArgument (metavar "INPUT_PATH" <> help "input file or directory (batch mode)") <*> strArgument (metavar "OUTPUT_PATH" <> help "output file name or directory (need explicit format option)") <*> option convertFormatR (long "input-format" <> short 'i' <> value UnspecifiedFormat <> help "Input file format, if not specified tries to infer from input file name. Values: blp png jpg tiff gif bmp.") <*> option convertFormatR (long "format" <> short 'f' <> value UnspecifiedFormat <> help "Output file format, if not specified tries to infer from output file name. Values: blp png jpg tiff gif bmp.") <*> option auto (long "quality" <> short 'q' <> value 90 <> help "Quality level for formats with lossy compression (default 90)") - <*> fmap not (switch (long "notPreserveStructure" <> short 'p' <> help "Will not produce subfolders while batch converting" )) - <*> switch (long "shallow" <> short 's' <> help "Not look into subfolders while batch converting") - <*> option blpFormatR (long "blpFormat" <> short 'b' <> value BlpJpeg <> help "Specifies what BLP internal format to use when converting to BLP. Values: jpg uncompressedWithAlpha uncompressedWithoutAlpha") - <*> option auto (long "min-mipmap-size" <> value 1 <> help "Minimum size of mimmap side to include in resulted BLP file") - addCommand "stats" "Collects statistics about BLP images in folder and saves examples of BLP's for each sample" (uncurry collectStatistics) $ (<*>) helper $ (,) + <*> fmap not (switch (long "flatten" <> long "notPreserveStructure" <> short 'p' <> help "Write every converted file straight into OUTPUT_PATH instead of recreating subfolders (files with the same name overwrite each other)")) + <*> switch (long "shallow" <> short 's' <> help "Only convert files directly in INPUT_PATH, not in its subfolders") + <*> option blpKindR (long "blpFormat" <> short 'b' <> value BlpJpeg <> help "Specifies what BLP internal format to use when converting to BLP. Values: jpg uncompressedWithAlpha uncompressedWithoutAlpha") + <*> option auto (long "min-mipmap-size" <> value 1 <> help "Smallest mipmap side to keep when writing BLP (default 1)") + addCommand "stats" "Groups the BLPs in a folder by header values and saves one example of each group" (uncurry collectStatistics) $ (,) <$> strArgument (metavar "DIRECTORY" <> help "Input folder that stores blps (subfolders are processed)") <*> strArgument (metavar "OUTPUT_PATH" <> help "Here blp samples would be stored") runCmd where - ver = "0.1.0.0" + ver = showVersion Paths.version headerDesc = "" - desc = "Converting BLP1 Warcraft III format to/from PNG, JPEG, TGA, TIFF, BMP, GIF" + desc = "Converting BLP1 Warcraft III textures to/from PNG, JPEG, TIFF, GIF and BMP" diff --git a/blp2any/Statistics.hs b/blp2any/Statistics.hs --- a/blp2any/Statistics.hs +++ b/blp2any/Statistics.hs @@ -10,6 +10,7 @@ import Data.Word import System.Directory import System.FilePath +import System.IO import qualified Data.ByteString as BS import qualified Data.Map.Strict as M @@ -17,7 +18,7 @@ import File -type BlpInfo = (BlpCompression, [BlpFlag], BlpPictureType, Word32) +type BlpInfo = (BlpCompression, Word32, Word32, Word32) type BlpStat = (FilePath, Int) type StatMap = M.Map BlpInfo BlpStat @@ -26,18 +27,21 @@ collectSamples dir = do f <- doesDirectoryExist dir unless f $ fail $ "Provided directory " ++ dir ++ " doesn't exists!" - forEachFile dir ((".blp" ==).takeExtension) collectSample M.empty - -collectSample :: StatMap -> FilePath -> IO StatMap -collectSample stats inputFile = do + forEachFile True dir ((".blp" ==) . takeExtension) collectSample M.empty + +collectSample :: StatMap -> FilePath -> IO StatMap +collectSample stats inputFile = do putStrLn $ "Sampling " ++ inputFile - fc <- BS.readFile inputFile - case parseBlp fc of - Left err -> fail $ inputFile ++ ": " ++ err + result <- tryAll (parseBlp <$> BS.readFile inputFile) + case join result of + Left err -> do + -- One unreadable file should not lose the statistics of the rest. + hPutStrLn stderr $ inputFile ++ ": skipped, " ++ err + return stats Right blp -> return $ adjust' (updateStat inputFile) (blpType blp) stats blpType :: BlpStruct -> BlpInfo -blpType BlpStruct{..} = (blpCompression, blpFlags, blpPictureType, blpPictureSubType) +blpType blp@BlpStruct{..} = (blpCompression blp, blpAlphaBits, blpExtra, blpHasMipmaps) adjust' :: (Maybe BlpStat -> BlpStat) -> BlpInfo -> StatMap -> StatMap adjust' f k m = M.insert k (f $ M.lookup k m) m @@ -49,8 +53,8 @@ printStatistics :: FilePath -> StatMap -> IO () printStatistics dir stats = do createDirectoryIfMissing True dir - forM_ (M.toList stats) $ \((compression, flags, pictureType, pictureSubType), (path, i)) -> do - let postfix = L.intercalate "-" [show compression, show flags, show pictureType, show pictureSubType] + forM_ (M.toList stats) $ \((compression, alphaBits, extra, hasMipmaps), (path, i)) -> do + let postfix = L.intercalate "-" [show compression, "alpha" ++ show alphaBits, "extra" ++ show extra, "mips" ++ show hasMipmaps] copyFile path $ dir ++ "/" ++ dropExtension (takeFileName path) ++ "-" ++ postfix ++ ".blp" putStrLn $ postfix ++ ": " ++ show i ++ " images" diff --git a/docs/format.md b/docs/format.md new file mode 100644 --- /dev/null +++ b/docs/format.md @@ -0,0 +1,175 @@ +# The BLP1 format + +BLP ("Blizzard Picture") is the texture format of Warcraft III (BLP1) and +World of Warcraft (BLP2). This library reads and writes **BLP1**. This page +describes the format as the community has documented it, and states for each +part what the library does with it, including where it falls short. + +Primary sources: + +- [BLP Specifications (WC3)](https://www.hiveworkshop.com/threads/blp-specifications-wc3.279306/) + by Dr Super Good, the most complete account of how Warcraft III treats + BLP files. +- [BLP on wowdev](https://wowdev.wiki/BLP), which covers all three versions. + +The older description by Magos, which this repository used to ship as +`Specification`, gets several fields wrong: the meaning of the header dwords +at `0x08`, `0x14` and `0x18`, and the "inverted alpha" in the palette. The +names below follow the newer sources. + +All values are little-endian. + +## Header + +The header is 156 bytes (`0x9C`) long. + +| Offset | Type | Name | Library field | Meaning | +|---|---|---|---|---| +| `0x00` | `char[4]` | magic | – | `"BLP1"` | +| `0x04` | `uint32` | content | `blpCompression` | `0` = JPEG, `1` = paletted ("direct") | +| `0x08` | `uint32` | alphaBits | `blpAlphaBits` | Alpha depth: 0, 1, 4 or 8 for paletted content, 0 or 8 for JPEG | +| `0x0C` | `uint32` | width | `blpWidth` | Width of mip 0 in pixels | +| `0x10` | `uint32` | height | `blpHeight` | Height of mip 0 in pixels | +| `0x14` | `uint32` | extra | `blpExtra` | No known effect; WorldEdit writes 5 | +| `0x18` | `uint32` | hasMipmaps | `blpHasMipmaps` | `0` = only mip 0, otherwise a full mip chain | +| `0x1C` | `uint32[16]` | mipmapOffset | – | File offset of each mip level | +| `0x5C` | `uint32[16]` | mipmapSize | – | Size in bytes of each mip level | + +What the library does with these fields: + +- **Magic.** Only `BLP1` is accepted. BLP0 and BLP2 are rejected (see + [Not supported](#not-supported)). +- **content.** Values other than 0 and 1 are rejected. The spec suggests + treating them as JPEG; the library is stricter. +- **alphaBits.** Decides whether there is alpha and how it is packed. Values + that are not valid for the content type mean no alpha. On paletted files, + a mip 0 too short to hold the declared alpha list also means no alpha; + some tools declare alpha and then write only the index list. The encoder + writes 8 or 0. +- **extra.** Read and kept, but it has no effect on decoding. The encoder + writes 3 with alpha and 5 without, so that readers which still pick alpha + by this field, as older versions of this library did, read the files + correctly. +- **hasMipmaps.** The decoder ignores it and goes by the mipmap slots. The + encoder writes 5, or 0 when it writes a single level. + +## Mipmaps + +Level `l` of a `w`×`h` texture is `max 1 (w / 2^l)` by `max 1 (h / 2^l)`. +The chain is as long as the **larger** side needs to reach 1×1. For example, +32×8 has six levels: 32×8, 16×4, 8×2, 4×1, 2×1 and 1×1. Unused slots are +zero. + +Warcraft III does not generate missing levels. When `hasMipmaps` is set, it +draws them as transparent black, and a model whose texture lacks them can +fail to load. It also only uses mip levels of at most 512×512; larger levels +are stored but skipped. + +**Decoder.** + +- Width and height must be between 1 and 65535; anything else is an error. +- Slots are read by index from slot 0. The chain ends at the first slot that + is empty, runs past the end of the file, points into the header, or + overlaps an earlier level, and after the last level of the full chain. + This drops garbage in unused slots + ([#7](https://github.com/NCrashed/JuicyPixels-blp/pull/7)), including + slots that repeat the last level. +- `decodeBlpMipmaps` returns the levels up to the first damaged one, so + element `i` is always level `i` + ([#9](https://github.com/NCrashed/JuicyPixels-blp/pull/9), + [#13](https://github.com/NCrashed/JuicyPixels-blp/issues/13)). +- A damaged mip 0 fails the file. + +**Encoder.** + +- It writes as many levels as asked for, at least mip 0 and at most the full + chain down to 1×1. Unused slots are zero, and levels are encoded only + if they are written. Downscaling averages 2×2 blocks, reusing the edge pixel + on odd or one-pixel sides. Colour is weighted by alpha, so transparent + pixels do not darken the edges of sprites; alpha, including the alpha list + of paletted textures, is a plain average. Palette indices take the + top-left pixel of each block + ([#26](https://github.com/NCrashed/JuicyPixels-blp/issues/26)). +- `mipMapsUpTo` counts the levels whose larger side is at least a minimum; + with 1 that is the full chain. +- `blp2any --min-mipmap-size N` with `N > 1` writes a deliberately short + chain. That is fine for interface images, but risky for model + textures, for the reason above. + +## JPEG content (`content = 0`) + +``` +uint32 jpegHeaderSize +uint8 jpegHeader[jpegHeaderSize] +... mip levels at mipmapOffset[i], mipmapSize[i] bytes each +``` + +- **Assembling a level.** Each level is `jpegHeader ++ mipData`, a complete + four-component JFIF stream. +- **Components.** They are the texture's **B, G, R and A** channels, stored + directly with no colour transform. The stream has no Adobe marker, so + general JPEG decoders report it as CMYK. The library maps the components + across unchanged ([#11](https://github.com/NCrashed/JuicyPixels-blp/pull/11), + [#17](https://github.com/NCrashed/JuicyPixels-blp/issues/17)). +- **Frame size.** The decoder reads each level's frame size before decoding + it. A frame larger than the level is treated as damage, which also stops a + forged frame header from making the decoder allocate gigabytes. A smaller + frame is padded with transparent black to the level size, as Warcraft III + does. +- **JuicyPixels.** The JPEG streams themselves are decoded by JuicyPixels. + Errors it raises are turned into `Left`, but some corrupt streams make it + loop forever + ([Juicy.Pixels#230](https://github.com/haskell-github-trust/Juicy.Pixels/issues/230)), + so decoding untrusted files needs a timeout. +- **Header size.** Warcraft III crashes on a `jpegHeaderSize` above 624. + The encoder shares the longest common prefix of all levels, up to 624 + bytes, and leaves every level at least one byte of its own + ([#18](https://github.com/NCrashed/JuicyPixels-blp/issues/18)). +- **Unused alpha plane.** Without alpha, the plane should be all `0xFF`, and + the encoder writes it that way. Tools in the wild fill an unused plane with + either all `0x00` or all `0xFF`. The decoder therefore treats a plane that + is entirely `0x00` or entirely `0xFF` as opaque, and uses any other plane, + including a uniformly semi-transparent one, as it is. +- **Other JPEG kinds.** Streams that are not four-component, such as + greyscale or YCbCr, are decoded as ordinary JPEG. + +## Paletted content (`content = 1`) + +``` +uint32 palette[256] -- 0x00RRGGBB, stored as B, G, R, padding +per mip level: + uint8 index[w * h] -- palette index per pixel, rows top to bottom + uint8 alpha[(w * h * alphaBits + 7) / 8] +``` + +- **Palette padding byte.** The fourth byte of each palette entry is padding + and carries no alpha. The decoder ignores it + ([#14](https://github.com/NCrashed/JuicyPixels-blp/issues/14)). +- **Alpha.** Alpha values are packed least-significant bit first. The + decoder handles 1, 4 and 8 bits and scales them to 0–255; the encoder + writes 8-bit alpha. +- **Short palettes.** Palettes shorter than 256 entries, where the first mip + starts earlier than `0x9C + 1024`, are accepted and padded + ([#6](https://github.com/NCrashed/JuicyPixels-blp/pull/6)). +- **Encoder.** It quantises colours to 256 with JuicyPixels' median-cut + palette and dithering, and writes 8-bit alpha or none. + +## Deviations found in real files + +The decoder accepts these, besides the ones mentioned above: + +| Deviation | Handling | +|---|---| +| Unusual `extra` values, such as 6 on WoW assets ported to Warcraft III and 0 from community tools | ignored ([#5](https://github.com/NCrashed/JuicyPixels-blp/pull/5), [#10](https://github.com/NCrashed/JuicyPixels-blp/pull/10)) | +| `alphaBits` declared, but mip 0 holds only the index list | read as without alpha ([#8](https://github.com/NCrashed/JuicyPixels-blp/pull/8)) | +| Garbage in unused mipmap slots | slot skipped ([#7](https://github.com/NCrashed/JuicyPixels-blp/pull/7)) | +| Truncated or corrupt tail mipmaps | levels before it kept ([#9](https://github.com/NCrashed/JuicyPixels-blp/pull/9)) | + +## Not supported + +- **BLP0**, which stores each mip level in a separate `.b00` … `.b15` file. +- **BLP2**, the World of Warcraft variant with DXT compression + ([#3](https://github.com/NCrashed/JuicyPixels-blp/issues/3)). +- **Writing 1-bit or 4-bit alpha**, or a chosen `extra` or `hasMipmaps` + value, through the public encoders. `Codec.Picture.Blp.Internal.Encoder` + can write any `BlpStruct`. 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 @@ -13,6 +13,9 @@ > Right img <- readBlp "war3mapMap.blp" > writePng "war3mapMap.png" (convertRGBA8 img) +> +> Right png <- readImage "icon.png" +> result <- writeBlpWith "icon.blp" defaultBlpEncodeOptions png -} module Codec.Picture.Blp( -- * Decoding @@ -21,22 +24,30 @@ , decodeBlp , decodeBlpMipmaps -- * Encoding - -- | The mipmap count passed to the encoders is the number of levels to - -- write, mip 0 included. It is clamped to at least one, and asking for - -- more levels than the image has stops at the level where a side reaches - -- one pixel. 'mipMapsUpTo' computes it from a minimum side length. + , encodeBlpWith + , writeBlpWith + , BlpEncodeOptions(..) + , defaultBlpEncodeOptions + , BlpFormat(..) + , BlpEncodeError(..) + , mipMapsUpTo + -- * Deprecated encoders + -- | These predate 'encodeBlpWith'. They clamp the JPEG quality to 1..100 + -- and throw on images 'encodeBlpWith' rejects. , writeBlpJpeg , writeBlpUncompressedWithAlpha , writeBlpUncompressedWithoutAlpha , encodeBlpJpeg , encodeBlpUncompressedWithAlpha , encodeBlpUncompressedWithoutAlpha - , mipMapsUpTo ) where import Codec.Picture -import Data.Bits (shiftR) +import Control.DeepSeq (force) +import Control.Exception +import Data.Bits ((.&.), shiftR) import Data.ByteString (ByteString) +import System.IO.Unsafe (unsafeDupablePerformIO) import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BSL @@ -76,118 +87,182 @@ let width = fromIntegral $ blpWidth blp height = fromIntegral $ blpHeight blp case blpExt blp of - BlpJpeg {..} -> do - let jpegs = (blpJpegHeader <>) `fmap` blpJpegData - case jpegs of - [] -> Left "No JPEG mipmap data in BLP" - (j0:js) -> do - -- Mipmap 0 is the full-resolution image; single-image callers - -- (`decodeBlp`) only ever take `head` of the result. Decoding it - -- strictly means a failure here still fails the whole file as - -- before. Tail mipmaps are decoded lazily and the chain stops at the - -- first one that fails, so a corrupt tail can no longer poison the - -- main image, and the result stays a prefix of the mip levels - -- (index i is always level i). - mip0 <- decodeJpeg j0 - let validPrefix (j:rest) | Right m <- decodeJpeg j = m : validPrefix rest - validPrefix _ = [] - lazyTail = validPrefix js - -- The alpha decision is taken once, from the full size mipmap, so that - -- every mipmap of a texture is decoded the same way. Smaller mipmaps - -- are often padded out with a flat alpha plane of their own. - useAlpha = BlpFlagAlphaChannel `elem` blpFlags blp && jpegAlphaIsUsable mip0 - Right $ fromBlpJpeg useAlpha <$> (mip0 : lazyTail) - - BlpUncompressed1 {..} -> uncompressedLevels width height fits render blpU1MipMaps + BlpJpeg {..} -> case blpJpegData of + [] -> Left "No JPEG mipmap data in BLP" + level0 : rest -> do + -- Mipmap 0 is the full-resolution image; a failure there fails the + -- file. Tail mipmaps are decoded lazily and the chain stops at the + -- first one that fails, so a corrupt tail costs only the levels from + -- it on, and element i stays level i. + mip0 <- decodeLevel 0 level0 + let validPrefix l (j : js) | Right m <- decodeLevel l j = m : validPrefix (l + 1) js + validPrefix _ _ = [] + -- The alpha decision is taken once, from the full size mipmap, so that + -- every mipmap of a texture is decoded the same way. Smaller mipmaps + -- are often padded out with a flat alpha plane of their own. + useAlpha = blpAlphaBits blp == 8 && jpegAlphaIsUsable mip0 + Right $ toLevel useAlpha <$> zip [0 ..] (mip0 : validPrefix 1 rest) where - fits n (indexList, alphaList) = BS.length indexList >= n && BS.length alphaList >= n - render w (indexList, alphaList) x y = let - i = y * w + x - PixelRGBA8 r g b _ = blpU1Palette V.! fromIntegral (indexList `BS.index` i) - in PixelRGBA8 b g r (alphaList `BS.index` i) + -- The frame size is checked before decoding: JuicyPixels allocates the + -- whole image up front, so a forged frame header could otherwise ask + -- for gigabytes. A frame larger than the level is rejected; a smaller + -- one is padded with transparent black, as Warcraft III does. + decodeLevel :: Int -> ByteString -> Either String DynamicImage + decodeLevel l level = do + let jpeg = blpJpegHeader <> level + (lw, lh) = levelSize width height l + (fw, fh) <- maybe (Left $ "JPEG mipmap " ++ show l ++ " has no frame header") Right (jpegFrameSize jpeg) + if fw > lw || fh > lh + then Left $ "JPEG mipmap " ++ show l ++ " is " ++ show fw ++ "x" ++ show fh + ++ ", larger than its level size " ++ show lw ++ "x" ++ show lh + else safeDecodeJpeg jpeg + toLevel useAlpha (l, img) = let + (lw, lh) = levelSize width height l + rgba = convertRGBA8 (fromBlpJpeg useAlpha img) + in ImageRGBA8 $ if imageWidth rgba == lw && imageHeight rgba == lh + then rgba + else generateImage (\x y -> if x < imageWidth rgba && y < imageHeight rgba + then pixelAt rgba x y else PixelRGBA8 0 0 0 0) lw lh - BlpUncompressed2 {..} -> uncompressedLevels width height fits render blpU2MipMaps + BlpPaletted {..} -> palettedLevels width height alphaBits blpPalette blpPalettedMipMaps where - fits n indexList = BS.length indexList >= n - render w indexList x y = let - PixelRGBA8 r g b _ = blpU2Palette V.! fromIntegral (indexList `BS.index` (y * w + x)) - -- Without-alpha textures have no alpha to decode; the palette's fourth - -- byte is not alpha and tools fill it inconsistently. - in PixelRGBA8 b g r 255 + -- Alpha depth as declared, if valid for paletted content. A mip 0 too + -- short to hold that much alpha has none: some tools declare alpha and + -- then write only the index list. + declared = case blpAlphaBits blp of + b | b `elem` [1, 4, 8] -> fromIntegral b + _ -> 0 + alphaBits = case blpPalettedMipMaps of + mip0 : _ | BS.length mip0 < levelBytes (width * height) declared -> 0 + _ -> declared --- | Render the mipmaps of an uncompressed BLP. Level @l@ of a @w@ x @h@ --- texture is @w / 2^l@ by @h / 2^l@, but never smaller than 1x1. The list --- stops at the first level whose buffer is too short for its size, so the --- result is always a prefix of the mip levels; a short level 0 fails the file. -uncompressedLevels :: Int -> Int - -> (Int -> mip -> Bool) -- ^ Does the buffer hold this many pixels? - -> (Int -> mip -> Int -> Int -> PixelRGBA8) -- ^ Pixel at (x, y) of a level of given width - -> [mip] - -> Either String [DynamicImage] -uncompressedLevels width height fits render mips +-- | Size of mip level @l@ of a @w@ x @h@ texture: each side halved @l@ times, +-- but never below one pixel. +levelSize :: Int -> Int -> Int -> (Int, Int) +levelSize w h l = (max 1 (w `shiftR` l), max 1 (h `shiftR` l)) + +-- | 'decodeJpeg', with errors JuicyPixels raises from pure code turned into +-- 'Left'. Asynchronous exceptions are rethrown. +safeDecodeJpeg :: ByteString -> Either String DynamicImage +safeDecodeJpeg jpeg = unsafeDupablePerformIO $ do + result <- try (evaluate (force (decodeJpeg jpeg))) + case result of + Right decoded -> return decoded + Left e + | Just async <- fromException e -> throwIO (async :: SomeAsyncException) + | otherwise -> return . Left $ "JPEG decoding failed: " ++ displayException (e :: SomeException) + +-- | Bytes a paletted mip level of @n@ pixels takes: the index list and the +-- alpha list. +levelBytes :: Int -> Int -> Int +levelBytes n alphaBits = n + (n * alphaBits + 7) `div` 8 + +-- | Render the mipmaps of a paletted BLP. Level @l@ of a @w@ x @h@ texture is +-- @w / 2^l@ by @h / 2^l@, but never smaller than 1x1. The list stops at the +-- first level whose data is too short for its size, so the result is always a +-- prefix of the mip levels; a short level 0 fails the file. +palettedLevels :: Int -> Int -> Int -> V.Vector PixelRGBA8 -> [ByteString] -> Either String [DynamicImage] +palettedLevels width height alphaBits palette mips | null mips = Right [] | otherwise = case go 0 mips of [] -> Left "Mipmap 0 is too short for the image size" levels -> Right levels where go l (mip : rest) - | fits (w * h) mip = ImageRGBA8 (generateImage (render w mip) w h) : go (l + 1) rest + | BS.length mip >= levelBytes (w * h) alphaBits = + ImageRGBA8 (generateImage (pixel w (BS.drop (w * h) mip) mip) w h) : go (l + 1) rest where - w = levelSide width l - h = levelSide height l + (w, h) = levelSize width height l go _ _ = [] - levelSide side l = if side <= 0 then 0 else max 1 (side `shiftR` l) --- | Number of mip levels, mip 0 included, whose smaller side is at least the --- given length; never less than one. Pass it to the encoders as the mipmap --- count. A 16x16 texture has five levels down to 1 pixel and three down to --- 4 pixels. + -- The palette's fourth byte is padding, not alpha. + pixel w alphas indices x y = let + i = y * w + x + PixelRGBA8 r g b _ = palette V.! fromIntegral (indices `BS.index` i) + in PixelRGBA8 b g r (alphaAt alphas i) + + -- Alpha values are packed least significant bit first. + alphaAt alphas i = case alphaBits of + 8 -> alphas `BS.index` i + 4 -> 17 * ((alphas `BS.index` (i `div` 2) `shiftR` (4 * (i `mod` 2))) .&. 0x0f) + 1 -> 255 * ((alphas `BS.index` (i `div` 8) `shiftR` (i `mod` 8)) .&. 1) + _ -> 255 + +-- | Number of mip levels, mip 0 included, whose larger side is at least the +-- given length; never less than one and at most 16. Use it as 'blpMipLevels'. +-- With 1 that is the full chain down to 1x1: five levels for 16x16, seven +-- for 64x16. With 4, a 16x16 texture keeps three levels. mipMapsUpTo :: Int -- ^ Smallest side length to keep (2, 4, 16, ...) -> DynamicImage -- ^ Image the mipmaps are made for -> Int -mipMapsUpTo minSize img = max 1 . length . takeWhile (>= max 1 minSize) $ iterate (`div` 2) minSide +mipMapsUpTo minSize img = max 1 . min 16 . length . takeWhile (>= max 1 minSize) $ iterate (`div` 2) larger where - minSide = min (dynamicMap imageWidth img) (dynamicMap imageHeight img) + larger = max (dynamicMap imageWidth img) (dynamicMap imageHeight img) +-- | JPEG at quality 90 with the full mip chain. +defaultBlpEncodeOptions :: BlpEncodeOptions +defaultBlpEncodeOptions = BlpEncodeOptions { + blpFormat = BlpFormatJpeg 90 + , blpMipLevels = 16 + } + +-- | Encode an image as a BLP1 file. +encodeBlpWith :: BlpEncodeOptions -> DynamicImage -> Either BlpEncodeError BSL.ByteString +encodeBlpWith BlpEncodeOptions{..} img + | w < 1 || h < 1 = Left BlpEmptyImage + | w > 65535 || h > 65535 = Left $ BlpImageTooLarge w h + | BlpFormatJpeg quality <- blpFormat, quality < 1 || quality > 100 = Left $ BlpInvalidJpegQuality quality + | BSL.length file > 0xFFFFFFFF = Left BlpFileTooLarge + | otherwise = Right file + where + w = dynamicMap imageWidth img + h = dynamicMap imageHeight img + file = encodeBlp (toBlpStruct blpFormat blpMipLevels img) + +-- | Encode an image with 'encodeBlpWith' and write it to a file. +writeBlpWith :: FilePath -> BlpEncodeOptions -> DynamicImage -> IO (Either BlpEncodeError ()) +writeBlpWith fp opts img = traverse (BSL.writeFile fp) (encodeBlpWith opts img) + -- | Encode with 'encodeBlpJpeg' and write the result to a file. writeBlpJpeg :: FilePath -> Int -> Int -> DynamicImage -> IO () -writeBlpJpeg fp quality numMips img = do - let bs = encodeBlpJpeg quality numMips img - BSL.writeFile fp bs +writeBlpJpeg fp quality numMips img = BSL.writeFile fp $ encodeBlpJpeg quality numMips img +{-# DEPRECATED writeBlpJpeg "Use writeBlpWith" #-} -- | Encode with 'encodeBlpUncompressedWithAlpha' and write the result to a file. writeBlpUncompressedWithAlpha :: FilePath -> Int -> DynamicImage -> IO () -writeBlpUncompressedWithAlpha fp numMips img = do - let bs = encodeBlpUncompressedWithAlpha numMips img - BSL.writeFile fp bs +writeBlpUncompressedWithAlpha fp numMips img = BSL.writeFile fp $ encodeBlpUncompressedWithAlpha numMips img +{-# DEPRECATED writeBlpUncompressedWithAlpha "Use writeBlpWith" #-} -- | Encode with 'encodeBlpUncompressedWithoutAlpha' and write the result to a -- file. writeBlpUncompressedWithoutAlpha :: FilePath -> Int -> DynamicImage -> IO () -writeBlpUncompressedWithoutAlpha fp numMips img = do - let bs = encodeBlpUncompressedWithoutAlpha numMips img - BSL.writeFile fp bs +writeBlpUncompressedWithoutAlpha fp numMips img = BSL.writeFile fp $ encodeBlpUncompressedWithoutAlpha numMips img +{-# DEPRECATED writeBlpUncompressedWithoutAlpha "Use writeBlpWith" #-} --- | Encode as a JPEG compressed BLP. The texture gets an alpha plane when the --- input image has an alpha channel. -encodeBlpJpeg :: Int -- ^ JPEG quality, 0 to 100 +-- | Encode as a JPEG compressed BLP; see 'BlpFormatJpeg'. +encodeBlpJpeg :: Int -- ^ JPEG quality, clamped to 1..100 -> Int -- ^ Number of mip levels to write -> DynamicImage -> BSL.ByteString -encodeBlpJpeg quality numMips = encodeBlp numMips . toBlpStruct BlpCompressionJPEG quality numMips +encodeBlpJpeg quality numMips = + orThrow "encodeBlpJpeg" . encodeBlpWith (BlpEncodeOptions (BlpFormatJpeg (max 1 (min 100 quality))) numMips) +{-# DEPRECATED encodeBlpJpeg "Use encodeBlpWith with BlpFormatJpeg" #-} --- | Encode as an uncompressed paletted BLP with an alpha plane. An input --- without alpha gets a fully opaque plane. Colours are quantised to 256. +-- | Encode with a 256 colour palette and 8-bit alpha; see 'BlpFormatPaletted'. encodeBlpUncompressedWithAlpha :: Int -- ^ Number of mip levels to write -> DynamicImage -> BSL.ByteString encodeBlpUncompressedWithAlpha numMips = - encodeBlp numMips . toBlpStruct BlpCompressionUncompressed 100 numMips . ImageRGBA8 . convertRGBA8 + orThrow "encodeBlpUncompressedWithAlpha" . encodeBlpWith (BlpEncodeOptions (BlpFormatPaletted True) numMips) +{-# DEPRECATED encodeBlpUncompressedWithAlpha "Use encodeBlpWith with BlpFormatPaletted True" #-} --- | Encode as an uncompressed paletted BLP without alpha. The alpha channel --- of the input, if any, is dropped. Colours are quantised to 256. +-- | Encode with a 256 colour palette and no alpha; see 'BlpFormatPaletted'. encodeBlpUncompressedWithoutAlpha :: Int -- ^ Number of mip levels to write -> DynamicImage -> BSL.ByteString encodeBlpUncompressedWithoutAlpha numMips = - encodeBlp numMips . toBlpStruct BlpCompressionUncompressed 100 numMips . ImageRGB8 . convertRGB8 + orThrow "encodeBlpUncompressedWithoutAlpha" . encodeBlpWith (BlpEncodeOptions (BlpFormatPaletted False) numMips) +{-# DEPRECATED encodeBlpUncompressedWithoutAlpha "Use encodeBlpWith with BlpFormatPaletted False" #-} + +orThrow :: String -> Either BlpEncodeError a -> a +orThrow name = either (\e -> error $ name ++ ": " ++ show e) id diff --git a/src/Codec/Picture/Blp/Internal/Convert.hs b/src/Codec/Picture/Blp/Internal/Convert.hs --- a/src/Codec/Picture/Blp/Internal/Convert.hs +++ b/src/Codec/Picture/Blp/Internal/Convert.hs @@ -1,13 +1,22 @@ +{-| +Pixel conversions between the BGRA planes of BLP1 JPEG content and +JuicyPixels images. + +This is an internal module: its API may change between minor versions. +-} module Codec.Picture.Blp.Internal.Convert( fromBlpJpeg , jpegAlphaIsUsable , toBlpCMYK8 + , opaqueRGBA8 ) where import Codec.Picture -import Codec.Picture.Types (pixelFold) +import Data.Bits ((.&.)) import Data.Word +import qualified Data.Vector.Storable as VS + -- | Convert a decoded mipmap of a JPEG compressed BLP1 into an image that can -- be written out directly. -- @@ -22,9 +31,7 @@ -- Any other kind of JPEG (greyscale, YCbCr) is converted to RGBA as usual. fromBlpJpeg :: Bool -> DynamicImage -> DynamicImage fromBlpJpeg useAlpha i = case i of - ImageCMYK8 p -> - let rgba = blpJpegToRGBA8 p - in ImageRGBA8 $ if useAlpha then rgba else forceOpaque rgba + ImageCMYK8 p -> ImageRGBA8 $ swapRedBlue (not useAlpha) p _ -> ImageRGBA8 $ convertRGBA8 i -- | Whether the alpha plane of a decoded BLP1 JPEG mipmap carries information. @@ -40,39 +47,41 @@ -- as it stands. jpegAlphaIsUsable :: DynamicImage -> Bool jpegAlphaIsUsable i = case i of - ImageCMYK8 p -> case uniformAlpha (blpJpegToRGBA8 p) of - Just a -> a /= 0 && a /= 255 - Nothing -> True + ImageCMYK8 p + | VS.null planes -> False + | otherwise -> varies 7 || (a0 /= 0 && a0 /= 255) + where + -- The fourth component of every pixel; stops at the first that differs. + planes = imageData p + a0 = VS.unsafeIndex planes 3 + varies j + | j >= VS.length planes = False + | VS.unsafeIndex planes j /= a0 = True + | otherwise = varies (j + 4) _ -> True --- | The alpha value every pixel of an image carries, if they all agree. An --- empty image counts as uniformly opaque. -uniformAlpha :: Image PixelRGBA8 -> Maybe Word8 -uniformAlpha img - | imageWidth img <= 0 || imageHeight img <= 0 = Just 255 - | pixelFold same True img = Just a0 - | otherwise = Nothing - where - PixelRGBA8 _ _ _ a0 = pixelAt img 0 0 - same acc _ _ (PixelRGBA8 _ _ _ a) = acc && a == a0 - -- | Reinterpret the four planes a JPEG decoder labelled CMYK as the BGRA they --- actually are. This inverts 'toBlpCMYK8'. -blpJpegToRGBA8 :: Image PixelCMYK8 -> Image PixelRGBA8 -blpJpegToRGBA8 = pixelMap convert - where - convert (PixelCMYK8 c m y k) = PixelRGBA8 y m c k +-- actually are, optionally making every pixel opaque. This inverts +-- 'toBlpCMYK8'. +swapRedBlue :: Bool -> Image PixelCMYK8 -> Image PixelRGBA8 +swapRedBlue opaque img = Image (imageWidth img) (imageHeight img) (swapBytes opaque (imageData img)) -forceOpaque :: Image PixelRGBA8 -> Image PixelRGBA8 -forceOpaque = pixelMap convert - where - convert (PixelRGBA8 r g b _) = PixelRGBA8 r g b 255 +-- | Swap the first and third byte of every four, optionally setting the +-- fourth to 255. +swapBytes :: Bool -> VS.Vector Word8 -> VS.Vector Word8 +swapBytes opaque src = VS.generate (VS.length src) $ \i -> case i .&. 3 of + 0 -> VS.unsafeIndex src (i + 2) + 2 -> VS.unsafeIndex src (i - 2) + 3 | opaque -> 255 + _ -> VS.unsafeIndex src i +-- | Set the alpha of every pixel to 255. +opaqueRGBA8 :: Image PixelRGBA8 -> Image PixelRGBA8 +opaqueRGBA8 img = img { imageData = VS.imap (\i v -> if i .&. 3 == 3 then 255 else v) (imageData img) } + -- | Lay out the B, G, R and A planes of a texture as the four components of -- a BLP1 JPEG. The encoder labels them CMYK only because that is the -- four-component JPEG it can write; this is the exact inverse of --- @blpJpegToRGBA8@. +-- 'swapRedBlue'. toBlpCMYK8 :: Image PixelRGBA8 -> Image PixelCMYK8 -toBlpCMYK8 = pixelMap convert - where - convert (PixelRGBA8 r g b a) = PixelCMYK8 b g r a +toBlpCMYK8 img = Image (imageWidth img) (imageHeight img) (swapBytes False (imageData img)) 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,9 +1,17 @@ +{-| +The structure of a BLP1 file as the parser reads it and the encoder writes +it. See @docs/format.md@ in the source repository for the full format. + +This is an internal module: its API may change between minor versions. +-} module Codec.Picture.Blp.Internal.Data( BlpStruct(..) + , blpCompression , BlpCompression(..) - , BlpFlag(..) - , BlpPictureType(..) , BlpExt(..) + , BlpFormat(..) + , BlpEncodeOptions(..) + , BlpEncodeError(..) ) where import Codec.Picture @@ -12,41 +20,78 @@ import Data.Word import GHC.Generics +-- | A parsed BLP1 file: the 156 byte header and the image data after it. The +-- content type (header dword @0x04@) follows from 'blpExt', see +-- 'blpCompression'. data BlpStruct = BlpStruct { - blpCompression :: !BlpCompression -, blpFlags :: ![BlpFlag] + -- | Header dword @0x08@: alpha bits per pixel. 0, 1, 4 and 8 are valid for + -- paletted content, 0 and 8 for JPEG; any other value means no alpha. + blpAlphaBits :: !Word32 + -- | Width of mip 0 in pixels. , blpWidth :: !Word32 + -- | Height of mip 0 in pixels. , blpHeight :: !Word32 -, blpPictureType :: !BlpPictureType -, blpPictureSubType :: !Word32 -- is not used + -- | Header dword @0x14@. It has no known effect and is kept as read. +, blpExtra :: !Word32 + -- | Header dword @0x18@: zero means only mip 0 is present. +, blpHasMipmaps :: !Word32 + -- | Everything after the header, including the mip levels. , blpExt :: BlpExt } deriving (Show, Generic) +-- | The part of the file after the header. data BlpExt = + -- | JPEG content. Each mip level is @blpJpegHeader <> level@, a + -- four-component JPEG whose components are B, G, R and A. BlpJpeg { - blpJpegHeader :: !ByteString - , blpJpegData :: ![ByteString] - } - | BlpUncompressed1 { - blpU1Palette :: !(Vector PixelRGBA8) - , blpU1MipMaps :: ![(ByteString, ByteString)] + blpJpegHeader :: !ByteString -- ^ Shared JPEG header, at most 624 bytes + , blpJpegData :: ![ByteString] -- ^ Rest of each mip level, mip 0 first } - | BlpUncompressed2 { - blpU2Palette :: !(Vector PixelRGBA8) - , blpU2MipMaps :: ![ByteString] + -- | Paletted content. Each mip level holds the index list followed by the + -- alpha list, packed at 'blpAlphaBits' bits per pixel; the level's size + -- tells where one ends and the other begins. + | BlpPaletted { + blpPalette :: !(Vector PixelRGBA8) -- ^ 256 entries stored as B, G, R and padding + , blpPalettedMipMaps :: ![ByteString] -- ^ Raw data of each mip level, mip 0 first } deriving (Show, Generic) +-- | Header dword @0x04@. data BlpCompression = - BlpCompressionJPEG - | BlpCompressionUncompressed + BlpCompressionJPEG -- ^ 0: JPEG + | BlpCompressionUncompressed -- ^ 1: 256 colour palette deriving (Eq, Ord, Enum, Bounded, Show, Generic) -data BlpFlag = BlpFlagAlphaChannel - deriving (Eq, Ord, Enum, Bounded, Show, Generic) +-- | Header dword @0x04@ (@content@ in the specification) of a file. +blpCompression :: BlpStruct -> BlpCompression +blpCompression blp = case blpExt blp of + BlpJpeg {} -> BlpCompressionJPEG + BlpPaletted {} -> BlpCompressionUncompressed -data BlpPictureType = - JPEGType - | UncompressedWithAlpha - | UncompressedWithoutAlpha - deriving (Eq, Ord, Enum, Bounded, Show, Generic) +-- | How to encode a texture. +data BlpFormat = + -- | JPEG with the given quality, from 1 to 100. The texture gets alpha + -- when the image has an alpha channel. + BlpFormatJpeg !Int + -- | 256 colour palette, with 8-bit alpha or without alpha. Colours are + -- quantised with dithering. + | BlpFormatPaletted !Bool + deriving (Eq, Show) + +-- | Options for encoding a texture. +data BlpEncodeOptions = BlpEncodeOptions { + -- | Content type and its settings. + blpFormat :: !BlpFormat + -- | Number of mip levels to write, mip 0 included. Values below 1 mean 1, + -- and values above what the image has mean the full chain down to 1x1 + -- (at most 16 levels). +, blpMipLevels :: !Int +} deriving (Eq, Show) + +-- | Why an image cannot be encoded. +data BlpEncodeError = + BlpEmptyImage -- ^ The image has a side of zero pixels. + | BlpImageTooLarge !Int !Int -- ^ Width or height is above 65535, the format's limit. + | BlpInvalidJpegQuality !Int -- ^ JPEG quality outside 1 to 100. + | BlpFileTooLarge -- ^ The file would exceed 4 GiB, the most its offsets can address. + deriving (Eq, Show) 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 @@ -1,11 +1,16 @@ +{-| +Building and serialising BLP1 files: palette quantisation, the mip chain, the +shared JPEG header and the binary layout. + +This is an internal module: its API may change between minor versions. +-} module Codec.Picture.Blp.Internal.Encoder( encodeBlp , blpEncoder + , toBlpStruct , createMipMaps , createMipMapsIndexed , scanHeader - , toBlpStruct - , toBlpExt ) where import Codec.Picture @@ -13,97 +18,56 @@ import Codec.Picture.Jpg import Codec.Picture.Types import Data.Binary.Put -import Data.Bits import Data.ByteString.Lazy (ByteString, toStrict) import Data.Foldable (traverse_) import Data.Word -import qualified Codec.Picture.Metadata as CM import qualified Data.ByteString as BS import qualified Data.ByteString.Internal as BI -import qualified Data.Foldable as F import qualified Data.Vector as V import qualified Data.Vector.Storable as VS +import qualified Data.Vector.Storable.Mutable as MVS import Codec.Picture.Blp.Internal.Convert import Codec.Picture.Blp.Internal.Data --- | Convert spare BLP structure into compact stream of bytes -encodeBlp :: Int -> BlpStruct -> ByteString -encodeBlp numMips = runPut . blpEncoder numMips +-- | Serialise a BLP structure. The content type follows from 'blpExt'; at +-- most 16 mip levels are written, and unused slots are zero. +encodeBlp :: BlpStruct -> ByteString +encodeBlp = runPut . blpEncoder -- | Raw encoder for BLP -blpEncoder :: Int -> BlpStruct -> Put -blpEncoder requestedMips BlpStruct{..} = do - putBlpVersion - putCompression - putFlags - putWidth - putHeight - putPictureType - putPictureSubType - putMipMapOffsets - putMipMapSizes - putBlpExt +blpEncoder :: BlpStruct -> Put +blpEncoder BlpStruct{..} = do + putByteString "BLP1" + putWord32le $ case blpExt of + BlpJpeg {} -> 0 + BlpPaletted {} -> 1 + putWord32le blpAlphaBits + putWord32le blpWidth + putWord32le blpHeight + putWord32le blpExtra + putWord32le blpHasMipmaps + traverse_ putWord32le . slots $ take (length levels) (scanl (+) contentStart levelSizes) + traverse_ putWord32le $ slots levelSizes + case blpExt of + BlpJpeg {..} -> do + putWord32le . fromIntegral $ BS.length blpJpegHeader + putByteString blpJpegHeader + BlpPaletted {..} -> + traverse_ putRgba8 . V.take 256 $ blpPalette <> V.replicate 256 (PixelRGBA8 0 0 0 0) + traverse_ putByteString levels where - -- A file without mip 0 has no image at all, so always write it. - numMips = max 1 requestedMips - putBlpVersion = putByteString "BLP1" - putCompression = putWord32le $ case blpCompression of - BlpCompressionJPEG -> 0 - BlpCompressionUncompressed -> 1 - putFlags = let - addFlag acc flag = (acc +) $ case flag of - BlpFlagAlphaChannel -> 1 `shiftL` 3 - in putWord32le $ F.foldl' addFlag 0 blpFlags - putWidth = putWord32le blpWidth - putHeight = putWord32le blpHeight - putPictureType = putWord32le $ case blpPictureType of - JPEGType -> 2 - UncompressedWithAlpha -> 3 - -- UncompressedWithAlpha -> 4 - UncompressedWithoutAlpha -> 5 - putPictureSubType = putWord32le blpPictureSubType - headerSize = 4 -- BLP1 - + 4 -- Compression - + 4 -- Flags - + 4 -- Width - + 4 -- Height - + 4 -- Picture type - + 4 -- Picture subtype - + 16 * 4 -- Mipmaps offsets - + 16 * 4 -- Mipmaps sizes - mipmaps = let - mkOffsetSize :: BS.ByteString -> (Int, [(Word32, Word32)]) -> (Int, [(Word32, Word32)]) - mkOffsetSize bs (!offset, !acc) = (offset + BS.length bs, (fromIntegral offset, fromIntegral $ BS.length bs) : acc) - uncomprStartOffset = headerSize + 4 * 256 - in reverse . snd $ case blpExt of - BlpJpeg{..} -> let - startOffset = headerSize + 4 + BS.length blpJpegHeader - in F.foldr' mkOffsetSize (startOffset, []) $ reverse blpJpegData - BlpUncompressed1{..} -> let - mkOffsetSizeU (indbs, alpbs) (!offset, !acc) = (offset + BS.length indbs + BS.length alpbs, (fromIntegral offset, fromIntegral $ BS.length indbs + BS.length alpbs) : acc) - in F.foldr' mkOffsetSizeU (uncomprStartOffset, []) $ reverse blpU1MipMaps - BlpUncompressed2{..} -> F.foldr' mkOffsetSize (uncomprStartOffset, []) $ reverse blpU2MipMaps - ensureLength _ [] = [] - ensureLength n xs = if length xs < n - then xs ++ replicate (n - length xs) (last xs) - else take n xs - ensureLengthV n a xs = if V.length xs < n then xs <> V.replicate (n - V.length xs) a else V.take n xs - putMipMapOffsets = traverse_ putWord32le . ensureLength 16 . take numMips . fmap fst $ mipmaps - putMipMapSizes = traverse_ putWord32le . ensureLength 16 . take numMips . fmap snd $ mipmaps + headerSize = 156 + levels = take 16 $ case blpExt of + BlpJpeg {..} -> blpJpegData + BlpPaletted {..} -> blpPalettedMipMaps + levelSizes = BS.length <$> levels + contentStart = case blpExt of + BlpJpeg {..} -> headerSize + 4 + BS.length blpJpegHeader + BlpPaletted {} -> headerSize + 4 * 256 + slots xs = take 16 $ (fromIntegral <$> xs) ++ repeat 0 putRgba8 (PixelRGBA8 r g b a) = putWord8 r >> putWord8 g >> putWord8 b >> putWord8 a - putBlpExt = case blpExt of -- TODO: check sync of compression flag and BlpExt - BlpJpeg{..} -> do - putWord32le $ fromIntegral $ BS.length blpJpegHeader - putByteString blpJpegHeader - traverse_ putByteString $ take numMips blpJpegData - BlpUncompressed1{..} -> do - traverse_ putRgba8 . ensureLengthV 256 (PixelRGBA8 0 0 0 0) $ blpU1Palette - traverse_ (\(indbs, alpbs) -> putByteString indbs >> putByteString alpbs) $ take numMips blpU1MipMaps - BlpUncompressed2{..} -> do - traverse_ putRgba8 . ensureLengthV 256 (PixelRGBA8 0 0 0 0) $ blpU2Palette - traverse_ putByteString $ take numMips blpU2MipMaps -- | Return 'True' if given picture format has alpha channel hasAlpha :: DynamicImage -> Bool @@ -114,111 +78,114 @@ ImageRGBA16 _ -> True _ -> False --- | Convert to BLP structure some image with given BLP options and quality (for JPEG compression) -toBlpStruct :: BlpCompression -> Int -> Int -> DynamicImage -> BlpStruct -toBlpStruct compression quality numMips img = BlpStruct { - blpCompression = compression - , blpFlags = if hasAlpha img - then [BlpFlagAlphaChannel] - else [] - , blpWidth = fromIntegral $ dynamicMap imageWidth img - , blpHeight = fromIntegral $ dynamicMap imageHeight img - , blpPictureType = pictype - , blpPictureSubType = 5 -- world edit use this for war3mapMap.blp - , blpExt = toBlpExt compression pictype quality numMips img' +-- | Build the BLP structure for an image with the given format and number of +-- mip levels. The number is clamped to between 1 and the image's full chain, +-- at most 16. The image's size is not checked. +toBlpStruct :: BlpFormat -> Int -> DynamicImage -> BlpStruct +toBlpStruct format requestedLevels img = BlpStruct { + blpAlphaBits = if alpha then 8 else 0 + , blpWidth = fromIntegral width + , blpHeight = fromIntegral height + -- Readers that follow the old description of the format pick alpha by + -- this field (3 or 4 with alpha, 5 without), so keep it consistent. + , blpExtra = if alpha then 3 else 5 + -- WorldEdit writes 5; a single level says it has no mipmaps. + , blpHasMipmaps = if numLevels > 1 then 5 else 0 + , blpExt = case format of + BlpFormatJpeg quality -> toBlpJpg (fromIntegral quality) numLevels alpha rgba + BlpFormatPaletted _ -> toBlpPaletted alpha numLevels (convertRGB8 img) rgba } where - pictype = if hasAlpha img - then UncompressedWithAlpha - else UncompressedWithoutAlpha - img' = convertRGBA8 img - --- | Take only first N mipmaps in list, fill rest with last non-fake mipmap -fakeMipMaps :: Int -- ^ How much true values to preserve (if <= 0, the function does nothing) - -> [a] -- ^ List of mimpaps - -> [a] -- ^ Result with fakes -fakeMipMaps = go Nothing - where - go mprev n xs - | n <= 0 = case mprev of - Nothing -> xs - Just v -> case xs of - [] -> [] - _ : xs' -> v : go (Just v) 0 xs' - | otherwise = case xs of - [] -> [] - x : xs' -> x : go (Just x) (n-1) xs' + alpha = case format of + BlpFormatJpeg _ -> hasAlpha img + BlpFormatPaletted withAlpha -> withAlpha + -- Only built when needed: paletted textures without alpha go from RGB. + rgba = convertRGBA8 img + width = dynamicMap imageWidth img + height = dynamicMap imageHeight img + chainLength = length . takeWhile (>= 1) $ iterate (`div` 2) (max width height) + numLevels = max 1 . min 16 $ min chainLength requestedLevels -- | Scale image to form the sequence of mipmaps. The first element is always the original picture. -- --- The scale procedure assumes that original image has power of 2 sides, that allows to simply pick --- average of 4 pixels. +-- Each level averages 2x2 blocks; on an odd or one-pixel side the last block +-- reuses the edge pixel. Colour is weighted by alpha, so the colour of +-- transparent pixels does not bleed into their neighbours; alpha itself is +-- a plain average. Rounding is to the nearest, ties to even. createMipMaps :: Image PixelRGBA8 -> [Image PixelRGBA8] createMipMaps img = img : go img where - avg' v1 v2 v3 v4 = let - v = fromIntegral v1 + fromIntegral v2 + fromIntegral v3 + fromIntegral v4 :: Double - in round $ v / 4 - avg i x y = let - PixelRGBA8 p00r p00g p00b p00a = pixelAt i (x*2) (y*2) - PixelRGBA8 p10r p10g p10b p10a = pixelAt i (x*2 + 1) (y*2) - PixelRGBA8 p01r p01g p01b p01a = pixelAt i (x*2) (y*2 + 1) - PixelRGBA8 p11r p11g p11b p11a = pixelAt i (x*2 + 1) (y*2 + 1) - in PixelRGBA8 (avg' p00r p10r p01r p11r) (avg' p00g p10g p01g p11g) (avg' p00b p10b p01b p11b) (avg' p00a p10a p01a p11a) - power2Scale i = generateImage (avg i) (downgrade $ imageWidth i) (downgrade $ imageHeight i) - downgrade v = max 1 $ v `div` 2 - go i | imageWidth i <= 1 || imageHeight i <= 1 = [] - | otherwise = let i' = power2Scale i in i' : go i' + go i | imageWidth i <= 1 && imageHeight i <= 1 = [] + | otherwise = let i' = halveRGBA8 i in i' : go i' --- | Scale image to form the sequence of mipmaps. The first element is always the original picture. --- --- The scale procedure assumes that original image has power of 2 sides, that allows to simply pick --- 1 of 4 pixels. +-- | One step of 'createMipMaps': halve both sides, but not below one pixel. +-- On a side that is already one pixel (or odd) the second sample of a block +-- is clamped to the edge. +halveRGBA8 :: Image PixelRGBA8 -> Image PixelRGBA8 +halveRGBA8 (Image w h src) = Image w' h' $ VS.create $ do + dst <- MVS.new (w' * h' * 4) + let pixel x y = do + let x0 = 2 * x + x1 = min (w - 1) (x0 + 1) + y0 = 2 * y + y1 = min (h - 1) (y0 + 1) + o00 = (y0 * w + x0) * 4 + o10 = (y0 * w + x1) * 4 + o01 = (y1 * w + x0) * 4 + o11 = (y1 * w + x1) * 4 + at o = fromIntegral (VS.unsafeIndex src o) :: Int + a00 = at (o00 + 3) + a10 = at (o10 + 3) + a01 = at (o01 + 3) + a11 = at (o11 + 3) + alphaSum = a00 + a10 + a01 + a11 + -- Colour weighted by alpha, or a plain average if all four are + -- transparent. + channel c + | alphaSum == 0 = roundDiv (at (o00 + c) + at (o10 + c) + at (o01 + c) + at (o11 + c)) 4 + | otherwise = roundDiv (at (o00 + c) * a00 + at (o10 + c) * a10 + at (o01 + c) * a01 + at (o11 + c) * a11) alphaSum + out = (y * w' + x) * 4 + MVS.unsafeWrite dst out (channel 0) + MVS.unsafeWrite dst (out + 1) (channel 1) + MVS.unsafeWrite dst (out + 2) (channel 2) + MVS.unsafeWrite dst (out + 3) (roundDiv alphaSum 4) + loop y x + | y >= h' = return () + | x >= w' = loop (y + 1) 0 + | otherwise = pixel x y >> loop y (x + 1) + loop 0 0 + return dst + where + w' = max 1 (w `div` 2) + h' = max 1 (h `div` 2) + -- Nearest, ties to even. + roundDiv :: Int -> Int -> Word8 + roundDiv n d = let + (q, r) = n `divMod` d + in fromIntegral $ if 2 * r > d || (2 * r == d && odd q) then q + 1 else q + +-- | Scale image to form the sequence of mipmaps, down to 1x1. The first +-- element is always the original picture. Each level takes the top-left pixel +-- of every 2x2 block, as averaging palette indices makes no sense. createMipMapsIndexed :: Pixel a => Image a -> [Image a] createMipMapsIndexed img = img : go img where power2Scale i = generateImage (\x y -> pixelAt i (x*2) (y*2)) (downgrade $ imageWidth i) (downgrade $ imageHeight i) downgrade v = max 1 $ v `div` 2 - go i | imageWidth i <= 1 || imageHeight i <= 1 = [] + go i | imageWidth i <= 1 && imageHeight i <= 1 = [] | otherwise = let i' = power2Scale i in i' : go i' --- | Convert picture to BLP payload -toBlpExt :: BlpCompression -> BlpPictureType -> Int -> Int -> Image PixelRGBA8 -> BlpExt -toBlpExt compr pictype quality numMips img = case compr of - BlpCompressionJPEG -> toBlpJpg (fromIntegral quality) numMips keepAlpha img - BlpCompressionUncompressed -> case pictype of - UncompressedWithAlpha -> toBlpUncompressed1 numMips img - UncompressedWithoutAlpha -> toBlpUncompressed2 numMips img - JPEGType -> toBlpUncompressed2 numMips img -- Consider this as without alpha - where - keepAlpha = case pictype of - UncompressedWithAlpha -> True - _ -> False - -- | Convert picture to BLP JPEG and create mipmaps toBlpJpg :: Word8 -> Int -> Bool -> Image PixelRGBA8 -> BlpExt -toBlpJpg quality numMips keepAlpha img = BlpJpeg { +toBlpJpg quality numLevels keepAlpha img = BlpJpeg { blpJpegHeader = header - , blpJpegData = mipmapsRawWithoutHeader + , blpJpegData = BS.drop (BS.length header) <$> streams } where - processAlpha :: Image PixelRGBA8 -> Image PixelRGBA8 - processAlpha = pixelMap $ \p@(PixelRGBA8 r g b _) -> if keepAlpha then p else PixelRGBA8 r g b 255 - - mipmaps :: [Image PixelCMYK8] - mipmaps = toBlpCMYK8 <$> (fakeMipMaps numMips . createMipMaps . processAlpha $ img) - - metadata :: CM.Metadatas - metadata = CM.insert (CM.Unknown "JPEG Quality") (CM.Int $ fromIntegral quality) mempty - - mipmapsRaw :: [BS.ByteString] - mipmapsRaw = toStrict . encodeDirectJpegAtQualityWithMetadata quality metadata <$> mipmaps - - header :: BS.ByteString - header = scanHeader 624 mipmapsRaw - - mipmapsRawWithoutHeader :: [BS.ByteString] - mipmapsRawWithoutHeader = BS.drop (BS.length header) <$> mipmapsRaw + opaque = if keepAlpha then id else opaqueRGBA8 + levels = take numLevels . createMipMaps . opaque $ img + streams = toStrict . encodeDirectJpegAtQualityWithMetadata quality mempty . toBlpCMYK8 <$> levels + header = scanHeader 624 streams -- | Manually scan shared prefix of each mipmap scanHeader :: Int -> [BS.ByteString] -> BS.ByteString @@ -234,8 +201,8 @@ sameAt i = all (\m -> BS.index m i == BS.index m0 i) mipmaps -- | Helper to quantise colors to 256 colour pallete -makePallette :: Image PixelRGBA8 -> (Image Pixel8, Palette) -makePallette = palettize defaultPaletteOptions . pixelMap dropTransparency +makePallette :: Image PixelRGB8 -> (Image Pixel8, Palette) +makePallette = palettize defaultPaletteOptions -- | Convert palette to format that we need for BLP convertPalette :: Palette -> V.Vector PixelRGBA8 @@ -249,36 +216,23 @@ -- Shares the image buffer without copying; the ByteString keeps it alive. in BI.fromForeignPtr fptr 0 l --- | Convert picture to BLP uncompressed with alpha and create mipmaps -toBlpUncompressed1 :: Int -> Image PixelRGBA8 -> BlpExt -toBlpUncompressed1 numMips img = BlpUncompressed1 { - blpU1Palette = convertPalette palette - , blpU1MipMaps = fmap convertIndexed mipmaps `zip` fmap convertIndexed alphaMaps +-- | Quantise a picture to a 256 colour palette and create mipmaps, with an +-- 8-bit alpha list after each index list when asked to keep alpha. +toBlpPaletted :: Bool -> Int -> Image PixelRGB8 -> Image PixelRGBA8 -> BlpExt +toBlpPaletted keepAlpha numLevels rgb rgba = BlpPaletted { + blpPalette = convertPalette palette + , blpPalettedMipMaps = if keepAlpha + then zipWith (<>) (convertIndexed <$> mipmaps) (convertIndexed <$> alphaMaps) + else convertIndexed <$> mipmaps } where img' :: Image Pixel8 palette :: Palette - (img', palette) = makePallette img - - alphaImg :: Image Pixel8 - alphaImg = extractComponent PlaneAlpha img + (img', palette) = makePallette rgb mipmaps :: [Image Pixel8] - mipmaps = fakeMipMaps numMips $ createMipMapsIndexed img' + mipmaps = take numLevels $ createMipMapsIndexed img' + -- Alpha is coverage, not an index, so its mipmaps are averaged. alphaMaps :: [Image Pixel8] - alphaMaps = fakeMipMaps numMips $ createMipMapsIndexed alphaImg - --- | Convert picture to BLP uncompressed without alpha and create mipmaps -toBlpUncompressed2 :: Int -> Image PixelRGBA8 -> BlpExt -toBlpUncompressed2 numMips img = BlpUncompressed2 { - blpU2Palette = convertPalette palette - , blpU2MipMaps = convertIndexed <$> mipmaps - } - where - img' :: Image Pixel8 - palette :: Palette - (img', palette) = makePallette img - - mipmaps :: [Image Pixel8] - mipmaps = fakeMipMaps numMips $ createMipMapsIndexed img' + alphaMaps = take numLevels $ extractComponent PlaneAlpha <$> createMipMaps rgba 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,98 +1,104 @@ +{-| +Parser for BLP1 files. It reads the header with attoparsec and takes the +content (JPEG header, palette, mip levels) straight from the slots the header +points at; turning the content into images is done in "Codec.Picture.Blp". + +This is an internal module: its API may change between minor versions. +-} module Codec.Picture.Blp.Internal.Parser( - blpParser + parseBlp , blpVersion , dword , compressionParser - , flagsParser - , pictureTypeParser - , blpJpegParser - , getPos - , skipToOffset - , blpUncompressed1Parser - , blpUncompressed2Parser - , parseBlp + , maxSide + , mipChainLength + , mipLevels + , jpegFrameSize ) where import Codec.Picture -import Control.Monad -import Data.Attoparsec.ByteString as AT +import Data.Attoparsec.ByteString (Parser, parseOnly, string, count, ()) +import qualified Data.Attoparsec.ByteString as AT import Data.Bits import Data.ByteString (ByteString) -import Data.List (nub, sortOn) import Data.Word import qualified Data.Vector as V -import qualified Data.Attoparsec.Internal.Types as AT import qualified Data.ByteString as BS import Codec.Picture.Blp.Internal.Data -blpParser :: Int -> Parser BlpStruct -blpParser inputLen = do +-- | Size of the fixed BLP1 header in bytes. +headerSize :: Int +headerSize = 156 + +-- | Largest width or height the format allows. +maxSide :: Int +maxSide = 65535 + +-- | Parse a BLP1 file into its header and raw content. +-- +-- Width and height must be between 1 and 'maxSide'. Mip levels are taken +-- slot by slot, see 'mipLevels'. +parseBlp :: ByteString -> Either String BlpStruct +parseBlp input = do + (mkStruct, compression, width, height, slots) <- parseOnly headerParser input + let w = fromIntegral width + h = fromIntegral height + if w < 1 || h < 1 || w > maxSide || h > maxSide + then Left $ "Invalid image size " ++ show width ++ "x" ++ show height + else Right () + let levelsFrom start = mipLevels (BS.length input) start (mipChainLength w h) slots + slice (offset, size) = BS.take size (BS.drop offset input) + fmap mkStruct $ case compression of + BlpCompressionJPEG -> do + jpegHeaderSize <- parseOnly (AT.take headerSize *> dword "jpeg header size") input + let headerEnd = headerSize + 4 + fromIntegral jpegHeaderSize + if headerEnd > BS.length input + then Left "jpeg header: not enough input" + else Right BlpJpeg { + blpJpegHeader = slice (headerSize + 4, fromIntegral jpegHeaderSize) + , blpJpegData = slice <$> levelsFrom headerEnd + } + BlpCompressionUncompressed -> do + let levels = levelsFrom headerSize + -- Some tools write only the palette entries they use, so the + -- palette ends where mip 0 starts. Missing entries are padded + -- with transparent black, so any index stays valid. + paletteEnd = case levels of + (offset, _) : _ -> min offset (headerSize + 1024) + [] -> headerSize + 1024 + paletteBytes = slice (headerSize, paletteEnd - headerSize) + entries = BS.length paletteBytes `div` 4 + entry i = let b k = BS.index paletteBytes (4 * i + k) + in PixelRGBA8 (b 0) (b 1) (b 2) (b 3) + Right BlpPaletted { + blpPalette = V.generate 256 $ \i -> + if i < entries then entry i else PixelRGBA8 0 0 0 0 + , blpPalettedMipMaps = slice <$> levels + } + +-- | The fixed header: a function completing the struct with its content, +-- plus the fields needed to read the content. +headerParser :: Parser (BlpExt -> BlpStruct, BlpCompression, Word32, Word32, [(Word32, Word32)]) +headerParser = do _ <- blpVersion - blpCompression <- compressionParser - blpFlags <- flagsParser + compression <- compressionParser + blpAlphaBits <- dword "alpha bits" blpWidth <- dword "width" blpHeight <- dword "height" - blpPictureType <- pictureTypeParser - blpPictureSubType <- dword "picture subtype" - blpMipMapOffset <- replicateM 16 dword "mipmaps offsets" - blpMipMapSize <- replicateM 16 dword "mipmaps sizes" - -- BLP1 specifies 16 mipmap slots but most files only use a handful; the - -- unused slots should be zero but some real-world files contain garbage - -- offsets/sizes left behind by the writing tool. Drop any slot whose - -- advertised range would run past the end of the file, then sort the - -- survivors by offset so that the monotonic `skipToOffset` walks forward - -- correctly even if the file stored mipmaps out of order. - let rawMipMapsInfo = nub . filter ((> 0) . snd) $ blpMipMapOffset `zip` blpMipMapSize - fitsInput (o, s) = - fromIntegral o + fromIntegral s <= (fromIntegral inputLen :: Integer) - -- Sorting is not enough on its own. `skipToOffset` only ever moves - -- forward, so a slot starting inside a range that has already been - -- consumed can never be reached: the skip stays where it is, the - -- following `take` reads the wrong bytes, and every later mipmap is - -- dragged forward until the walk runs off the end of the file. Slots - -- holding garbage that points back into mipmap 0 are common enough in - -- the wild to matter, so keep only a forward-progressing run. - dropOverlapping :: Integer -> [(Word32, Word32)] -> [(Word32, Word32)] - dropOverlapping _ [] = [] - dropOverlapping end (slot@(o, s) : rest) - | fromIntegral o >= end = - slot : dropOverlapping (fromIntegral o + fromIntegral s) rest - | otherwise = dropOverlapping end rest - mipMapsInfo = - dropOverlapping 0 . sortOn fst . filter fitsInput $ rawMipMapsInfo - -- Some writing tools set `pictureType` to `UncompressedWithAlpha` on - -- files whose mipmap 0 is actually only large enough for a single - -- index plane (w*h bytes) rather than indices + alpha (2*w*h bytes). - -- Trust the physical size over the picture-type byte and decode those - -- files via the without-alpha path instead of crashing on a half-read - -- index list. Anything short of 2*w*h cannot hold both planes, so the - -- check is a range rather than an exact match. - let pixels0 :: Integer - pixels0 = fromIntegral blpWidth * fromIntegral blpHeight - mipZeroSize = case mipMapsInfo of - ((_, s):_) -> fromIntegral s :: Integer - [] -> 0 - mislabeledAsAlpha = - blpPictureType == UncompressedWithAlpha && - pixels0 > 0 && - mipZeroSize >= pixels0 && - mipZeroSize < 2 * pixels0 - effectivePictureType = - if mislabeledAsAlpha then UncompressedWithoutAlpha else blpPictureType - blpExt <- case blpCompression of - BlpCompressionJPEG -> blpJpegParser mipMapsInfo - BlpCompressionUncompressed -> case effectivePictureType of - JPEGType -> fail "JPEG type with Uncompressed type mix" - UncompressedWithAlpha -> blpUncompressed1Parser mipMapsInfo - UncompressedWithoutAlpha -> blpUncompressed2Parser mipMapsInfo - - return $ BlpStruct {..} + blpExtra <- dword "extra" + blpHasMipmaps <- dword "has mipmaps" + offsets <- count 16 dword "mipmaps offsets" + sizes <- count 16 dword "mipmaps sizes" + let mkStruct blpExt = BlpStruct {..} + return (mkStruct, compression, blpWidth, blpHeight, offsets `zip` sizes) +-- | The @BLP1@ magic. BLP0 and BLP2 files fail here. blpVersion :: Parser ByteString blpVersion = string "BLP1" "BLP1 version tag" +-- | A little-endian 32-bit word. dword :: Parser Word32 dword = do bs <- AT.take 4 @@ -100,9 +106,7 @@ where pack = BS.foldl' (\n h -> (n `shiftL` 8) .|. fromIntegral h) 0 -rgba8 :: Parser PixelRGBA8 -rgba8 = PixelRGBA8 <$> anyWord8 <*> anyWord8 <*> anyWord8 <*> anyWord8 - +-- | Header dword @0x04@ (@content@): 0 is JPEG, 1 is paletted. compressionParser :: Parser BlpCompression compressionParser = ( "compression") $ do i <- dword @@ -111,86 +115,59 @@ 1 -> return BlpCompressionUncompressed _ -> fail $ "Unknown compression " ++ show i -flagsParser :: Parser [BlpFlag] -flagsParser = ( "flags") $ do - i <- dword - return $ if i `testBit` 3 - then [BlpFlagAlphaChannel] - else [] - -pictureTypeParser :: Parser BlpPictureType -pictureTypeParser = ( "picture type") $ do - i <- dword - case i of - 0 -> return UncompressedWithAlpha - 2 -> return JPEGType - 3 -> return UncompressedWithAlpha - 4 -> return UncompressedWithAlpha - 5 -> return UncompressedWithoutAlpha - -- BLP1 files seen in the wild (notably from World of Warcraft assets, - -- as well as some BLPs found inside Warcraft III maps) use picture type - -- 6 for JPEG-compressed textures with an alpha channel. The actual data - -- layout is identical to type 2, and the dispatch in `blpParser` already - -- decides JPEG vs uncompressed based on the `compression` field, so we - -- can safely treat 6 as another spelling of `JPEGType`. - 6 -> return JPEGType - _ -> fail $ "Unknown picture type " ++ show i - -blpJpegParser :: [(Word32, Word32)] -> Parser BlpExt -blpJpegParser mps = ( "blp jpeg") $ do - headerSize <- dword "jpeg header size" - blpJpegHeader <- AT.take (fromIntegral headerSize) "jpeg header" - blpJpegData <- forM mps $ \(offset, size) -> do - skipToOffset offset - AT.take $ fromIntegral size - return $ BlpJpeg {..} - -getPos :: Parser Int -getPos = AT.Parser $ \t pos more _ succ' -> succ' t pos more (AT.fromPos pos) - -skipToOffset :: Word32 -> Parser () -skipToOffset i = do - pos <- getPos - let diff = fromIntegral i - pos - if diff <= 0 then return () - else void $ AT.take diff - --- | Read up to 256 palette entries, bounded by the offset of the first --- mipmap. Some BLP1 files in the wild (e.g. produced by community map --- tools) only emit the palette entries that are actually used, so the --- palette region between the main header and the first mipmap can be --- shorter than the canonical 1024 bytes. We pad the resulting vector to --- 256 entries with transparent black so the rest of the codebase, which --- indexes the palette by an arbitrary `Word8`, stays sound. -paletteParser :: [(Word32, Word32)] -> Parser (V.Vector PixelRGBA8) -paletteParser mps = do - pos <- getPos - let firstOffset = case mps of - ((o, _):_) -> fromIntegral o - [] -> pos + 1024 -- no mipmaps: keep historical behaviour - available = max 0 (firstOffset - pos) - nEntries = min 256 (available `div` 4) - entries <- V.replicateM nEntries rgba8 - return $ entries V.++ V.replicate (256 - nEntries) (PixelRGBA8 0 0 0 0) - -blpUncompressed1Parser :: [(Word32, Word32)] -> Parser BlpExt -blpUncompressed1Parser mps = do - blpU1Palette <- paletteParser mps - blpU1MipMaps <- forM mps $ \(offset, size) -> do - skipToOffset offset - let halfSize = fromIntegral size `div` 2 - indexList <- AT.take halfSize "index list" - alphaList <- AT.take halfSize "alpha list" - return (indexList, alphaList) - return $ BlpUncompressed1 {..} +-- | Number of levels in a full mip chain: halving the larger side down to 1, +-- at most 16. +mipChainLength :: Int -> Int -> Int +mipChainLength w h = min 16 . length . takeWhile (>= 1) $ iterate (`div` 2) (max w h) -blpUncompressed2Parser :: [(Word32, Word32)] -> Parser BlpExt -blpUncompressed2Parser mps = do - blpU2Palette <- paletteParser mps - blpU2MipMaps <- forM mps $ \(offset, size) -> do - skipToOffset offset - AT.take (fromIntegral size) "index list" - return $ BlpUncompressed2 {..} +-- | The mip levels a file holds, as (offset, size) in the input. Slots are +-- read in order from slot 0, and the chain ends at the first slot that is +-- empty, does not fit in the input, starts before the given content offset, +-- or overlaps an earlier level, and after the given number of levels. +-- +-- Unused slots should be zero, but tools leave garbage there: offsets past +-- the end of the file, or copies of an earlier slot. Ending the chain there +-- keeps element @i@ of the result level @i@. +mipLevels :: Int -- ^ Length of the input + -> Int -- ^ Offset where the content starts + -> Int -- ^ Most levels to take + -> [(Word32, Word32)] -- ^ Mipmap slots: offset and size + -> [(Int, Int)] +mipLevels inputLen start maxLevels = go [] . take maxLevels + where + go used ((offset, size) : rest) + | s > 0 && o >= toInteger start && o + s <= toInteger inputLen && not (any (overlaps (o, s)) used) = + (fromInteger o, fromInteger s) : go ((o, s) : used) rest + where + o = toInteger offset + s = toInteger size + go _ _ = [] + overlaps (o, s) (o', s') = o < o' + s' && o' < o + s -parseBlp :: ByteString -> Either String BlpStruct -parseBlp bs = parseOnly (blpParser (BS.length bs)) bs +-- | Width and height from the frame header (SOFn) of a JPEG stream, read +-- without decoding the stream. +jpegFrameSize :: ByteString -> Maybe (Int, Int) +jpegFrameSize bs + | BS.take 2 bs == BS.pack [0xFF, 0xD8] = go 2 + | otherwise = Nothing + where + go i = do + 0xFF <- byte i + marker <- byte (i + 1) + if | marker == 0xFF -> go (i + 1) -- fill byte + | marker == 0x01 || (marker >= 0xD0 && marker <= 0xD7) -> go (i + 2) -- no length + | marker == 0xD9 || marker == 0xDA -> Nothing -- end of image or start of scan + | isFrameHeader marker -> do + height <- word16 (i + 5) + width <- word16 (i + 7) + return (width, height) + | otherwise -> do + len <- word16 (i + 2) + if len < 2 then Nothing else go (i + 2 + len) + byte i = if i < BS.length bs then Just (BS.index bs i) else Nothing + word16 i = do + hi <- byte i + lo <- byte (i + 1) + return (fromIntegral hi * 256 + fromIntegral lo) + -- SOF0 to SOF15, except DHT (C4), JPG (C8) and DAC (CC). + isFrameHeader m = m >= 0xC0 && m <= 0xCF && m `notElem` [0xC4, 0xC8, 0xCC] diff --git a/test/Deprecated.hs b/test/Deprecated.hs new file mode 100644 --- /dev/null +++ b/test/Deprecated.hs @@ -0,0 +1,31 @@ +{-# OPTIONS_GHC -Wno-deprecations #-} +-- | Tests for the encoders that 'encodeBlpWith' replaced. They live in their +-- own module so that deprecation warnings stay errors everywhere else. +module Deprecated(deprecatedTests) where + +import Codec.Picture +import Codec.Picture.Blp +import Control.Exception (ErrorCall, evaluate, try) +import Data.Either (isLeft) +import Data.Int (Int64) +import Test.Tasty +import Test.Tasty.HUnit + +import qualified Data.ByteString.Lazy as BSL + +deprecatedTests :: TestTree +deprecatedTests = testGroup "deprecated encoders" + [ testCase "match encodeBlpWith" $ do + let with f n = either (error . show) id $ encodeBlpWith (BlpEncodeOptions f n) img + encodeBlpJpeg 90 3 img @?= with (BlpFormatJpeg 90) 3 + encodeBlpUncompressedWithAlpha 3 img @?= with (BlpFormatPaletted True) 3 + encodeBlpUncompressedWithoutAlpha 3 img @?= with (BlpFormatPaletted False) 3 + , testCase "clamp the JPEG quality" $ do + encodeBlpJpeg 300 1 img @?= encodeBlpJpeg 100 1 img + encodeBlpJpeg (-5) 1 img @?= encodeBlpJpeg 1 1 img + , testCase "throw on an empty image" $ do + r <- try (evaluate . BSL.length $ encodeBlpJpeg 90 1 (ImageRGBA8 $ generateImage (\_ _ -> PixelRGBA8 0 0 0 0) 0 3)) + assertBool "expected an error" (isLeft (r :: Either ErrorCall Int64)) + ] + where + img = ImageRGBA8 $ generateImage (\x y -> PixelRGBA8 (fromIntegral $ x * 16) (fromIntegral $ y * 16) 128 200) 16 16 diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -2,6 +2,7 @@ import Codec.Picture import Codec.Picture.Blp +import Codec.Picture.Blp.Internal.Encoder (createMipMaps) import Codec.Picture.Types (convertImage) import Control.Exception (bracket_, try) import Control.Monad (forM_) @@ -16,6 +17,7 @@ import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BSL +import Deprecated import Fixture main :: IO () @@ -25,6 +27,7 @@ , jpegTests , encoderTests , fileTests + , deprecatedTests ] -- | 4x4 test texture: pixel (x, y) is palette index @y*4+x@. @@ -76,6 +79,23 @@ [ testCase "with alpha, picture type 4" $ assertPixels withAlphaPixel (withAlphaFile 4) , testCase "with alpha, picture type 3" $ assertPixels withAlphaPixel (withAlphaFile 3) , testCase "picture type 0 decodes as with alpha (#10)" $ assertPixels withAlphaPixel (withAlphaFile 0) + , testCase "alphaBits 8 keeps alpha whatever extra says (#25)" $ + assertPixels withAlphaPixel $ uncompressed defHeader { hPictureType = 5 } (palette 256) [indices <> alphaPlane] + , testCase "extra has no effect (#25)" $ + forM_ [0, 1, 2, 3, 4, 5, 6, 7, 99] $ \extra -> + assertPixels withAlphaPixel (withAlphaFile extra) + , testCase "alphaBits 0 ignores a trailing alpha list (#25)" $ + assertPixels withoutAlphaPixel $ uncompressed defHeader { hFlags = 0, hPictureType = 4 } (palette 256) [indices <> alphaPlane] + , testCase "1-bit alpha, least significant bit first (#25)" $ do + let bs = uncompressed defHeader { hFlags = 1 } (palette 256) [indices <> BS.pack [0x0f, 0xf0]] + on k = k < 4 || k >= 12 + assertPixels (\k -> setAlpha (if on k then 255 else 0) (withoutAlphaPixel k)) bs + , testCase "4-bit alpha, low nibble first (#25)" $ do + let nibbles = BS.pack [fromIntegral (2 * j) + 16 * fromIntegral (2 * j + 1) | j <- [0 .. 7 :: Int]] + bs = uncompressed defHeader { hFlags = 4 } (palette 256) [indices <> nibbles] + assertPixels (\k -> setAlpha (k * 17) (withoutAlphaPixel k)) bs + , testCase "invalid alphaBits counts as no alpha (#25)" $ + assertPixels withoutAlphaPixel $ uncompressed defHeader { hFlags = 3 } (palette 256) [indices <> alphaPlane] , testCase "without alpha, picture type 5" $ assertPixels withoutAlphaPixel withoutAlphaFile , testCase "without alpha ignores the palette's fourth byte (#14)" $ assertPixels withoutAlphaPixel $ uncompressed defHeader { hFlags = 0, hPictureType = 5 } @@ -128,10 +148,6 @@ assertLeft "BLP1" . decodeBlp $ "BLP2" <> BS.drop 4 (withAlphaFile 4) , testCase "unknown compression" $ assertLeft "compression" . decodeBlp $ uncompressed defHeader { hCompression = 7 } (palette 256) [indices] - , testCase "unknown picture type" $ - assertLeft "picture type" . decodeBlp $ withAlphaFile 9 - , testCase "uncompressed file with JPEG picture type" $ - assertLeft "JPEG type" . decodeBlp $ withAlphaFile 2 , testCase "truncated header" $ assertLeft "" . decodeBlp $ BS.take 100 (withAlphaFile 4) , testCase "empty input" $ @@ -140,6 +156,16 @@ assertLeft "mipmaps sizes" . decodeBlp $ BS.take 100 (withAlphaFile 4) , testCase "JPEG header longer than the file" $ assertLeft "jpeg header" . decodeBlp $ setDword headerSize 100000 jpegFile + , testCase "width or height outside 1..65535 is an error" $ do + let sized w h = uncompressed defHeader { hFlags = 0, hWidth = w, hHeight = h } (palette 256) [BS.replicate 4 0] + assertLeft "Invalid image size" . decodeBlp $ sized 0xFFFFFFFF 0xFFFFFFFF + assertLeft "Invalid image size" . decodeBlp $ sized 0 4 + assertLeft "Invalid image size" . decodeBlp $ sized 4 65536 + , testCase "garbage slot before mip 0 leaves the palette intact" $ do + let bs = setDword (offsetSlot 1) 200 . setDword (sizeSlot 1) 4 $ withAlphaFile 4 + assertPixels withAlphaPixel bs + levels <- decodeLevels bs + length levels @?= 1 , testCase "uncompressed file without mipmaps" $ assertLeft "No data" . decodeBlp $ blpFile defHeader [] (paletteBytes $ palette 256) , testCase "JPEG file without mipmaps" $ @@ -157,7 +183,7 @@ opaqueGradient = pixelMap (\(PixelRGBA8 r g b _) -> PixelRGBA8 r g b 255) gradient jpegFile :: ByteString -jpegFile = BSL.toStrict $ encodeBlpJpeg 100 3 (ImageRGBA8 gradient) +jpegFile = BSL.toStrict $ enc (BlpFormatJpeg 100) 3 (ImageRGBA8 gradient) -- | Largest per-channel difference between two equally sized images. maxDiff :: Image PixelRGBA8 -> Image PixelRGBA8 -> Int @@ -173,12 +199,15 @@ jpegTests :: TestTree jpegTests = testGroup "jpeg" [ testCase "opaque texture round-trips through the encoder (#11)" $ do - img <- decodeRGBA . BSL.toStrict $ encodeBlpJpeg 100 1 (ImageRGBA8 opaqueGradient) + img <- decodeRGBA . BSL.toStrict $ enc (BlpFormatJpeg 100) 1 (ImageRGBA8 opaqueGradient) let d = maxDiff opaqueGradient img assertBool ("max channel difference " ++ show d) (d <= 8) , testCase "all three mip levels decode" $ do levels <- decodeLevels jpegFile sizes levels @?= [(16, 16), (8, 8), (4, 4)] + , testCase "JPEG with alphaBits 0 decodes opaque (#25)" $ do + img <- decodeRGBA (setDword 8 0 jpegFile) + assertBool "every pixel opaque" $ all (\(PixelRGBA8 _ _ _ a) -> a == 255) (pixelsOf img) , testCase "picture type 6 decodes like the original (#5)" $ do orig <- decodeRGBA jpegFile img <- decodeRGBA (setDword pictureTypeOffset 6 jpegFile) @@ -189,6 +218,29 @@ , testCase "broken last mip keeps the levels before it (#9)" $ do levels <- decodeLevels (setDword (sizeSlot 2) 12 jpegFile) sizes levels @?= [(16, 16), (8, 8)] + , testCase "JPEG frame larger than its level is rejected before decoding" $ do + let sof = frameHeaderAt (fromIntegral headerSize + 4) jpegFile + huge = foldr (\(i, v) bs -> setByte i v bs) jpegFile [(sof + k, 0xFF) | k <- [5 .. 8]] + assertLeft "larger than its level size" $ decodeBlp huge + , testCase "JPEG frame smaller than its level is padded with transparent black" $ do + let big = setDword 12 32 (setDword 16 32 jpegFile) + levels <- decodeLevels big + sizes (take 2 levels) @?= [(32, 32), (16, 16)] + orig <- decodeRGBA jpegFile + case levels of + mip0 : _ -> do + pixelAt mip0 3 5 @?= pixelAt orig 3 5 + pixelAt mip0 20 20 @?= PixelRGBA8 0 0 0 0 + [] -> assertFailure "no levels" + , testCase "a missing middle slot ends the chain" $ do + levels <- decodeLevels (setDword (sizeSlot 1) 0 jpegFile) + sizes levels @?= [(16, 16)] + , testCase "a JPEG decoder error in mip 0 is a Left" $ + assertLeft "JPEG decoding failed" . decodeBlp $ jpegBlp 1 1 [badJpeg] + , testCase "a JPEG decoder error in a tail mip ends the list" $ do + let good = BSL.toStrict . encodeJpeg $ (convertImage (generateImage (\_ _ -> PixelRGB8 10 20 30) 2 2 :: Image PixelRGB8) :: Image PixelYCbCr8) + levels <- decodeLevels (jpegBlp 2 2 [good, badJpeg]) + sizes levels @?= [(2, 2)] , testCase "broken mip 0 fails the file" $ assertLeft "" . decodeBlp $ setDword (sizeSlot 0) 12 jpegFile , testCase "three-component JPEG decodes to RGBA" $ do @@ -203,18 +255,18 @@ pixelsOf img @?= pixelsOf direct _ -> assertFailure "expected ImageRGBA8" , testCase "semi-transparent texture round-trips through the encoder (#17)" $ do - img <- decodeRGBA . BSL.toStrict $ encodeBlpJpeg 100 1 (ImageRGBA8 gradient) + img <- decodeRGBA . BSL.toStrict $ enc (BlpFormatJpeg 100) 1 (ImageRGBA8 gradient) let d = maxDiff gradient img assertBool ("max channel difference " ++ show d) (d <= 8) , testCase "uniformly semi-transparent texture keeps its alpha (#17)" $ do let solid = generateImage (\_ _ -> PixelRGBA8 200 100 50 128) 8 8 - img <- decodeRGBA . BSL.toStrict $ encodeBlpJpeg 100 1 (ImageRGBA8 solid) + img <- decodeRGBA . BSL.toStrict $ enc (BlpFormatJpeg 100) 1 (ImageRGBA8 solid) let d = maxDiff solid img assertBool ("max channel difference " ++ show d) (d <= 4) , testCase "all-zero alpha plane means opaque (#11)" $ do let clear = generateImage (\_ _ -> PixelRGBA8 200 100 50 0) 8 8 opaque = pixelMap (\(PixelRGBA8 r g b _) -> PixelRGBA8 r g b 255) clear - img <- decodeRGBA . BSL.toStrict $ encodeBlpJpeg 100 1 (ImageRGBA8 clear) + img <- decodeRGBA . BSL.toStrict $ enc (BlpFormatJpeg 100) 1 (ImageRGBA8 clear) let d = maxDiff opaque img assertBool ("max channel difference " ++ show d) (d <= 4) , testCase "mipmaps share a JPEG header (#18)" $ do @@ -224,7 +276,7 @@ sizes levels @?= [(16, 16), (8, 8), (4, 4)] , testCase "single mipmap keeps its data out of the shared header (#18)" $ do let tiny = generateImage (\_ _ -> PixelRGBA8 200 100 50 255) 1 1 - img <- decodeRGBA . BSL.toStrict $ encodeBlpJpeg 100 1 (ImageRGBA8 tiny) + img <- decodeRGBA . BSL.toStrict $ enc (BlpFormatJpeg 100) 1 (ImageRGBA8 tiny) let d = maxDiff tiny img assertBool ("max channel difference " ++ show d) (d <= 4) ] @@ -232,29 +284,29 @@ encoderTests :: TestTree encoderTests = testGroup "encoder" [ testCase "with alpha writes the expected header" $ do - let bs = BSL.toStrict $ encodeBlpUncompressedWithAlpha 3 (ImageRGBA8 gradient) + let bs = BSL.toStrict $ enc (BlpFormatPaletted True) 3 (ImageRGBA8 gradient) map (`getDword` bs) [4, 8, 12, 16] @?= [1, 8, 16, 16] getDword pictureTypeOffset bs @?= 3 map (\i -> getDword (sizeSlot i) bs) [0 .. 2] @?= [512, 128, 32] , testCase "without alpha writes the expected header" $ do - let bs = BSL.toStrict $ encodeBlpUncompressedWithoutAlpha 3 (ImageRGB8 $ convertRGB8 (ImageRGBA8 gradient)) + let bs = BSL.toStrict $ enc (BlpFormatPaletted False) 3 (ImageRGB8 $ convertRGB8 (ImageRGBA8 gradient)) map (`getDword` bs) [4, 8] @?= [1, 0] getDword pictureTypeOffset bs @?= 5 map (\i -> getDword (sizeSlot i) bs) [0 .. 2] @?= [256, 64, 16] , testCase "with alpha round-trips mip 0" $ do - img <- decodeRGBA . BSL.toStrict $ encodeBlpUncompressedWithAlpha 1 (ImageRGBA8 gradient) + img <- decodeRGBA . BSL.toStrict $ enc (BlpFormatPaletted True) 1 (ImageRGBA8 gradient) let d = maxDiff gradient img assertBool ("max channel difference " ++ show d) (d <= 8) , testCase "without alpha round-trips mip 0 (#14)" $ do let opaque = convertRGB8 (ImageRGBA8 opaqueGradient) - img <- decodeRGBA . BSL.toStrict $ encodeBlpUncompressedWithoutAlpha 1 (ImageRGB8 opaque) + img <- decodeRGBA . BSL.toStrict $ enc (BlpFormatPaletted False) 1 (ImageRGB8 opaque) let d = maxDiff opaqueGradient img assertBool ("max channel difference " ++ show d) (d <= 8) , testCase "encoded mipmaps decode at their own sizes (#13)" $ do - levels <- decodeLevels . BSL.toStrict $ encodeBlpUncompressedWithAlpha 3 (ImageRGBA8 gradient) + levels <- decodeLevels . BSL.toStrict $ enc (BlpFormatPaletted True) 3 (ImageRGBA8 gradient) sizes levels @?= [(16, 16), (8, 8), (4, 4)] , testCase "JPEG alpha flag and picture type follow the input format" $ do - let header dyn = let bs = BSL.toStrict $ encodeBlpJpeg 90 1 dyn + let header dyn = let bs = BSL.toStrict $ enc (BlpFormatJpeg 90) 1 dyn in (getDword 8 bs, getDword pictureTypeOffset bs) rgba = convertRGBA8 (ImageRGBA8 gradient) header (ImageY8 $ pixelMap (\(PixelRGBA8 r _ _ _) -> r) rgba) @?= (0, 5) @@ -262,44 +314,99 @@ header (ImageRGB16 $ pixelMap (\(PixelRGBA8 r g b _) -> PixelRGB16 (w16 r) (w16 g) (w16 b)) rgba) @?= (0, 5) header (ImageRGBA16 $ pixelMap (\(PixelRGBA8 r g b a) -> PixelRGBA16 (w16 r) (w16 g) (w16 b) (w16 a)) rgba) @?= (8, 3) , testCase "without alpha drops the alpha of an RGBA input" $ do - let bs = BSL.toStrict $ encodeBlpUncompressedWithoutAlpha 1 (ImageRGBA8 gradient) + let bs = BSL.toStrict $ enc (BlpFormatPaletted False) 1 (ImageRGBA8 gradient) (getDword 8 bs, getDword pictureTypeOffset bs) @?= (0, 5) img <- decodeRGBA bs let d = maxDiff opaqueGradient img assertBool ("max channel difference " ++ show d) (d <= 8) , testCase "with alpha keeps an alpha plane for an RGB input" $ do - let bs = BSL.toStrict $ encodeBlpUncompressedWithAlpha 1 (ImageRGB8 $ convertRGB8 (ImageRGBA8 opaqueGradient)) + let bs = BSL.toStrict $ enc (BlpFormatPaletted True) 1 (ImageRGB8 $ convertRGB8 (ImageRGBA8 opaqueGradient)) (getDword 8 bs, getDword pictureTypeOffset bs) @?= (8, 3) img <- decodeRGBA bs let d = maxDiff opaqueGradient img assertBool ("max channel difference " ++ show d) (d <= 8) , testCase "JPEG without alpha decodes opaque" $ do - let bs = BSL.toStrict $ encodeBlpJpeg 100 1 (ImageRGB8 $ convertRGB8 (ImageRGBA8 gradient)) + let bs = BSL.toStrict $ enc (BlpFormatJpeg 100) 1 (ImageRGB8 $ convertRGB8 (ImageRGBA8 gradient)) getDword 8 bs @?= 0 img <- decodeRGBA bs let d = maxDiff opaqueGradient img assertBool ("max channel difference " ++ show d) (d <= 8) , testCase "asking for more mipmaps than levels stops at 1x1" $ do - levels <- decodeLevels . BSL.toStrict $ encodeBlpUncompressedWithAlpha 20 (ImageRGBA8 gradient) + levels <- decodeLevels . BSL.toStrict $ enc (BlpFormatPaletted True) 20 (ImageRGBA8 gradient) sizes levels @?= [(16, 16), (8, 8), (4, 4), (2, 2), (1, 1)] - , testCase "non-square mip chain stops when a side reaches 1" $ do + , testCase "non-square mip chain goes on to 1x1 (#26)" $ do let wide = generateImage (\x y -> PixelRGBA8 (fromIntegral x) (fromIntegral y) 0 255) 64 16 - levels <- decodeLevels . BSL.toStrict $ encodeBlpJpeg 90 16 (ImageRGBA8 wide) - sizes levels @?= [(64, 16), (32, 8), (16, 4), (8, 2), (4, 1)] - odd' <- decodeLevels . BSL.toStrict $ encodeBlpUncompressedWithAlpha 16 (ImageRGBA8 $ generateImage (\_ _ -> PixelRGBA8 1 2 3 4) 5 3) - sizes odd' @?= [(5, 3), (2, 1)] - , testCase "mipMapsUpTo counts every level down to the minimum side" $ do + levels <- decodeLevels . BSL.toStrict $ enc (BlpFormatJpeg 90) 16 (ImageRGBA8 wide) + sizes levels @?= [(64, 16), (32, 8), (16, 4), (8, 2), (4, 1), (2, 1), (1, 1)] + odd' <- decodeLevels . BSL.toStrict $ enc (BlpFormatPaletted True) 16 (ImageRGBA8 $ generateImage (\_ _ -> PixelRGBA8 1 2 3 4) 5 3) + sizes odd' @?= [(5, 3), (2, 1), (1, 1)] + , testCase "single-row texture keeps halving its width (#26)" $ do + let row = ImageRGBA8 $ generateImage (\x _ -> PixelRGBA8 (fromIntegral x) 0 0 255) 8 1 + forM_ [enc (BlpFormatJpeg 90) 16 row, enc (BlpFormatPaletted True) 16 row] $ \bs -> do + levels <- decodeLevels (BSL.toStrict bs) + sizes levels @?= [(8, 1), (4, 1), (2, 1), (1, 1)] + , testCase "a solid texture stays solid down to 1x1 (#26)" $ do + let solid = PixelRGBA8 200 100 50 128 + img = ImageRGBA8 $ generateImage (\_ _ -> solid) 6 3 + levels <- decodeLevels . BSL.toStrict $ enc (BlpFormatPaletted True) 16 img + sizes levels @?= [(6, 3), (3, 1), (1, 1)] + forM_ levels $ \level -> assertBool "every pixel unchanged" (all (== solid) (pixelsOf level)) + , testCase "slots repeating the last level add no levels" $ do + let bs = BSL.toStrict $ enc (BlpFormatPaletted True) 5 (ImageRGBA8 gradient) + lastSlot = (getDword (offsetSlot 4) bs, getDword (sizeSlot 4) bs) + padded = foldr (\i b -> setDword (offsetSlot i) (fst lastSlot) (setDword (sizeSlot i) (snd lastSlot) b)) bs [5 .. 15] + levels <- decodeLevels padded + sizes levels @?= [(16, 16), (8, 8), (4, 4), (2, 2), (1, 1)] + , testCase "unused mipmap slots are zero" $ do + let bs = BSL.toStrict $ enc (BlpFormatPaletted True) 2 (ImageRGBA8 gradient) + [(getDword (offsetSlot i) bs, getDword (sizeSlot i) bs) | i <- [2 .. 15]] @?= replicate 14 (0, 0) + , testCase "hasMipmaps is 0 for a single level" $ do + let hasMipmaps n = getDword 24 . BSL.toStrict $ enc (BlpFormatJpeg 90) n (ImageRGBA8 gradient) + hasMipmaps 1 @?= 0 + hasMipmaps 3 @?= 5 + , testCase "encodeBlpWith rejects what it cannot encode" $ do + let opts f = BlpEncodeOptions f 16 + blank w h = ImageRGBA8 $ generateImage (\_ _ -> PixelRGBA8 0 0 0 0) w h + errorOf o img = either Just (const Nothing) (encodeBlpWith o img) + errorOf (opts (BlpFormatJpeg 90)) (blank 0 4) @?= Just BlpEmptyImage + errorOf (opts (BlpFormatPaletted True)) (blank 4 0) @?= Just BlpEmptyImage + errorOf (opts (BlpFormatJpeg 90)) (blank 65536 1) @?= Just (BlpImageTooLarge 65536 1) + errorOf (opts (BlpFormatJpeg 0)) (blank 4 4) @?= Just (BlpInvalidJpegQuality 0) + errorOf (opts (BlpFormatJpeg 101)) (blank 4 4) @?= Just (BlpInvalidJpegQuality 101) + errorOf defaultBlpEncodeOptions (blank 4 4) @?= Nothing + , testCase "colour of transparent pixels does not bleed into mipmaps" $ do + let px x y = if (x, y) == (0, 0) then PixelRGBA8 255 255 255 255 else PixelRGBA8 0 0 0 0 + img = generateImage px 2 2 + case createMipMaps img of + _ : level1 : _ -> pixelAt level1 0 0 @?= PixelRGBA8 255 255 255 64 + _ -> assertFailure "expected two levels" + , testCase "paletted alpha mipmaps are averaged" $ do + let checker = generateImage (\x y -> PixelRGBA8 200 100 50 (if even (x + y) then 0 else 255)) 16 16 + levels <- decodeLevels . BSL.toStrict $ enc (BlpFormatPaletted True) 2 (ImageRGBA8 checker) + case levels of + _ : level1 : _ -> assertBool "alpha around half" $ + all (\(PixelRGBA8 _ _ _ a) -> a == 128) (pixelsOf level1) + _ -> assertFailure "expected two levels" + , testCase "opaque mipmaps average plainly" $ do + let img = generateImage (\x _ -> PixelRGBA8 (fromIntegral $ 10 * x) 7 0 255) 4 1 + case createMipMaps img of + _ : level1 : _ -> pixelsOf level1 @?= [PixelRGBA8 5 7 0 255, PixelRGBA8 25 7 0 255] + _ -> assertFailure "expected two levels" + , testCase "mipMapsUpTo is at most 16" $ + mipMapsUpTo 1 (ImageRGBA8 $ generateImage (\_ _ -> PixelRGBA8 0 0 0 0) 65535 1) @?= 16 + , testCase "mipMapsUpTo counts levels by the larger side (#26)" $ do let img w h = ImageRGBA8 $ generateImage (\_ _ -> PixelRGBA8 0 0 0 0) w h mipMapsUpTo 1 (img 16 16) @?= 5 mipMapsUpTo 4 (img 16 16) @?= 3 - mipMapsUpTo 1 (img 64 16) @?= 5 + mipMapsUpTo 1 (img 64 16) @?= 7 + mipMapsUpTo 16 (img 64 16) @?= 3 mipMapsUpTo 1 (img 5 5) @?= 3 mipMapsUpTo 1 (img 1 1) @?= 1 mipMapsUpTo 32 (img 16 16) @?= 1 , testCase "zero or negative mipmap count still writes mip 0" $ do - let enc n = [ encodeBlpJpeg 90 n (ImageRGBA8 gradient) - , encodeBlpUncompressedWithAlpha n (ImageRGBA8 gradient) ] - forM_ (concatMap enc [0, -1]) $ \bs -> do + let encs n = [ enc (BlpFormatJpeg 90) n (ImageRGBA8 gradient) + , enc (BlpFormatPaletted True) n (ImageRGBA8 gradient) ] + forM_ (concatMap encs [0, -1]) $ \bs -> do levels <- decodeLevels (BSL.toStrict bs) sizes levels @?= [(16, 16)] ] @@ -316,9 +423,9 @@ assertBool ("max channel difference " ++ show d) (d <= 8) Right levels <- readBlpMipmaps path sizes (map convertRGBA8 levels) @?= [(16, 16), (8, 8)] - check $ \p -> writeBlpJpeg p 100 2 img - check $ \p -> writeBlpUncompressedWithAlpha p 2 img - check $ \p -> writeBlpUncompressedWithoutAlpha p 2 (ImageRGB8 $ convertRGB8 img) + check $ \p -> writeOk p (BlpFormatJpeg 100) img + check $ \p -> writeOk p (BlpFormatPaletted True) img + check $ \p -> writeOk p (BlpFormatPaletted False) (ImageRGB8 $ convertRGB8 img) , testCase "missing file is an IO error" $ do r <- tryIO $ readBlp "/nonexistent/juicypixels-blp.blp" assertBool "readBlp should throw" (either (const True) (const False) r) @@ -329,3 +436,37 @@ w16 :: Word8 -> Word16 w16 v = fromIntegral v * 257 + +setAlpha :: Word8 -> PixelRGBA8 -> PixelRGBA8 +setAlpha a (PixelRGBA8 r g b _) = PixelRGBA8 r g b a + +setByte :: Int -> Word8 -> ByteString -> ByteString +setByte i v bs = BS.take i bs <> BS.singleton v <> BS.drop (i + 1) bs + +-- | Offset of the first JPEG frame header (FF C0) at or after the given offset. +frameHeaderAt :: Word32 -> ByteString -> Int +frameHeaderAt from bs = fromIntegral from + BS.length (fst (BS.breakSubstring (BS.pack [0xFF, 0xC0]) (BS.drop (fromIntegral from) bs))) + +-- | A 1x1 JPEG whose scan selects a component the frame does not have. +-- JuicyPixels 3.3.9 raises an error on it instead of returning Left. +badJpeg :: ByteString +badJpeg = BS.pack + [ 0xff, 0xd8, 0xff, 0xc0, 0x00, 0x0b, 0x08, 0x00, 0x01, 0x00, 0x01, 0x01, 0x01, 0x11, 0x00 + , 0xff, 0xda, 0x00, 0x08, 0x01, 0x02, 0x00, 0x00, 0x3f, 0x00, 0xff, 0xd9 ] + +-- | JPEG BLP without alpha and with an empty shared header, holding the given +-- streams as its mip levels. +jpegBlp :: Word32 -> Word32 -> [ByteString] -> ByteString +jpegBlp w h mips = blpFile defHeader { hCompression = 0, hFlags = 0, hWidth = w, hHeight = h } slots ("\0\0\0\0" <> BS.concat mips) + where + sizes' = map (fromIntegral . BS.length) mips + slots = zip (scanl (+) (fromIntegral headerSize + 4) sizes') sizes' + +-- | Encode with the given format and number of levels, failing the test on +-- an encoding error. +enc :: BlpFormat -> Int -> DynamicImage -> BSL.ByteString +enc format levels = either (error . show) id . encodeBlpWith (BlpEncodeOptions format levels) + +-- | Write a file with two mip levels, failing the test on an encoding error. +writeOk :: FilePath -> BlpFormat -> DynamicImage -> IO () +writeOk path format img = writeBlpWith path (BlpEncodeOptions format 2) img >>= either (assertFailure . show) return