JuicyPixels-blp 0.6.0.0 → 1.0.0.0

raw patch · 20 files changed

+1101/−313 lines, 20 filesdep ~vectorPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: vector

API changes (from Hackage documentation)

Files

• CHANGELOG.md +69/−0
• JuicyPixels-blp.cabal +3/−3
• README.md +55/−28
• bench/Main.hs +6/−2
• blp2any/Convert.hs +29/−5
• blp2any/Main.hs +3/−2
• blp2any/Statistics.hs +14/−6
• docs/format.md +33/−9
• src/Codec/Picture/Blp.hs +37/−74
• src/Codec/Picture/Blp/Internal/Decoder.hs +20/−21
• src/Codec/Picture/Blp/Internal/Dxt.hs +307/−9
• src/Codec/Picture/Blp/Internal/Encoder.hs +106/−18
• src/Codec/Picture/Blp/Internal/Parser.hs +51/−34
• src/Codec/Picture/Blp/Types.hs +75/−6
• test/Blp2.hs +86/−19
• test/Deprecated.hs +0/−31
• test/Dxt.hs +117/−0
• test/Fixture.hs +19/−0
• test/Main.hs +56/−39
• test/Properties.hs +15/−7

@@ -1,3 +1,72 @@+1.0.0.0 (2026-10-17)+====================++The library now reads and writes both BLP versions in use, and its API is+meant to stay. Decoding reports why it fails and returns the image type it+always produced, BLP2 can be written, and the deprecated encoders are gone.+Every decoding function and the encoding options change; see below.++### Writing BLP2++- **Breaking:** `BlpEncodeOptions` has a new field, `blpVersion` (`Blp1` by+  default), and `BlpFormat` new constructors `BlpFormatDxt1`,+  `BlpFormatDxt3`, `BlpFormatDxt5` and `BlpFormatBgra`. These exist only in+  BLP2; JPEG exists only in BLP1, and a palette in both. Other combinations+  give the new `BlpUnsupportedFormat`.+- The DXT encoder fits each block's colours along their principal axis,+  refines the endpoints by least squares, and tries a single-colour fit+  from exact tables. Against ImageMagick's DDS encoders on seven test+  images it is 0.7–2.5 dB above range fit and 0.2–0.6 dB below cluster+  fit (1.8 dB on a 64×64 icon). It encodes a 512×512 texture in about+  80 ms (DXT1) or 100 ms (DXT5).+- Files written this way decode with an independent decoder (Pinta365/blp,+  with the DXT5 alpha fix reported in Pinta365/blp#1): palette and BGRA+  exactly, DXT within the two decoders' rounding differences.+- `blp2any convert` writes BLP2 with `-b dxt1`, `dxt3`, `dxt5` or `bgra`,+  and paletted BLP2 with `--blp2`.++### Decoding++- **Breaking:** `decodeBlp`, `decodeBlpWith`, `readBlp` and the `Mipmaps`+  variants return `Image PixelRGBA8` instead of `DynamicImage`; the image+  was always `ImageRGBA8`. Drop the `convertRGBA8` call, or wrap the result+  in `ImageRGBA8` where a `DynamicImage` is needed.+- **Breaking:** they and `blpInfo` report errors as `BlpDecodeError`+  instead of `String`: `BlpNotBlp`, `BlpTruncatedHeader`, `BlpUnsupported`,+  `BlpInvalidSize`, `BlpTooLarge`, `BlpNoImageData` and `BlpCorruptImage`.+  `displayBlpDecodeError` gives a readable message. Callers can tell a+  broken file from one that is too large or of an unsupported kind without+  parsing text.+- A paletted file without any usable mip level is now `BlpNoImageData` for+  `decodeBlpMipmaps` too; it used to give an empty list. JPEG files already+  failed this way. Apart from that, decoding is unchanged: an equivalence+  run against 0.6.0.0 over 4735 cases gives the same pixels, levels,+  `blpInfo` results and failures.+- JPEG errors from JuicyPixels name the level, for example+  `JPEG mipmap 0: not enough bytes`.++### Also++- **Breaking:** the deprecated `encodeBlpJpeg`,+  `encodeBlpUncompressedWithAlpha`, `encodeBlpUncompressedWithoutAlpha` and+  their `writeBlp*` variants are removed. Use `encodeBlpWith` or+  `writeBlpWith`; unlike them, these return `Left` instead of throwing.+- `BlpDecodeError` and `BlpEncodeError` are `Exception`s, and the public+  result and option types have `NFData` instances.+- `blp2any stats` groups BLP2 files too, by content type, `alphaDepth`,+  `alphaType` and `hasMips`. Group names of BLP1 files are unchanged.+- The README lists what is out of scope on purpose: BLP0, BLP2 with JPEG+  content, chosen header values through the public encoder, and archives+  or other texture formats.+- Internal modules:+  - `Internal.Dxt` has `encodeDxt`.+  - `Internal.Encoder` has `toBlp2Struct`, `encodeBlp2` and `blp2Encoder`,+    and `toBlpStruct` returns `Either BlpEncodeError`.+  - The parser and decoder return `BlpDecodeError`, and the decoder+    `Image PixelRGBA8`.+  - The BLP1 magic parser `blpVersion` is renamed `blp1Tag`, as the name+    now belongs to the option.+ 0.6.0.0 (2026-10-16) ==================== 

@@ -1,9 +1,9 @@ cabal-version:       2.2 name:                JuicyPixels-blp-version:             0.6.0.0+version:             1.0.0.0 synopsis:            BLP format decoder/encoder over JuicyPixels library description:-  Read and write BLP1, the texture format of Warcraft III, and read BLP2,+  Read and write BLP1, the texture format of Warcraft III, and BLP2,   its World of Warcraft variant, with images as   [JuicyPixels](https://hackage.haskell.org/package/JuicyPixels) types.   Supports JPEG, paletted, DXT1/3/5 and BGRA content with and without@@ -119,7 +119,6 @@   ghc-options:         -rtsopts -with-rtsopts=-M1g   other-modules:     Blp2-    Deprecated     Dxt     Fixture     Properties@@ -136,6 +135,7 @@     , QuickCheck            >= 2.14   && < 2.17     , tasty-hunit           >= 0.10   && < 0.11     , tasty-quickcheck      >= 0.10.2 && < 0.12+    , vector    default-extensions:     OverloadedStrings

@@ -4,7 +4,7 @@ [![CI](https://github.com/NCrashed/JuicyPixels-blp/actions/workflows/ci.yml/badge.svg)](https://github.com/NCrashed/JuicyPixels-blp/actions/workflows/ci.yml) [![Hackage](https://img.shields.io/hackage/v/JuicyPixels-blp.svg)](https://hackage.haskell.org/package/JuicyPixels-blp) -Read and write BLP1, the texture format of Warcraft III, and read BLP2, its+Read and write BLP1, the texture format of Warcraft III, and BLP2, its World of Warcraft variant, with images as [JuicyPixels](https://hackage.haskell.org/package/JuicyPixels) types. The package also ships `blp2any`, a command-line converter between BLP and@@ -21,9 +21,9 @@  main :: IO () main = do-  -- Decode: the result is always ImageRGBA8.+  -- Decode: the result is an Image PixelRGBA8, whatever the content.   Right img <- readBlp "war3mapMap.blp"-  writePng "war3mapMap.png" (convertRGBA8 img)+  writePng "war3mapMap.png" img    -- Encode: JPEG at quality 90 with every mip level down to 1x1.   Right png <- readImage "icon.png"@@ -31,13 +31,22 @@   either print return result ``` -- `readBlp` / `decodeBlp` return the full size image of a BLP1 or BLP2 file.+- `readBlp` / `decodeBlp` return the full size image of a BLP1 or BLP2 file+  as `Image PixelRGBA8`. - `readBlpMipmaps` / `decodeBlpMipmaps` return the image followed by its   mipmaps.+- Files they cannot read give a `BlpDecodeError`, which says why: not a BLP+  file, a header cut short, unsupported content, an invalid size, a size+  above the limit, no image data, or a damaged full size image.+  `displayBlpDecodeError` turns it into a message. - `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).+  - `blpVersion`: `Blp1` (Warcraft III, the default) or `Blp2` (World of+    Warcraft).+  - `blpFormat`: in BLP1, `BlpFormatJpeg quality` (1 to 100; the texture+    gets alpha when the image has it); in BLP2, `BlpFormatDxt1` (1-bit+    alpha when some alpha is below 128), `BlpFormatDxt3`, `BlpFormatDxt5`+    or `BlpFormatBgra` (lossless); in both, `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.   - `blpDither`: whether paletted textures are dithered (on by default;@@ -50,10 +59,8 @@    They return `Left` for images they cannot encode (`BlpEncodeError`): an   empty image, a side above 65535 (after `blpMaxSize`), an invalid JPEG-  quality or size limit, or a file over 4 GiB.-- The older `encodeBlpJpeg`, `encodeBlpUncompressedWithAlpha`,-  `encodeBlpUncompressedWithoutAlpha` and their `write` variants are-  deprecated wrappers around `encodeBlpWith`.+  quality or size limit, a format the version does not have (such as+  JPEG in BLP2), or a file over 4 GiB.  The `Codec.Picture.Blp.Internal.*` modules expose the parser, decoder, encoder and file structure. They are useful for tools, but their API may@@ -74,28 +81,44 @@   - 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. Memory use follows the size in the file-  header, so decoding refuses images above 8192×8192 by default; check-  untrusted files with `blpInfo` and set your own limit with-  `decodeBlpWith (BlpDecodeOptions n)`. One known exception: some corrupt JPEG-  streams make JuicyPixels loop forever+  The decoder reports malformed input as a `BlpDecodeError`, including+  errors raised inside JuicyPixels' JPEG decoder. Memory use follows the+  size in the file header, so decoding refuses images above 8192×8192 by+  default; check untrusted files with `blpInfo` and set your own limit with+  `decodeBlpWith (BlpDecodeOptions n)`. 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.+- **Encoding** BLP1 to JPEG or a 256 colour palette, with or without alpha.+  The JPEG header is shared between mipmaps, as in Blizzard's own files.+- **Encoding BLP2** to DXT1, DXT3, DXT5, BGRA or a palette. The DXT encoder+  fits each block along its principal axis and refines it by least squares;+  on test images it is 0.2–0.6 dB below libsquish's cluster fit (1.8 dB on a+  small icon) and 0.7–2.5 dB above a plain range fit.  ## Limitations -- **BLP0, writing BLP2, and BLP2 with JPEG content.** BLP0 keeps mipmaps in-  separate `.b00`–`.b15` files. BLP2 is read only, and its JPEG variant,-  which no known file uses, is rejected. - **Lossy palette.** Uncompressed encoding quantises to 256 colours, so it is   lossy for images with more colours. Mipmaps after the first are mapped to   the first level's palette. - **Fixed header values.** The encoder writes `extra` as 3 with alpha and 5   without, and `hasMipmaps` as 5, or 0 for a single level. +## Out of scope++The library reads and writes every BLP version in use, BLP1 and BLP2.+These are left out on purpose, not for lack of time:++- **BLP0**, which keeps mipmaps in separate `.b00`–`.b15` files and appeared+  only in the Reign of Chaos beta.+- **BLP2 with JPEG content** (`type` 0): no known file uses it, so it is+  rejected rather than guessed at.+- **Writing 1-bit or 4-bit alpha, or chosen `extra` and `hasMipmaps`+  values,** through the public encoder. `Codec.Picture.Blp.Internal.Encoder`+  can write any `BlpStruct`.+- **Archives and other texture formats**, such as MPQ, CASC or the DDS+  textures of Warcraft III: Reforged.+ ## blp2any  Ready-made binaries for Windows, macOS (Apple Silicon) and Linux are@@ -107,7 +130,8 @@  ``` blp2any convert INPUT_PATH OUTPUT_PATH [-i FORMAT] [-f FORMAT] [-q QUALITY]-                [-b jpg|uncompressedWithAlpha|uncompressedWithoutAlpha]+                [-b jpg|uncompressedWithAlpha|uncompressedWithoutAlpha|dxt1|dxt3|dxt5|bgra]+                [--blp2]                 [--min-mipmap-size N] [--max-size PIXELS] [--no-dither]                 [-s|--shallow] [-p|--flatten] [--timeout SECONDS] blp2any stats DIRECTORY OUTPUT_PATH@@ -125,7 +149,9 @@     untrusted input, where some corrupt JPEG data makes decoding hang. The     output never overwrites its input.   - When writing BLP:-    - `-b` picks the internal format, JPEG by default.+    - `-b` picks the internal format, JPEG by default. `dxt1`, `dxt3`,+      `dxt5` and `bgra` write BLP2; the others write BLP1 unless `--blp2`+      is given, which writes a paletted BLP2.     - `--max-size PIXELS` halves the image until its larger side fits;       Warcraft III shows mip levels up to 512 pixels only.     - `--no-dither` turns off dithering for paletted output, which suits@@ -135,10 +161,11 @@       textures without their smallest levels; Warcraft III draws missing       levels as transparent black, so this is only safe for interface       images.-- **`stats`** groups the BLP1 files in a directory by their header values-  and copies one example of each group to `OUTPUT_PATH`. Files it cannot-  read, BLP2 files included, are reported and skipped. It helps when-  hunting for unusual files.+- **`stats`** groups the BLP files in a directory by their header values+  and copies one example of each group to `OUTPUT_PATH`, named after the+  group: content type, `alphaBits`, `extra` and `hasMipmaps` for BLP1, and+  `alphaDepth`, `alphaType` and `hasMips` for BLP2. Files it cannot read are+  reported and skipped. It helps when hunting for unusual files.  ``` blp2any convert war3/ textures-png/ -f png

@@ -11,7 +11,7 @@ import Codec.Picture import Codec.Picture.Blp import Codec.Picture.Blp.Internal.Convert (jpegAlphaIsUsable)-import Codec.Picture.Blp.Internal.Dxt (DxtFormat(..), decodeDxt, dxtLevelBytes)+import Codec.Picture.Blp.Internal.Dxt (DxtFormat(..), decodeDxt, dxtLevelBytes, encodeDxt) import Codec.Picture.Blp.Internal.Encoder (createMipMaps) import Codec.Picture.Jpg (encodeDirectJpegAtQualityWithMetadata) import Control.DeepSeq@@ -52,6 +52,10 @@         bench "decodeDxt/2048 dxt1" $ nf (fmap imageData . decodeDxt (Dxt1 True) 2048 2048) blocks     , env (return . force $ dxtBlocks Dxt5 2048) $ \blocks ->         bench "decodeDxt/2048 dxt5" $ nf (fmap imageData . decodeDxt Dxt5 2048 2048) blocks+    , env (return . force $ convertRGBA8 (texture 512)) $ \img ->+        bench "encodeDxt/512 dxt1" $ nf (encodeDxt (Dxt1 False)) img+    , env (return . force $ convertRGBA8 (texture 512)) $ \img ->+        bench "encodeDxt/512 dxt5" $ nf (encodeDxt Dxt5) img     ]   ] @@ -64,7 +68,7 @@       ]   | n <- sizes ]   where-    pixels img = imageData (convertRGBA8 img)+    pixels = imageData  -- | Encode an image of each size with the given format and level count. encodeGroup :: String -> BlpFormat -> Int -> (Int -> DynamicImage) -> [Int] -> Benchmark

@@ -31,6 +31,10 @@     BlpJpeg   | BlpUncompressedWithAlpha   | BlpUncompressedWithoutAlpha+  | BlpDxt1+  | BlpDxt3+  | BlpDxt5+  | BlpBgra   deriving (Eq, Ord, Show, Enum, Bounded)  readBlpKind :: String -> Maybe BlpKind@@ -41,6 +45,10 @@   "uncompressedwithalpha" -> Just BlpUncompressedWithAlpha   "uncompressed2" -> Just BlpUncompressedWithoutAlpha   "uncompressedwithoutalpha" -> Just BlpUncompressedWithoutAlpha+  "dxt1" -> Just BlpDxt1+  "dxt3" -> Just BlpDxt3+  "dxt5" -> Just BlpDxt5+  "bgra" -> Just BlpBgra   _ -> Nothing  data ConvertFormat =@@ -99,6 +107,7 @@ , convertTimeout        :: Maybe Int , convertDither         :: Bool , convertMaxSize        :: Maybe Int+, convertBlp2           :: Bool }  convertFiles :: ConvertOptions -> IO ()@@ -130,7 +139,7 @@ -- | Try to load input file with desired format readInputFile :: FilePath -> ConvertFormat -> IO (Either String DynamicImage) readInputFile inputFile format = case format of-  Blp -> either (Left . ("parse error: " <>)) Right . decodeBlp <$> BS.readFile inputFile+  Blp -> either (Left . ("parse error: " <>) . displayBlpDecodeError) (Right . ImageRGBA8) . decodeBlp <$> BS.readFile inputFile   Png -> loadJuicy readPng   Jpeg -> loadJuicy readJpeg   Tiff -> loadJuicy readTiff@@ -166,7 +175,7 @@    let mipsCount = mipMapsUpTo convertBlpMinMipSize img   let encodeOptions = defaultBlpEncodeOptions { blpMipLevels = mipsCount, blpDither = convertDither, blpMaxSize = convertMaxSize }-  ExceptT $ convertionFunction distFormat convertQuality convertBlpKind encodeOptions outputFile img+  ExceptT $ convertionFunction distFormat convertQuality convertBlpKind convertBlp2 encodeOptions outputFile img   pure $ inputFile <> ": Success"  -- | A readable message for an encoding error.@@ -177,6 +186,15 @@   BlpInvalidJpegQuality q -> "JPEG quality must be 1 to 100, got " <> show q   BlpFileTooLarge -> "the BLP file would be larger than 4 GiB"   BlpInvalidMaxSize n -> "--max-size must be at least 1, got " <> show n+  BlpUnsupportedFormat v f -> formatName f <> " cannot be written as " <> (if v == Blp1 then "BLP1" else "BLP2")+  where+    formatName f = case f of+      BlpFormatJpeg _ -> "JPEG"+      BlpFormatPaletted _ -> "a palette"+      BlpFormatDxt1 -> "DXT1"+      BlpFormatDxt3 -> "DXT3"+      BlpFormatDxt5 -> "DXT5"+      BlpFormatBgra -> "BGRA"  -- | Run a conversion, giving up after the given number of seconds. withTimeout :: Maybe Int -> IO (Either String a) -> IO (Either String a)@@ -184,14 +202,20 @@ withTimeout (Just seconds) action =   fromMaybe (Left $ "gave up after " <> show seconds <> " s") <$> timeout (seconds * 1000000) action -convertionFunction :: ConvertFormat -> Int -> BlpKind -> BlpEncodeOptions -> FilePath -> DynamicImage -> IO (Either String ())-convertionFunction f quality blpKind encodeOptions path img = case f of+convertionFunction :: ConvertFormat -> Int -> BlpKind -> Bool -> BlpEncodeOptions -> FilePath -> DynamicImage -> IO (Either String ())+convertionFunction f quality blpKind blp2 encodeOptions path img = case f of   Blp -> do     let format = case blpKind of           BlpJpeg -> BlpFormatJpeg quality           BlpUncompressedWithAlpha -> BlpFormatPaletted True           BlpUncompressedWithoutAlpha -> BlpFormatPaletted False-    res <- writeBlpWith path encodeOptions { blpFormat = format } img+          BlpDxt1 -> BlpFormatDxt1+          BlpDxt3 -> BlpFormatDxt3+          BlpDxt5 -> BlpFormatDxt5+          BlpBgra -> BlpFormatBgra+        -- DXT and BGRA exist only in BLP2; a palette goes either way.+        version = if blp2 || blpKind `elem` [BlpDxt1, BlpDxt3, BlpDxt5, BlpBgra] then Blp2 else Blp1+    res <- writeBlpWith path encodeOptions { blpFormat = format, blpVersion = version } img     pure $ either (Left . describeEncodeError) Right res   Png -> do     res <- writeDynamicPng path img

@@ -43,11 +43,12 @@       <*> option qualityR (long "quality" <> short 'q' <> value 90 <> help "Quality level for formats with lossy compression, 1 to 100 (default 90)")       <*> 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 blpKindR (long "blpFormat" <> short 'b' <> value BlpJpeg <> help "Specifies what BLP internal format to use when converting to BLP. Values: jpg uncompressedWithAlpha uncompressedWithoutAlpha (BLP1), dxt1 dxt3 dxt5 bgra (BLP2)")       <*> option auto (long "min-mipmap-size" <> value 1 <> help "Smallest mipmap side to keep when writing BLP (default 1)")       <*> optional (option auto (long "timeout" <> metavar "SECONDS" <> help "Give up on a file after this many seconds; some corrupt JPEG data makes decoding hang"))       <*> fmap not (switch (long "no-dither" <> help "Do not dither paletted BLP textures; better for icons and pixel art"))       <*> optional (option auto (long "max-size" <> metavar "PIXELS" <> help "When writing BLP, halve the image until its larger side is at most this; Warcraft III shows mip levels up to 512 only"))+      <*> switch (long "blp2" <> help "Write BLP2 (World of Warcraft) even for a paletted format; DXT and BGRA always write BLP2")     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")@@ -55,4 +56,4 @@   where     ver = showVersion Paths.version     headerDesc = ""-    desc = "Converting BLP textures to and from PNG, JPEG, TIFF, GIF and BMP. Reads BLP1 (Warcraft III) and BLP2 (World of Warcraft), writes BLP1"+    desc = "Converting BLP textures to and from PNG, JPEG, TIFF, GIF and BMP. Reads BLP1 (Warcraft III) and BLP2 (World of Warcraft), writes both"

@@ -5,6 +5,7 @@   ) where  import Codec.Picture.Blp.Internal.Data+import Codec.Picture.Blp (BlpVersion(..), displayBlpDecodeError) import Codec.Picture.Blp.Internal.Parser import Control.Monad import Data.Char (toLower)@@ -19,7 +20,11 @@  import File  -type BlpInfo = (BlpCompression, Word32, Word32, Word32)+-- | What files are grouped by: version, content type and the header fields+-- that vary between files, with their names.+data BlpInfo = BlpInfo BlpVersion BlpCompression [(String, Word32)]+  deriving (Eq, Ord)+ type BlpStat = (FilePath, Int)  type StatMap = M.Map BlpInfo BlpStat@@ -33,7 +38,7 @@ collectSample :: StatMap -> FilePath -> IO StatMap collectSample stats inputFile = do   putStrLn $ "Sampling " ++ inputFile-  result <- tryAll (parseBlp <$> BS.readFile inputFile)+  result <- tryAll (either (Left . displayBlpDecodeError) Right . parseBlpFile <$> BS.readFile inputFile)   case join result of     Left err -> do       -- One unreadable file should not lose the statistics of the rest.@@ -41,8 +46,11 @@       return stats     Right blp -> return $ adjust' (updateStat inputFile) (blpType blp) stats -blpType :: BlpStruct -> BlpInfo -blpType blp@BlpStruct{..} = (blpCompression blp, blpAlphaBits, blpExtra, blpHasMipmaps)+blpType :: BlpFile -> BlpInfo+blpType (BlpFile1 blp@BlpStruct{..}) = BlpInfo Blp1 (blpCompression blp)+  [("alpha", blpAlphaBits), ("extra", blpExtra), ("mips", blpHasMipmaps)]+blpType (BlpFile2 blp@Blp2Struct{..}) = BlpInfo Blp2 (blp2Compression blp)+  [("alpha", fromIntegral blp2AlphaDepth), ("alphaType", fromIntegral blp2AlphaType), ("mips", fromIntegral blp2HasMips)]  adjust' :: (Maybe BlpStat -> BlpStat) -> BlpInfo -> StatMap -> StatMap  adjust' f k m = M.insert k (f $ M.lookup k m) m@@ -54,8 +62,8 @@ printStatistics :: FilePath -> StatMap -> IO ()  printStatistics dir stats = do     createDirectoryIfMissing True dir-    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]+    forM_ (M.toList stats) $ \(BlpInfo version compression fields, (path, i)) -> do+      let postfix = L.intercalate "-" $ [show version | version /= Blp1] ++ show compression : [name ++ show v | (name, v) <- fields]       copyFile path $ dir </> dropExtension (takeFileName path) ++ "-" ++ postfix ++ ".blp"       putStrLn $ postfix ++ ": " ++ show i ++ " images" 

@@ -1,11 +1,10 @@ # The BLP format  BLP ("Blizzard Picture") is the texture format of Warcraft III (BLP1) and-World of Warcraft (BLP2). This library reads and writes **BLP1** and reads-**BLP2**. This page describes the format as the community has documented-it, and states for each part what the library does with it, including where-it falls short. The sections up to [BLP2](#blp2-world-of-warcraft) are about-BLP1.+World of Warcraft (BLP2). This library reads and writes both. This page+describes the format as the community has documented it, and states for+each part what the library does with it, including where it falls short.+The sections up to [BLP2](#blp2-world-of-warcraft) are about BLP1.  Primary sources: @@ -122,8 +121,8 @@   (8192×8192 by default) before allocating anything. `blpInfo` reads the   size without decoding. - **JuicyPixels.** The JPEG streams themselves are decoded by JuicyPixels.-  Errors it raises are turned into `Left`, but some corrupt streams make it-  loop forever+  Errors it raises on mip 0 become a `BlpCorruptImage`, and on a later level+  end the list of levels, 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.@@ -164,7 +163,7 @@  ## BLP2 (World of Warcraft) -The library reads BLP2 files; it does not write them. The sections above+The library reads and writes BLP2 files. The sections above apply where noted.  ### Header@@ -230,6 +229,31 @@  Four bytes per pixel: blue, green, red and alpha. +### Writing++`encodeBlpWith` with `blpVersion = Blp2` writes type 1 files. The header+values follow files from World of Warcraft:++| `blpFormat` | encoding | alphaDepth | alphaType |+|---|---|---|---|+| `BlpFormatPaletted True` / `False` | 1 | 8 / 0 | 8 |+| `BlpFormatDxt1` | 2 | 1 if some alpha is below 128, else 0 | 0 |+| `BlpFormatDxt3` | 2 | 8 | 1 |+| `BlpFormatDxt5` | 2 | 8 | 7 |+| `BlpFormatBgra` | 3 | 8 | 8 |++hasMips is 1, or 0 for a single level. The palette is written in full for+paletted content and as zeros otherwise, and the levels follow it. Mipmaps+are made as for BLP1, by averaging 2×2 blocks weighted by alpha.++The DXT encoder fits each block's colours along their principal axis,+refines the two endpoints by least squares while that lowers the error, and+compares the result with endpoints from a single-colour table, which decodes+flat colours exactly where rounding to RGB565 would not. Errors are measured+on what the decoder above gives back. DXT1 with alpha makes blocks with+pixels below alpha 128 three-colour, those pixels transparent. DXT3 rounds+alpha to the nearest of its 16 levels, and DXT5 tries both alpha modes.+ ### Damaged levels  As in BLP1, a level 0 too short for its size fails the file, and the list of@@ -249,7 +273,7 @@ ## Not supported  - **BLP0**, which stores each mip level in a separate `.b00` … `.b15` file.-- **Writing BLP2**, and BLP2 files with JPEG content (`type = 0`).+- **BLP2 files with JPEG content** (`type = 0`). - **Writing 1-bit or 4-bit alpha**, or a chosen `extra` or `hasMipmaps`   value, through the public encoders. `Codec.Picture.Blp.Internal.Encoder`   can write any `BlpStruct`.

@@ -1,7 +1,7 @@ {-| Decoding and encoding of BLP, the texture format of Warcraft III (BLP1) and-World of Warcraft (BLP2), on top of JuicyPixels. BLP1 is read and written,-BLP2 is read.+World of Warcraft (BLP2), on top of JuicyPixels. Both versions are read and+written.  BLP1 comes in two flavours: JPEG compressed and uncompressed with a 256 colour palette. Uncompressed textures either carry an alpha plane or not.@@ -9,12 +9,13 @@ file holds the full size image followed by its mipmaps, each half the size of the previous one. -Decoding always yields 'ImageRGBA8'. Files from the wild are often slightly-off spec; the decoder accepts the common deviations and, when a mipmap is-damaged, keeps the levels before it.+Decoding yields t'Image' t'PixelRGBA8' whatever the content, and reports+files it cannot read as a 'BlpDecodeError'. Files from the wild are often+slightly off spec; the decoder accepts the common deviations and, when a+mipmap is damaged, keeps the levels before it.  > Right img <- readBlp "war3mapMap.blp"-> writePng "war3mapMap.png" (convertRGBA8 img)+> writePng "war3mapMap.png" img > > Right png <- readImage "icon.png" > result <- writeBlpWith "icon.blp" defaultBlpEncodeOptions png@@ -32,6 +33,8 @@   , decodeBlpMipmapsWith   , BlpDecodeOptions(..)   , defaultBlpDecodeOptions+  , BlpDecodeError(..)+  , displayBlpDecodeError   -- * Inspecting   , blpInfo   , BlpInfo(..)@@ -45,15 +48,6 @@   , 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   ) where  import Codec.Picture@@ -70,44 +64,43 @@  -- | Read a BLP file and decode its full size image. IO errors, such as a -- missing file, are thrown; malformed contents give 'Left'.-readBlp :: FilePath -> IO (Either String DynamicImage)+readBlp :: FilePath -> IO (Either BlpDecodeError (Image PixelRGBA8)) readBlp fp = decodeBlp `fmap` BS.readFile fp  -- | Read a BLP file and decode the full size image followed by its mipmaps. -- See 'decodeBlpMipmaps'.-readBlpMipmaps :: FilePath -> IO (Either String [DynamicImage])+readBlpMipmaps :: FilePath -> IO (Either BlpDecodeError [Image PixelRGBA8]) readBlpMipmaps fp = decodeBlpMipmaps `fmap` BS.readFile fp  -- | Decode the full size image of a BLP file with 'defaultBlpDecodeOptions'.--- The result is 'ImageRGBA8'.-decodeBlp :: ByteString -> Either String DynamicImage+decodeBlp :: ByteString -> Either BlpDecodeError (Image PixelRGBA8) decodeBlp = decodeBlpWith defaultBlpDecodeOptions --- | Decode the full size image of a BLP file. The result is 'ImageRGBA8'.-decodeBlpWith :: BlpDecodeOptions -> ByteString -> Either String DynamicImage+-- | Decode the full size image of a BLP file.+decodeBlpWith :: BlpDecodeOptions -> ByteString -> Either BlpDecodeError (Image PixelRGBA8) decodeBlpWith opts bs = do   is <- decodeBlpMipmapsWith opts bs   case is of     i : _ -> Right i-    [] -> Left "No data in BLP"+    [] -> Left BlpNoImageData  -- | Decode the full size image followed by its mipmaps with -- 'defaultBlpDecodeOptions'. See 'decodeBlpMipmapsWith'.-decodeBlpMipmaps :: ByteString -> Either String [DynamicImage]+decodeBlpMipmaps :: ByteString -> Either BlpDecodeError [Image PixelRGBA8] decodeBlpMipmaps = decodeBlpMipmapsWith defaultBlpDecodeOptions --- | Decode the full size image followed by its mipmaps, all 'ImageRGBA8'.+-- | Decode the full size image followed by its mipmaps. -- -- Element @i@ is always mip level @i@. Mipmaps are decoded lazily, and the -- list stops at the first one that is damaged, so a broken mipmap never -- costs the levels before it. A damaged full size image fails the file.-decodeBlpMipmapsWith :: BlpDecodeOptions -> ByteString -> Either String [DynamicImage]+decodeBlpMipmapsWith :: BlpDecodeOptions -> ByteString -> Either BlpDecodeError [Image PixelRGBA8] decodeBlpMipmapsWith opts bs = parseBlpFile bs >>= decodeBlpFile opts  -- | Read the header of a BLP file. This checks what 'decodeBlp' checks before -- decoding (format, size, mipmap slots) but decodes no pixels, so it is cheap -- on any input. Use it to reject textures that are too large.-blpInfo :: ByteString -> Either String BlpInfo+blpInfo :: ByteString -> Either BlpDecodeError BlpInfo blpInfo bs = blpFileInfo <$> parseBlpFile bs  -- | Number of mip levels, mip 0 included, whose larger side is at least the@@ -119,65 +112,35 @@   -> Int mipMapsUpTo minSize img = max 1 $ mipLevelsDownTo minSize (dynamicMap imageWidth img) (dynamicMap imageHeight img) --- | Encode an image as a BLP1 file.+-- | Encode an image as a BLP1 or BLP2 file, as 'blpVersion' says. encodeBlpWith :: BlpEncodeOptions -> DynamicImage -> Either BlpEncodeError BSL.ByteString encodeBlpWith opts@BlpEncodeOptions{..} img   | dynamicMap imageWidth img < 1 || dynamicMap imageHeight img < 1 = Left BlpEmptyImage+  | not (formatInVersion blpVersion blpFormat) = Left $ BlpUnsupportedFormat blpVersion blpFormat   | Just limit <- blpMaxSize, limit < 1 = Left $ BlpInvalidMaxSize limit   | w > 65535 || h > 65535 = Left $ BlpImageTooLarge w h   | BlpFormatJpeg quality <- blpFormat, quality < 1 || quality > 100 = Left $ BlpInvalidJpegQuality quality-  | BSL.length file > 0xFFFFFFFF = Left BlpFileTooLarge-  | otherwise = Right file+  | otherwise = do+      file <- case blpVersion of+        Blp1 -> encodeBlp <$> toBlpStruct opts source+        Blp2 -> encodeBlp2 <$> toBlp2Struct opts source+      if BSL.length file > 0xFFFFFFFF then Left BlpFileTooLarge else Right file   where     source = maybe img (`shrinkTo` img) blpMaxSize     w = dynamicMap imageWidth source     h = dynamicMap imageHeight source-    file = encodeBlp (toBlpStruct opts source) +-- | Whether a version of the format can hold the content type.+formatInVersion :: BlpVersion -> BlpFormat -> Bool+formatInVersion version format = case (version, format) of+  (_, BlpFormatPaletted _) -> True+  (Blp1, BlpFormatJpeg _) -> True+  (Blp2, BlpFormatDxt1) -> True+  (Blp2, BlpFormatDxt3) -> True+  (Blp2, BlpFormatDxt5) -> True+  (Blp2, BlpFormatBgra) -> True+  _ -> False+ -- | 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 = 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 = 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 = BSL.writeFile fp $ encodeBlpUncompressedWithoutAlpha numMips img-{-# DEPRECATED writeBlpUncompressedWithoutAlpha "Use writeBlpWith" #-}---- | 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 =-  orThrow "encodeBlpJpeg" . encodeBlpWith defaultBlpEncodeOptions { blpFormat = BlpFormatJpeg (max 1 (min 100 quality)), blpMipLevels = numMips }-{-# DEPRECATED encodeBlpJpeg "Use encodeBlpWith with BlpFormatJpeg" #-}---- | Encode with a 256 colour palette and 8-bit alpha; see 'BlpFormatPaletted'.-encodeBlpUncompressedWithAlpha :: Int -- ^ Number of mip levels to write-  -> DynamicImage-  -> BSL.ByteString-encodeBlpUncompressedWithAlpha numMips =-  orThrow "encodeBlpUncompressedWithAlpha" . encodeBlpWith defaultBlpEncodeOptions { blpFormat = BlpFormatPaletted True, blpMipLevels = numMips }-{-# DEPRECATED encodeBlpUncompressedWithAlpha "Use encodeBlpWith with BlpFormatPaletted True" #-}---- | Encode with a 256 colour palette and no alpha; see 'BlpFormatPaletted'.-encodeBlpUncompressedWithoutAlpha :: Int -- ^ Number of mip levels to write-  -> DynamicImage-  -> BSL.ByteString-encodeBlpUncompressedWithoutAlpha numMips =-  orThrow "encodeBlpUncompressedWithoutAlpha" . encodeBlpWith defaultBlpEncodeOptions { blpFormat = BlpFormatPaletted False, blpMipLevels = numMips }-{-# DEPRECATED encodeBlpUncompressedWithoutAlpha "Use encodeBlpWith with BlpFormatPaletted False" #-}--orThrow :: String -> Either BlpEncodeError a -> a-orThrow name = either (\e -> error $ name ++ ": " ++ show e) id

@@ -33,22 +33,22 @@ import Codec.Picture.Blp.Internal.Parser import Codec.Picture.Blp.Types --- | Decode the full size image of a parsed file followed by its mipmaps, all--- 'ImageRGBA8'. See 'Codec.Picture.Blp.decodeBlpMipmapsWith'.-decodeBlpStruct :: BlpDecodeOptions -> BlpStruct -> Either String [DynamicImage]+-- | Decode the full size image of a parsed file followed by its mipmaps.+-- See 'Codec.Picture.Blp.decodeBlpMipmapsWith'.+decodeBlpStruct :: BlpDecodeOptions -> BlpStruct -> Either BlpDecodeError [Image PixelRGBA8] decodeBlpStruct opts blp = do   let width = fromIntegral $ blpWidth blp       height = fromIntegral $ blpHeight blp   checkSize opts width height   case blpExt blp of     BlpJpeg {..} -> case blpJpegData of-      [] -> Left "No JPEG mipmap data in BLP"+      [] -> Left BlpNoImageData       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+        mip0 <- either (Left . BlpCorruptImage) Right (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@@ -69,11 +69,11 @@         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+          else either (Left . (("JPEG mipmap " ++ show l ++ ": ") ++)) Right (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+        in 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@@ -81,10 +81,10 @@     BlpPaletted {..} -> palettedImages width height (fromIntegral (blpAlphaBits blp)) blpPalette blpPalettedMipMaps  -- | Decode the full size image of a parsed BLP2 file followed by its--- mipmaps, all 'ImageRGBA8'. Levels are taken as in BLP1: a damaged level 0+-- mipmaps. Levels are taken as in BLP1: a damaged level 0 -- fails the file, and the list stops at the first damaged mipmap. An alpha -- depth of 0 makes every level opaque.-decodeBlp2Struct :: BlpDecodeOptions -> Blp2Struct -> Either String [DynamicImage]+decodeBlp2Struct :: BlpDecodeOptions -> Blp2Struct -> Either BlpDecodeError [Image PixelRGBA8] decodeBlp2Struct opts blp = do   checkSize opts width height   case blp2Content blp of@@ -96,10 +96,10 @@     height = fromIntegral $ blp2Height blp     finish = if blp2AlphaDepth blp == 0 then setOpaque else id     levels decode = case blp2MipMaps blp of-      [] -> Left "No mipmap data in BLP2"+      [] -> Left BlpNoImageData       mips -> case [decode (levelSize width height l) mip | (l, mip) <- zip [0 ..] mips] of-        Left e : _ -> Left $ "Mipmap 0: " ++ e-        decoded -> Right [ImageRGBA8 (finish img) | Right img <- takeWhile isRight decoded]+        Left e : _ -> Left (BlpCorruptImage e)+        decoded -> Right [finish img | Right img <- takeWhile isRight decoded]  -- | A level of four bytes per pixel, B, G, R and A. bgraLevel :: (Int, Int) -> ByteString -> Either String (Image PixelRGBA8)@@ -115,15 +115,14 @@ setOpaque = pixelMap (\(PixelRGBA8 r g b _) -> PixelRGBA8 r g b 255)  -- | Reject an image above the size limit before anything is allocated.-checkSize :: BlpDecodeOptions -> Int -> Int -> Either String ()+checkSize :: BlpDecodeOptions -> Int -> Int -> Either BlpDecodeError () checkSize opts width height = when (width * height > blpMaxPixels opts) . Left $-  "Image size " ++ show width ++ "x" ++ show height ++ " is above the limit of "-  ++ show (blpMaxPixels opts) ++ " pixels"+  BlpTooLarge width height (blpMaxPixels opts)  -- | Paletted levels with the declared alpha depth, if it is valid for -- paletted content. A mip 0 too short to hold that much alpha has none: -- some tools declare alpha and then write only the index list.-palettedImages :: Int -> Int -> Int -> V.Vector PixelRGBA8 -> [ByteString] -> Either String [DynamicImage]+palettedImages :: Int -> Int -> Int -> V.Vector PixelRGBA8 -> [ByteString] -> Either BlpDecodeError [Image PixelRGBA8] palettedImages width height declaredBits palette mips = palettedLevels width height alphaBits palette mips   where     declared = if declaredBits `elem` [1, 4, 8] then declaredBits else 0@@ -132,7 +131,7 @@       _ -> declared  -- | Decode a parsed BLP1 or BLP2 file.-decodeBlpFile :: BlpDecodeOptions -> BlpFile -> Either String [DynamicImage]+decodeBlpFile :: BlpDecodeOptions -> BlpFile -> Either BlpDecodeError [Image PixelRGBA8] decodeBlpFile opts (BlpFile1 blp) = decodeBlpStruct opts blp decodeBlpFile opts (BlpFile2 blp) = decodeBlp2Struct opts blp @@ -180,16 +179,16 @@ -- @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 :: Int -> Int -> Int -> V.Vector PixelRGBA8 -> [ByteString] -> Either BlpDecodeError [Image PixelRGBA8] palettedLevels width height alphaBits palette mips-  | null mips = Right []+  | null mips = Left BlpNoImageData   | otherwise = case go 0 mips of-      [] -> Left "Mipmap 0 is too short for the image size"+      [] -> Left (BlpCorruptImage "mip 0 is too short for the image size")       levels -> Right levels   where     go l (mip : rest)       | BS.length mip >= levelBytes (w * h) alphaBits =-          ImageRGBA8 (generateImage (pixel w (BS.drop (w * h) mip) mip) w h) : go (l + 1) rest+          generateImage (pixel w (BS.drop (w * h) mip) mip) w h : go (l + 1) rest       where         (w, h) = levelSize width height l     go _ _ = []

@@ -26,18 +26,22 @@     DxtFormat(..)   , dxtLevelBytes   , decodeDxt+  , encodeDxt   ) where  import Codec.Picture-import Control.Monad (when)+import Control.Monad (forM_, when) import Control.Monad.ST (ST) import Data.Bits+import qualified Data.List as L import Data.ByteString (ByteString) import Data.Word  import qualified Data.ByteString as BS+import qualified Data.ByteString.Internal as BI import qualified Data.ByteString.Unsafe as BSU import qualified Data.Vector.Storable as VS+import qualified Data.Vector.Unboxed as VU import qualified Data.Vector.Storable.Mutable as MVS  -- | Block compression formats.@@ -142,14 +146,7 @@       Dxt5 -> word (o + 2) 6     !a0 = byte o     !a1 = byte (o + 1)-    dxt5Alpha :: Int -> Int-    dxt5Alpha j = case j of-      0 -> a0-      1 -> a1-      _ | a0 > a1 -> ((8 - j) * a0 + (j - 1) * a1) `quot` 7-        | j < 6 -> ((6 - j) * a0 + (j - 1) * a1) `quot` 5-        | j == 6 -> 0-        | otherwise -> 255+    dxt5Alpha = dxt5AlphaValue a0 a1      -- Copying a pixel as one 32-bit word keeps its bytes in order on any     -- platform.@@ -180,3 +177,304 @@  asWord32 :: MVS.MVector s Word8 -> MVS.MVector s Word32 asWord32 = MVS.unsafeCast++-- | Alpha value of 3-bit index @j@ in a DXT5 block with endpoints @a0@ and+-- @a1@: six interpolated values between them if @a0 > a1@, otherwise four+-- plus 0 and 255.+dxt5AlphaValue :: Int -> Int -> Int -> Int+dxt5AlphaValue a0 a1 j = case j of+  0 -> a0+  1 -> a1+  _ | a0 > a1 -> ((8 - j) * a0 + (j - 1) * a1) `quot` 7+    | j < 6 -> ((6 - j) * a0 + (j - 1) * a1) `quot` 5+    | j == 6 -> 0+    | otherwise -> 255++------------------------------------------------------------------------------+-- Encoding++-- | Encode an image as DXT blocks, 'dxtLevelBytes' long.+--+-- Colours are fitted per block along the principal axis of the block's+-- pixels (range fit), and the endpoints are then refined by least squares+-- for the chosen indices while that lowers the error. Errors are measured+-- on what 'decodeDxt' gives back. DXT1 with 'True' writes blocks with+-- pixels whose alpha is below 128 in three-colour mode, those pixels+-- transparent; with 'False' alpha is ignored. DXT3 alpha is rounded to 4+-- bits; DXT5 alpha takes whichever of its two modes fits the block better.+-- Pixels outside the image, in blocks on the right and bottom edges, do not+-- count.+encodeDxt :: DxtFormat -> Image PixelRGBA8 -> ByteString+encodeDxt fmt img = BI.fromForeignPtr fptr 0 len+  where+    w = imageWidth img+    h = imageHeight img+    src = imageData img+    blocksWide = (w + 3) `div` 4+    blocksHigh = (h + 3) `div` 4+    size = blockBytes fmt+    (fptr, len) = VS.unsafeToForeignPtr0 $ VS.create $ do+      dst <- MVS.new (blocksWide * blocksHigh * size)+      forM_ [0 .. blocksHigh - 1] $ \by -> forM_ [0 .. blocksWide - 1] $ \bx ->+        encodeBlock fmt (blockPixels bx by) dst ((by * blocksWide + bx) * size)+      return dst+    -- The pixels of a block inside the image, in order, with their index in+    -- the block.+    blockPixels bx by+      | 4 * bx + 3 < w && 4 * by + 3 < h = gather wholeBlock+      | otherwise = gather (VU.filter (\i -> 4 * bx + i .&. 3 < w && 4 * by + i `shiftR` 2 < h) wholeBlock)+      where+        gather pos =+          let channel c = VU.map (\i -> fromIntegral (VS.unsafeIndex src (4 * ((4 * by + i `shiftR` 2) * w + 4 * bx + i .&. 3) + c))) pos+          in Pixels pos (channel 0) (channel 1) (channel 2) (channel 3)++-- | The positions of a block's 16 pixels.+wholeBlock :: VU.Vector Int+wholeBlock = VU.enumFromN 0 16++-- | Some of a block's pixels: their index in the block and their channels.+data Pixels = Pixels !(VU.Vector Int) !(VU.Vector Int) !(VU.Vector Int) !(VU.Vector Int) !(VU.Vector Int)++-- | Write one block at the given byte offset.+encodeBlock :: DxtFormat -> Pixels -> MVS.MVector s Word8 -> Int -> ST s ()+encodeBlock fmt px dst o = case fmt of+  Dxt1 transparent -> encodeColour transparent False px dst o+  Dxt3 -> dxt3AlphaBlock px dst o >> encodeColour False True px dst (o + 8)+  Dxt5 -> dxt5AlphaBlock px dst o >> encodeColour False True px dst (o + 8)++-- | Write the low n bytes of a number, least significant first.+putLE :: MVS.MVector s Word8 -> Int -> Int -> Int -> ST s ()+putLE dst o n v = forM_ [0 .. n - 1] $ \k -> MVS.unsafeWrite dst (o + k) (fromIntegral (v `shiftR` (8 * k)))++-- | A colour block. With @transparent@, pixels with alpha below 128 make the+-- block three-colour with them at index 3. With @fourAlways@ (DXT3 and+-- DXT5), the decoder uses four colours whatever the endpoint order.+encodeColour :: Bool -> Bool -> Pixels -> MVS.MVector s Word8 -> Int -> ST s ()+encodeColour transparent fourAlways (Pixels pos rs gs bs as) dst o = do+  putLE dst o 2 c0+  putLE dst (o + 2) 2 c1+  putLE dst (o + 4) 4 (indices .|. clearBits)+  where+    isClear j = transparent && VU.unsafeIndex as j < 128+    keep = VU.filter (not . isClear) (VU.enumFromN 0 (VU.length pos))+    clearBits = VU.foldl' (\acc j -> if isClear j then acc .|. 3 `shiftL` (2 * VU.unsafeIndex pos j) else acc) 0 (VU.enumFromN 0 (VU.length pos))+    threeColour = VU.length keep < VU.length pos+    -- The pixels the colours are fitted to.+    fpos = VU.map (VU.unsafeIndex pos) keep+    pr = VU.map (VU.unsafeIndex rs) keep+    pg = VU.map (VU.unsafeIndex gs) keep+    pb = VU.map (VU.unsafeIndex bs) keep+    n = VU.length keep++    -- A candidate replaces the best only with a strictly lower error, so+    -- none is tried once the error is 0, nor endpoints already tried.+    Fit c0 c1 _ indices+      | n == 0 = Fit 0 0 0 0 -- all transparent+      | otherwise =+          let fitted = refine (3 :: Int) (assign (endpoints (rangeFit pr pg pb)))+          in if fitError fitted == 0 then fitted else better fitted (assign single)+    better a b = if fitError b < fitError a then b else a+    refine 0 best = best+    refine k best@(Fit e0 e1 err _)+      | err == 0 || ends == (e0, e1) = best+      | fitError next < err = refine (k - 1) next+      | otherwise = best+      where+        ends = endpoints (leastSquares best)+        next = assign ends++    -- Endpoints in the order the mode needs: c0 > c1 for four colours,+    -- c0 <= c1 for three.+    endpoints (a, b)+      | threeColour = (min qa qb, max qa qb)+      | otherwise = (max qa qb, min qa qb)+      where+        qa = pack565 a+        qb = pack565 b++    -- The nearest usable colour for every pixel, packed as 2-bit indices by+    -- position in the block, and the total error.+    assign (e0, e1) =+      let four = fourAlways || e0 > e1+          pal = palette four e0 e1+          -- The error of colour k, times 4, plus k: the smallest is the+          -- nearest colour, the lower index on ties. One number instead of a+          -- pair keeps the loop free of allocation.+          nearest j =+            let r = VU.unsafeIndex pr j; g = VU.unsafeIndex pg j; b = VU.unsafeIndex pb j+                cost k = 4 * (sq (r - VU.unsafeIndex pal (3 * k)) + sq (g - VU.unsafeIndex pal (3 * k + 1)) + sq (b - VU.unsafeIndex pal (3 * k + 2))) + k+                three = min (cost 0) (min (cost 1) (cost 2))+            in if four then min three (cost 3) else three+          loop j !err !bits+            | j >= n = Fit e0 e1 err bits+            | otherwise =+                let c = nearest j+                in loop (j + 1) (err + c `shiftR` 2) (bits .|. (c .&. 3) `shiftL` (2 * VU.unsafeIndex fpos j))+      in loop 0 0 0++    -- Endpoints that best reproduce the pixels with their current indices:+    -- index k stands for weight w_k of the first endpoint and 1 - w_k of the+    -- second.+    leastSquares (Fit e0 e1 _ packed) =+      let four = fourAlways || e0 > e1+          weight :: Int -> Double+          weight k = case k of+            0 -> 1+            1 -> 0+            2 -> if four then 2 / 3 else 1 / 2+            _ -> 1 / 3+          step (Sums aa bb2 ab2 ar0 ag0 ab0 br0 bg0 bb0) j =+            let a = weight ((packed `shiftR` (2 * VU.unsafeIndex fpos j)) .&. 3)+                b' = 1 - a+                fr = fromIntegral (VU.unsafeIndex pr j)+                fg = fromIntegral (VU.unsafeIndex pg j)+                fb = fromIntegral (VU.unsafeIndex pb j)+            in Sums (aa + a * a) (bb2 + b' * b') (ab2 + a * b')+                 (ar0 + a * fr) (ag0 + a * fg) (ab0 + a * fb)+                 (br0 + b' * fr) (bg0 + b' * fg) (bb0 + b' * fb)+          Sums saa sbb sab ar ag ab br bg bb = L.foldl' step (Sums 0 0 0 0 0 0 0 0 0) [0 .. n - 1]+          det = saa * sbb - sab * sab+          sap = (ar, ag, ab)+          sbp = (br, bg, bb)+      in if abs det < 1e-9+           then rangeFit pr pg pb+           else ( scale (1 / det) (sub (scale sbb sap) (scale sab sbp))+                , scale (1 / det) (sub (scale saa sbp) (scale sab sap)) )++    -- A block of nearly one colour is best served by endpoints whose+    -- intermediate colour decodes to it exactly, which the range fit cannot+    -- find: it rounds both endpoints to the nearest RGB565 colour.+    single =+      let avg v = (VU.sum v + n `div` 2) `div` n+          table5 = if threeColour then three5 else four5+          table6 = if threeColour then three6 else four6+          (r0, r1) = table5 VU.! avg pr+          (g0, g1) = table6 VU.! avg pg+          (b0, b1) = table5 VU.! avg pb+          e0 = r0 `shiftL` 11 .|. g0 `shiftL` 5 .|. b0+          e1 = r1 `shiftL` 11 .|. g1 `shiftL` 5 .|. b1+      in if threeColour then (min e0 e1, max e0 e1) else (max e0 e1, min e0 e1)++sq :: Int -> Int+sq x = x * x++-- | Endpoints of a colour block, the error of the pixels, and their 2-bit+-- indices packed by position in the block.+data Fit = Fit !Int !Int !Int !Int++fitError :: Fit -> Int+fitError (Fit _ _ err _) = err++-- | Nine running sums, for the least squares fit and the covariance.+data Sums = Sums !Double !Double !Double !Double !Double !Double !Double !Double !Double++-- | Two points spanning the pixels along their principal axis.+rangeFit :: VU.Vector Int -> VU.Vector Int -> VU.Vector Int -> (V3, V3)+rangeFit pr pg pb = (along hi, along lo)+  where+    count = VU.length pr+    pointAt j = (fromIntegral (VU.unsafeIndex pr j), fromIntegral (VU.unsafeIndex pg j), fromIntegral (VU.unsafeIndex pb j)) :: V3+    -- Sums of the channels and of their products, in one pass.+    moment (Sums r g b rr gg bb rg rb gb) j =+      let (x, y, z) = pointAt j+      in Sums (r + x) (g + y) (b + z) (rr + x * x) (gg + y * y) (bb + z * z) (rg + x * y) (rb + x * z) (gb + y * z)+    Sums sr sg sb srr sgg sbb srg srb sgb = L.foldl' moment (Sums 0 0 0 0 0 0 0 0 0) [0 .. count - 1]+    n = fromIntegral count+    m@(mr, mg, mb) = (sr / n, sg / n, sb / n)+    -- Covariance matrix, times n.+    cxx = srr - n * mr * mr; cyy = sgg - n * mg * mg; czz = sbb - n * mb * mb+    cxy = srg - n * mr * mg; cxz = srb - n * mr * mb; cyz = sgb - n * mg * mb+    cov (x, y, z) = (cxx * x + cxy * y + cxz * z, cxy * x + cyy * y + cyz * z, cxz * x + cyz * y + czz * z)+    power v = let v' = cov v; l = norm v' in if l < 1e-9 then v else scale (1 / l) v'+    -- Start from the pixel farthest from the mean: unlike a fixed vector, it+    -- is never orthogonal to the spread, which would collapse the fit.+    farthest = snd $ L.foldl' (\best@(bd, _) j -> let d = sub (pointAt j) m; l = dot d d in if l > bd then (l, d) else best) (0, (1, 1, 1)) [0 .. count - 1]+    axis = iterate power farthest !! 8+    (lo, hi) = L.foldl' (\(a, b) j -> let t = dot (sub (pointAt j) m) axis in (min a t, max b t)) (1 / 0, -1 / 0) [0 .. count - 1]+    along t = add m (scale t axis)++type V3 = (Double, Double, Double)++add, sub :: V3 -> V3 -> V3+add (a, b, c) (d, e, f) = (a + d, b + e, c + f)+sub (a, b, c) (d, e, f) = (a - d, b - e, c - f)++scale :: Double -> V3 -> V3+scale k (a, b, c) = (k * a, k * b, k * c)++dot :: V3 -> V3 -> Double+dot (a, b, c) (d, e, f) = a * d + b * e + c * f++norm :: V3 -> Double+norm v = sqrt (dot v v)++-- | The nearest RGB565 colour.+pack565 :: V3 -> Int+pack565 (r, g, b) = q r 31 `shiftL` 11 .|. q g 63 `shiftL` 5 .|. q b 31+  where q v m = max 0 . min m $ round (v * fromIntegral m / 255)++-- | The four colours of a block as 'decodeDxt' computes them, as R, G, B+-- triples.+palette :: Bool -> Int -> Int -> VU.Vector Int+palette four e0 e1 = VU.fromListN 12+  [ r0, g0, b0, r1, g1, b1+  , mix2 r0 r1, mix2 g0 g1, mix2 b0 b1+  , mix3 r0 r1, mix3 g0 g1, mix3 b0 b1 ]+  where+    (r0, g0, b0) = (expand5 (e0 `shiftR` 11), expand6 (e0 `shiftR` 5), expand5 e0)+    (r1, g1, b1) = (expand5 (e1 `shiftR` 11), expand6 (e1 `shiftR` 5), expand5 e1)+    mix2 a b = if four then (2 * a + b) `quot` 3 else (a + b) `quot` 2+    mix3 a b = if four then (a + 2 * b) `quot` 3 else 0++-- | DXT3 alpha: 4 bits per pixel, rounded.+dxt3AlphaBlock :: Pixels -> MVS.MVector s Word8 -> Int -> ST s ()+dxt3AlphaBlock (Pixels pos _ _ _ as) dst o = putLE dst o 8 bits+  where+    bits = VU.ifoldl' (\acc j a -> acc .|. min 15 ((a + 8) `div` 17) `shiftL` (4 * VU.unsafeIndex pos j)) 0 as++-- | DXT5 alpha: endpoints and 3-bit indices, in whichever mode has the+-- smaller squared error. The six-step mode spans the block's alphas; the+-- four-step mode spans those other than 0 and 255, which it has exactly.+dxt5AlphaBlock :: Pixels -> MVS.MVector s Word8 -> Int -> ST s ()+dxt5AlphaBlock (Pixels pos _ _ _ as) dst o = do+  MVS.unsafeWrite dst o (fromIntegral a0)+  MVS.unsafeWrite dst (o + 1) (fromIntegral a1)+  putLE dst (o + 2) 6 bits+  where+    inner = VU.filter (\v -> v /= 0 && v /= 255) as+    six = (VU.maximum as, VU.minimum as)+    four = if VU.null inner then (0, 0) else (VU.minimum inner, VU.maximum inner)+    -- The nearest table entry for every alpha, packed as 3-bit indices by+    -- position, and the total error. As for colours, the error times 8+    -- plus the index finds both at once.+    assign (e0, e1) =+      let table = VU.generate 8 (dxt5AlphaValue e0 e1)+          nearest v = VU.minimum (VU.imap (\j t -> 8 * sq (v - t) + j) table)+          loop j !err !packed+            | j >= VU.length as = (err, packed)+            | otherwise =+                let c = nearest (VU.unsafeIndex as j)+                in loop (j + 1) (err + c `shiftR` 3) (packed .|. (c .&. 7) `shiftL` (3 * VU.unsafeIndex pos j))+      in loop 0 (0 :: Int) (0 :: Int)+    ((a0, a1), (_, bits))+      | fst sixFit <= fst fourFit = (six, sixFit)+      | otherwise = (four, fourFit)+      where+        sixFit = assign six+        fourFit = assign four++-- | For each 8-bit value, the pair of 5 or 6-bit endpoints whose+-- intermediate colour decodes nearest to it: the first third point in+-- four-colour mode, the midpoint in three-colour mode.+four5, four6, three5, three6 :: VU.Vector (Int, Int)+four5 = singleColourTable 5 (\a b -> (2 * a + b) `quot` 3)+four6 = singleColourTable 6 (\a b -> (2 * a + b) `quot` 3)+three5 = singleColourTable 5 (\a b -> (a + b) `quot` 2)+three6 = singleColourTable 6 (\a b -> (a + b) `quot` 2)++singleColourTable :: Int -> (Int -> Int -> Int) -> VU.Vector (Int, Int)+singleColourTable bits mix = VU.generate 256 best+  where+    expand = if bits == 5 then expand5 else expand6+    values = [0 .. 2 ^ bits - 1]+    best v = snd $ minimum [ (abs (mix (expand a) (expand b) - v), (a, b)) | a <- values, b <- values ]

@@ -8,6 +8,9 @@     encodeBlp   , blpEncoder   , toBlpStruct+  , toBlp2Struct+  , encodeBlp2+  , blp2Encoder   , shrinkTo   , createMipMaps   , createMipMapsIndexed@@ -33,6 +36,8 @@  import Codec.Picture.Blp.Internal.Convert import Codec.Picture.Blp.Internal.Data+import Codec.Picture.Blp.Internal.Dxt (DxtFormat(..), encodeDxt)+import Codec.Picture.Blp.Types  -- | Serialise a BLP structure. The content type follows from 'blpExt'; at -- most 16 mip levels are written, and unused slots are zero.@@ -84,31 +89,109 @@ -- | Build the BLP structure for an image. The number of mip levels is clamped -- to between 1 and the image's full chain, at most 16. The image's size is -- not checked, and 'blpMaxSize' is applied by the caller (see 'shrinkTo').-toBlpStruct :: BlpEncodeOptions -> DynamicImage -> BlpStruct-toBlpStruct BlpEncodeOptions{..} img = BlpStruct {-    blpAlphaBits = if alpha then 8 else 0-  , blpWidth = fromIntegral width-  , blpHeight = fromIntegral height-  -- 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 blpFormat of-      BlpFormatJpeg quality -> toBlpJpg (fromIntegral quality) numLevels alpha rgba-      BlpFormatPaletted _ -> toBlpPaletted blpDither alpha numLevels (convertRGB8 img) rgba-  }+toBlpStruct :: BlpEncodeOptions -> DynamicImage -> Either BlpEncodeError BlpStruct+toBlpStruct BlpEncodeOptions{..} img = do+  ext <- case blpFormat of+    BlpFormatJpeg quality -> Right $ toBlpJpg (fromIntegral quality) numLevels alpha rgba+    BlpFormatPaletted _ -> Right $ toBlpPaletted blpDither alpha numLevels (convertRGB8 img) rgba+    other -> Left $ BlpUnsupportedFormat Blp1 other+  return 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 = ext+    }   where     -- JPEG keeps alpha only if some pixel is not fully opaque.     alpha = case blpFormat of       BlpFormatJpeg _ -> hasAlpha img && anyTransparent rgba       BlpFormatPaletted withAlpha -> withAlpha+      _ -> False     -- Only built when needed: paletted textures without alpha go from RGB.     rgba = convertRGBA8 img     width = dynamicMap imageWidth img     height = dynamicMap imageHeight img     numLevels = max 1 $ min (mipChainLength width height) blpMipLevels +-- | Build the BLP2 structure for an image, as 'toBlpStruct' does for BLP1.+-- The header values follow files from World of Warcraft: alpha depth 0 or+-- 1 for DXT1, 8 for DXT3, DXT5 and BGRA, 8 or 0 for a palette; alpha type+-- 0, 1 and 7 for the DXT formats and 8 otherwise.+toBlp2Struct :: BlpEncodeOptions -> DynamicImage -> Either BlpEncodeError Blp2Struct+toBlp2Struct BlpEncodeOptions{..} img = case blpFormat of+  BlpFormatPaletted withAlpha ->+    let (palette, mips) = quantiseLevels blpDither withAlpha numLevels (convertRGB8 img) rgba+    in Right $ struct (if withAlpha then 8 else 0) 8 (Blp2Paletted palette) mips+  BlpFormatDxt1 ->+    let punch = hasAlpha img && anyBelowHalf rgba+    in Right $ struct (if punch then 1 else 0) 0 (Blp2Dxt (Dxt1 punch)) (encodeDxt (Dxt1 punch) <$> levels)+  BlpFormatDxt3 -> Right $ struct 8 1 (Blp2Dxt Dxt3) (encodeDxt Dxt3 <$> levels)+  BlpFormatDxt5 -> Right $ struct 8 7 (Blp2Dxt Dxt5) (encodeDxt Dxt5 <$> levels)+  BlpFormatBgra -> Right $ struct 8 8 Blp2Bgra (bgraBytes <$> levels)+  other -> Left $ BlpUnsupportedFormat Blp2 other+  where+    rgba = convertRGBA8 img+    width = dynamicMap imageWidth img+    height = dynamicMap imageHeight img+    numLevels = max 1 $ min (mipChainLength width height) blpMipLevels+    levels = take numLevels (createMipMaps rgba)+    struct depth alphaType content mips = Blp2Struct {+        blp2AlphaDepth = depth+      , blp2AlphaType = alphaType+      , blp2HasMips = if numLevels > 1 then 1 else 0+      , blp2Width = fromIntegral width+      , blp2Height = fromIntegral height+      , blp2Content = content+      , blp2MipMaps = mips+      }++-- | Whether any pixel's alpha is below 128, so DXT1 needs 1-bit alpha.+anyBelowHalf :: Image PixelRGBA8 -> Bool+anyBelowHalf img = VS.any id $ VS.generate (imageWidth img * imageHeight img) (\i -> VS.unsafeIndex (imageData img) (4 * i + 3) < 128)++-- | Pixels as B, G, R and A.+bgraBytes :: Image PixelRGBA8 -> BS.ByteString+bgraBytes img = BS.pack . concat $ [[b, g, r, a] | PixelRGBA8 r g b a <- pixels]+  where pixels = [pixelAt img x y | y <- [0 .. imageHeight img - 1], x <- [0 .. imageWidth img - 1]]++-- | Serialise a BLP2 structure. At most 16 mip levels are written, unused+-- slots are zero, and the palette is zeros unless the content is paletted.+encodeBlp2 :: Blp2Struct -> ByteString+encodeBlp2 = runPut . blp2Encoder++-- | Raw encoder for BLP2.+blp2Encoder :: Blp2Struct -> Put+blp2Encoder Blp2Struct{..} = do+  putByteString "BLP2"+  putWord32le 1+  putWord8 $ case blp2Content of+    Blp2Paletted _ -> 1+    Blp2Dxt _ -> 2+    Blp2Bgra -> 3+  putWord8 blp2AlphaDepth+  putWord8 blp2AlphaType+  putWord8 blp2HasMips+  putWord32le blp2Width+  putWord32le blp2Height+  traverse_ putWord32le . slots $ take (length levels) (scanl (+) contentStart levelSizes)+  traverse_ putWord32le $ slots levelSizes+  traverse_ putRgba8 . V.take 256 $ palette <> V.replicate 256 (PixelRGBA8 0 0 0 0)+  traverse_ putByteString levels+  where+    contentStart = 148 + 4 * 256+    levels = take 16 blp2MipMaps+    levelSizes = BS.length <$> levels+    palette = case blp2Content of+      Blp2Paletted p -> p+      _ -> V.empty+    slots xs = take 16 $ (fromIntegral <$> xs) ++ repeat 0+    putRgba8 (PixelRGBA8 r g b a) = putWord8 r >> putWord8 g >> putWord8 b >> putWord8 a+ -- | Whether any pixel is less than fully opaque. anyTransparent :: Image PixelRGBA8 -> Bool anyTransparent img = go 3@@ -245,12 +328,17 @@ -- | 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 -> Bool -> Int -> Image PixelRGB8 -> Image PixelRGBA8 -> BlpExt-toBlpPaletted dither keepAlpha numLevels rgb rgba = BlpPaletted {-    blpPalette = convertPalette palette-  , blpPalettedMipMaps = if keepAlpha+toBlpPaletted dither keepAlpha numLevels rgb rgba =+  uncurry BlpPaletted (quantiseLevels dither keepAlpha numLevels rgb rgba)++-- | The palette and the raw mip levels of 'toBlpPaletted', shared with BLP2.+quantiseLevels :: Bool -> Bool -> Int -> Image PixelRGB8 -> Image PixelRGBA8 -> (V.Vector PixelRGBA8, [BS.ByteString])+quantiseLevels dither keepAlpha numLevels rgb rgba =+  ( convertPalette palette+  , if keepAlpha       then zipWith (<>) (convertIndexed <$> mipmaps) (convertIndexed <$> alphaMaps)       else convertIndexed <$> mipmaps-  }+  )   where     img'    :: Image Pixel8     palette :: Palette

@@ -11,7 +11,7 @@   , parseBlp2   , parseBlpFile   , readPalette-  , blpVersion+  , blp1Tag   , dword   , compressionParser   , maxSide@@ -32,6 +32,7 @@  import Codec.Picture.Blp.Internal.Data import Codec.Picture.Blp.Internal.Dxt (DxtFormat(..))+import Codec.Picture.Blp.Types (BlpDecodeError(..))  -- | Size of the fixed BLP1 header in bytes. headerSize :: Int@@ -45,33 +46,52 @@ -- -- Width and height must be between 1 and 'maxSide'. Mip levels are taken -- slot by slot, see 'mipLevels'.-parseBlp :: ByteString -> Either String BlpStruct+parseBlp :: ByteString -> Either BlpDecodeError 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-  fmap mkStruct $ case compression of-    BlpCompressionJPEG -> do-      jpegHeaderSize <- parseOnly (AT.take headerSize *> dword <?> "jpeg header size") input+  checkMagic "BLP1" input+  (mkStruct, content, width, height, slots) <- truncated $ parseOnly headerParser input+  checkSize width height+  let levelsFrom start = mipLevels (BS.length input) start (mipChainLength (fromIntegral width) (fromIntegral height)) slots+  fmap mkStruct $ case content of+    0 -> do+      jpegHeaderSize <- truncated $ parseOnly (AT.take headerSize *> dword) input       let headerEnd = headerSize + 4 + fromIntegral jpegHeaderSize       if headerEnd > BS.length input-        then Left "jpeg header: not enough input"+        then Left BlpTruncatedHeader         else Right BlpJpeg {             blpJpegHeader = slice input (headerSize + 4, fromIntegral jpegHeaderSize)           , blpJpegData = slice input <$> levelsFrom headerEnd           }-    _ -> do-      -- compressionParser gives JPEG or paletted only.+    1 -> do       let levels = levelsFrom headerSize       Right BlpPaletted {           blpPalette = readPalette input headerSize levels         , blpPalettedMipMaps = slice input <$> levels         }+    c -> Left . BlpUnsupported $ "BLP1 content type " ++ show c +-- | The file must start with the given magic. A non-empty file shorter than+-- that is cut short if it is the start of the magic.+checkMagic :: ByteString -> ByteString -> Either BlpDecodeError ()+checkMagic magic input+  | BS.take 4 input == magic = Right ()+  | not (BS.null input) && BS.length input < 4 && input `BS.isPrefixOf` magic = Left BlpTruncatedHeader+  | otherwise = Left BlpNotBlp++-- | Width and height must be between 1 and 'maxSide'.+checkSize :: Word32 -> Word32 -> Either BlpDecodeError ()+checkSize width height+  | w < 1 || h < 1 || w > maxSide || h > maxSide = Left $ BlpInvalidSize w h+  | otherwise = Right ()+  where+    w = fromIntegral width+    h = fromIntegral height++-- | Once the magic is checked, the header parsers fail only when the input+-- ends.+truncated :: Either String a -> Either BlpDecodeError a+truncated = either (const (Left BlpTruncatedHeader)) Right+ -- | The 256 entry palette that starts at the given offset. Some tools write -- only the palette entries they use, so the palette ends where mip 0 -- starts. Missing entries are padded with transparent black, so any index@@ -94,7 +114,7 @@  -- | Parse a BLP1 or BLP2 file, told apart by their magic. Anything that is -- not BLP2 is parsed, and rejected, as BLP1.-parseBlpFile :: ByteString -> Either String BlpFile+parseBlpFile :: ByteString -> Either BlpDecodeError BlpFile parseBlpFile input   | BS.take 4 input == "BLP2" = BlpFile2 <$> parseBlp2 input   | otherwise = BlpFile1 <$> parseBlp input@@ -111,29 +131,26 @@ -- levels are taken slot by slot, as in BLP1 (see 'mipLevels'). Levels may -- start right after the header: the palette that follows it is only read -- for paletted content, and cut short where mip 0 starts.-parseBlp2 :: ByteString -> Either String Blp2Struct+parseBlp2 :: ByteString -> Either BlpDecodeError Blp2Struct parseBlp2 input = do+  checkMagic "BLP2" input   (blpType, encoding, blp2AlphaDepth, blp2AlphaType, blp2HasMips, blp2Width, blp2Height, slots) <--    parseOnly blp2HeaderParser input-  let w = fromIntegral blp2Width-      h = fromIntegral blp2Height+    truncated $ parseOnly blp2HeaderParser input   case blpType of     1 -> Right ()-    0 -> Left "BLP2 files with JPEG content are not supported"-    t -> Left $ "Unknown BLP2 type " ++ show t-  if w < 1 || h < 1 || w > maxSide || h > maxSide-    then Left $ "Invalid image size " ++ show blp2Width ++ "x" ++ show blp2Height-    else Right ()-  let levels = mipLevels (BS.length input) blp2HeaderSize (mipChainLength w h) slots+    0 -> Left $ BlpUnsupported "BLP2 with JPEG content (type 0)"+    t -> Left . BlpUnsupported $ "BLP2 type " ++ show t+  checkSize blp2Width blp2Height+  let levels = mipLevels (BS.length input) blp2HeaderSize (mipChainLength (fromIntegral blp2Width) (fromIntegral blp2Height)) slots   blp2Content <- case encoding of     1 -> Right . Blp2Paletted $ readPalette input blp2HeaderSize levels     2 -> case blp2AlphaType of       0 -> Right . Blp2Dxt $ Dxt1 (blp2AlphaDepth /= 0)       1 -> Right $ Blp2Dxt Dxt3       7 -> Right $ Blp2Dxt Dxt5-      t -> Left $ "Unknown BLP2 DXT format (alpha type " ++ show t ++ ")"+      t -> Left . BlpUnsupported $ "BLP2 DXT alpha type " ++ show t     3 -> Right Blp2Bgra-    e -> Left $ "Unknown BLP2 encoding " ++ show e+    e -> Left . BlpUnsupported $ "BLP2 encoding " ++ show e   return Blp2Struct { blp2MipMaps = slice input <$> levels, .. }  -- | The BLP2 header: type, encoding, alpha depth, alpha type, has mips,@@ -154,10 +171,10 @@  -- | 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 :: Parser (BlpExt -> BlpStruct, Word32, Word32, Word32, [(Word32, Word32)]) headerParser = do-  _ <- blpVersion-  compression <- compressionParser+  _ <- blp1Tag+  content <- dword <?> "content"   blpAlphaBits <- dword <?> "alpha bits"   blpWidth <- dword <?> "width"   blpHeight <- dword <?> "height"@@ -166,11 +183,11 @@   offsets <- count 16 dword <?> "mipmaps offsets"   sizes <- count 16 dword <?> "mipmaps sizes"   let mkStruct blpExt = BlpStruct {..}-  return (mkStruct, compression, blpWidth, blpHeight, offsets `zip` sizes)+  return (mkStruct, content, blpWidth, blpHeight, offsets `zip` sizes)  -- | The @BLP1@ magic. BLP0 and BLP2 files fail here.-blpVersion :: Parser ByteString-blpVersion = string "BLP1" <?> "BLP1 version tag"+blp1Tag :: Parser ByteString+blp1Tag = string "BLP1" <?> "BLP1 version tag"  -- | A little-endian 32-bit word. dword :: Parser Word32

@@ -6,6 +6,8 @@ module Codec.Picture.Blp.Types(     BlpDecodeOptions(..)   , defaultBlpDecodeOptions+  , BlpDecodeError(..)+  , displayBlpDecodeError   , BlpInfo(..)   , BlpVersion(..)   , BlpCompression(..)@@ -15,6 +17,8 @@   , BlpEncodeError(..)   ) where +import Control.DeepSeq (NFData)+import Control.Exception (Exception(..)) import GHC.Generics  -- | Options for decoding.@@ -29,6 +33,46 @@ defaultBlpDecodeOptions :: BlpDecodeOptions defaultBlpDecodeOptions = BlpDecodeOptions { blpMaxPixels = 8192 * 8192 } +-- | Why a BLP file cannot be decoded. 'displayBlpDecodeError' gives a+-- readable message.+data BlpDecodeError =+    -- | The file starts with neither @BLP1@ nor @BLP2@. BLP0 files are among+    -- these.+    BlpNotBlp+    -- | The file ends inside its header.+  | BlpTruncatedHeader+    -- | The header asks for something this library does not read, such as+    -- an unknown content type or BLP2 with JPEG content. The text says what.+  | BlpUnsupported String+    -- | Width or height outside 1 to 65535.+  | BlpInvalidSize !Int !Int+    -- | Width and height whose product is above 'blpMaxPixels', the limit+    -- given last.+  | BlpTooLarge !Int !Int !Int+    -- | No mipmap slot points at usable data.+  | BlpNoImageData+    -- | The full size image cannot be decoded: its data is too short, its+    -- JPEG stream is broken, and so on. The text says what. Damaged+    -- mipmaps after the first are not errors; the list of levels stops+    -- before them.+  | BlpCorruptImage String+  deriving (Eq, Show, Generic)++instance Exception BlpDecodeError where+  displayException = displayBlpDecodeError++-- | A message for an error, in plain words.+displayBlpDecodeError :: BlpDecodeError -> String+displayBlpDecodeError e = case e of+  BlpNotBlp -> "Not a BLP file: it starts with neither BLP1 nor BLP2"+  BlpTruncatedHeader -> "The file ends inside its header"+  BlpUnsupported what -> "Unsupported BLP file: " ++ what+  BlpInvalidSize w h -> "Invalid image size " ++ show w ++ "x" ++ show h+  BlpTooLarge w h limit -> "Image size " ++ show w ++ "x" ++ show h+    ++ " is above the limit of " ++ show limit ++ " pixels"+  BlpNoImageData -> "The file has no image data"+  BlpCorruptImage what -> "The full size image is damaged: " ++ what+ -- | What a BLP file holds, read from its header without decoding any pixels. data BlpInfo = BlpInfo {     blpInfoVersion :: !BlpVersion -- ^ BLP1 or BLP2@@ -37,7 +81,7 @@   , blpInfoHeight :: !Int -- ^ Height of the full size image   , blpInfoAlphaBits :: !Int -- ^ The alpha depth header field (@alphaBits@ in BLP1, @alphaDepth@ in BLP2), as stored   , blpInfoMipLevels :: !Int -- ^ Mip levels with usable slots, the full size image included-  } deriving (Eq, Show)+  } deriving (Eq, Show, Generic)  -- | Version of a BLP file: BLP1 is used by Warcraft III, BLP2 by World of -- Warcraft.@@ -54,7 +98,8 @@   | BlpCompressionBgra -- ^ 32-bit BGRA pixels (BLP2 only)   deriving (Eq, Ord, Enum, Bounded, Show, Generic) --- | How to encode a texture.+-- | How to encode a texture. JPEG is BLP1 only; DXT and BGRA are BLP2 only;+-- a palette works in both, see 'blpVersion'. data BlpFormat =     -- | JPEG with the given quality, from 1 to 100. The texture gets alpha     -- when the image has an alpha channel.@@ -62,7 +107,17 @@     -- | 256 colour palette, with 8-bit alpha or without alpha. Colours are     -- quantised with dithering.   | BlpFormatPaletted !Bool-  deriving (Eq, Show)+    -- | DXT1 blocks, 4 bits per pixel. The texture gets 1-bit alpha when+    -- some pixel's alpha is below 128; those pixels become transparent.+  | BlpFormatDxt1+    -- | DXT3 blocks: DXT1 colour plus 4-bit alpha per pixel.+  | BlpFormatDxt3+    -- | DXT5 blocks: DXT1 colour plus interpolated 8-bit alpha, smoother+    -- than DXT3 for gradual alpha.+  | BlpFormatDxt5+    -- | Uncompressed 32-bit pixels, lossless and 4 bytes per pixel.+  | BlpFormatBgra+  deriving (Eq, Show, Generic)  -- | Options for encoding a texture. data BlpEncodeOptions = BlpEncodeOptions {@@ -78,16 +133,20 @@   -- | Shrink the image, halving both sides, until the larger side is at most   -- this many pixels. Warcraft III shows mip levels up to 512 pixels only. , blpMaxSize :: !(Maybe Int)+  -- | File version to write: 'Blp1' for Warcraft III, 'Blp2' for World of+  -- Warcraft. The format must exist in that version, see 'BlpFormat'.+, blpVersion :: !BlpVersion } deriving (Eq, Show) --- | JPEG at quality 90 with the full mip chain, dithered palettes, and no--- size limit.+-- | BLP1, JPEG at quality 90 with the full mip chain, dithered palettes, and+-- no size limit. defaultBlpEncodeOptions :: BlpEncodeOptions defaultBlpEncodeOptions = BlpEncodeOptions {     blpFormat = BlpFormatJpeg 90   , blpMipLevels = 16   , blpDither = True   , blpMaxSize = Nothing+  , blpVersion = Blp1   }  -- | Why an image cannot be encoded.@@ -97,4 +156,14 @@   | BlpInvalidJpegQuality !Int -- ^ JPEG quality outside 1 to 100.   | BlpFileTooLarge -- ^ The file would exceed 4 GiB, the most its offsets can address.   | BlpInvalidMaxSize !Int -- ^ A 'blpMaxSize' below 1.-  deriving (Eq, Show)+  | BlpUnsupportedFormat !BlpVersion !BlpFormat -- ^ The format does not exist in this version, such as JPEG in BLP2.+  deriving (Eq, Show, Generic)++instance Exception BlpEncodeError++instance NFData BlpDecodeError+instance NFData BlpEncodeError+instance NFData BlpInfo+instance NFData BlpVersion+instance NFData BlpCompression+instance NFData BlpFormat

@@ -1,16 +1,21 @@ -- | BLP2 files, built byte by byte: every content type, alpha depths, and -- damaged or unsupported files.-module Blp2(blp2Tests, blp2Seeds) where+module Blp2(blp2Tests, blp2EncodeTests, blp2Seeds) where  import Codec.Picture import Codec.Picture.Blp+import Codec.Picture.Blp.Internal.Data (Blp2Content(..), Blp2Struct(..))+import Codec.Picture.Blp.Internal.Encoder (createMipMaps, encodeBlp2, toBlp2Struct)+import Codec.Picture.Blp.Internal.Parser (parseBlp2)+import Control.Monad (forM_) import Data.ByteString (ByteString)-import Data.List (isInfixOf) import Data.Word import Test.Tasty import Test.Tasty.HUnit  import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BSL+import qualified Data.Vector as V  import Fixture @@ -61,19 +66,19 @@   , testCase "a damaged mipmap ends the list, a damaged level 0 fails the file" $ do       levels <- decoded $ blp2 dxt1Header blankPalette [dxt1Mip0, BS.take 4 (colourBlock 0xFFFF 0 []), dxt1Block 0x07E0, dxt1Block 0x001F]       map size levels @?= [(8, 8)]-      assertLeft "Mipmap 0" . decodeBlp $ blp2 dxt1Header blankPalette [BS.take 31 dxt1Mip0]-      assertLeft "BGRA" . decodeBlp $ blp2 defHeader2 { h2Encoding = 3, h2Width = 2, h2Height = 1 } blankPalette [BS.pack [1 .. 7]]+      assertCorrupt "DXT data" . decodeBlp $ blp2 dxt1Header blankPalette [BS.take 31 dxt1Mip0]+      assertCorrupt "BGRA" . decodeBlp $ blp2 defHeader2 { h2Encoding = 3, h2Width = 2, h2Height = 1 } blankPalette [BS.pack [1 .. 7]]   , testCase "unsupported and malformed headers are errors" $ do-      assertLeft "JPEG" . decodeBlp $ setDword 4 0 dxt1File-      assertLeft "type" . decodeBlp $ setDword 4 5 dxt1File-      assertLeft "encoding" . decodeBlp $ setByte 8 4 dxt1File-      assertLeft "alpha type" . decodeBlp $ setByte 10 3 dxt1File-      assertLeft "Invalid image size" . decodeBlp $ setDword 12 0 dxt1File-      assertLeft "No mipmap data" . decodeBlp $ blp2 dxt1Header blankPalette []-      assertLeft "not enough input" . decodeBlp $ BS.take 100 dxt1File-      assertLeft "JPEG" . blpInfo $ setDword 4 0 dxt1File+      assertError (BlpUnsupported "BLP2 with JPEG content (type 0)") . decodeBlp $ setDword 4 0 dxt1File+      assertError (BlpUnsupported "BLP2 type 5") . decodeBlp $ setDword 4 5 dxt1File+      assertError (BlpUnsupported "BLP2 encoding 4") . decodeBlp $ setByte 8 4 dxt1File+      assertError (BlpUnsupported "BLP2 DXT alpha type 3") . decodeBlp $ setByte 10 3 dxt1File+      assertError (BlpInvalidSize 0 8) . decodeBlp $ setDword 12 0 dxt1File+      assertError BlpNoImageData . decodeBlp $ blp2 dxt1Header blankPalette []+      assertError BlpTruncatedHeader . decodeBlp $ BS.take 100 dxt1File+      assertError (BlpUnsupported "BLP2 with JPEG content (type 0)") . blpInfo $ setDword 4 0 dxt1File   , testCase "the size limit applies to BLP2" $-      assertLeft "limit" $ decodeBlpWith (BlpDecodeOptions 63) dxt1File+      assertError (BlpTooLarge 8 8 63) $ decodeBlpWith (BlpDecodeOptions 63) dxt1File   ]  -- | Valid BLP2 files of every content type, for the fuzz properties.@@ -82,16 +87,12 @@  decoded :: ByteString -> IO [Image PixelRGBA8] decoded file = case decodeBlpMipmaps file of-  Left e -> assertFailure e-  Right levels -> return (map convertRGBA8 levels)+  Left e -> assertFailure (show e)+  Right levels -> return levels  size :: Image a -> (Int, Int) size img = (imageWidth img, imageHeight img) -assertLeft :: String -> Either String a -> Assertion-assertLeft needle r = case r of-  Left e -> assertBool ("error " ++ show e ++ " should mention " ++ show needle) (needle `isInfixOf` e)-  Right _ -> assertFailure "expected a decoding error"  setByte :: Int -> Word8 -> ByteString -> ByteString setByte o v bs = BS.take o bs <> BS.singleton v <> BS.drop (o + 1) bs@@ -145,3 +146,69 @@ level0 :: [Image PixelRGBA8] -> Image PixelRGBA8 level0 (l : _) = l level0 [] = error "no levels decoded"++blp2EncodeTests :: TestTree+blp2EncodeTests = testGroup "blp2 encoding"+  [ testCase "every format writes a BLP2 that blpInfo reads back" $+      forM_ [ (BlpFormatPaletted True, BlpCompressionUncompressed, 8)+            , (BlpFormatPaletted False, BlpCompressionUncompressed, 0)+            , (BlpFormatDxt1, BlpCompressionDxt1, 1)+            , (BlpFormatDxt3, BlpCompressionDxt3, 8)+            , (BlpFormatDxt5, BlpCompressionDxt5, 8)+            , (BlpFormatBgra, BlpCompressionBgra, 8) ] $ \(fmt, compression, depth) ->+        fmap blpInfo (encode2 fmt sprite) @?= Right (Right (BlpInfo Blp2 compression 16 8 depth 5))+  , testCase "header bytes follow World of Warcraft files" $+      forM_ [ (BlpFormatPaletted True, 1, 8), (BlpFormatDxt1, 2, 0), (BlpFormatDxt3, 2, 1)+            , (BlpFormatDxt5, 2, 7), (BlpFormatBgra, 3, 8) ] $ \(fmt, encoding, alphaType) -> do+        Right file <- return (encode2 fmt sprite)+        (BS.index file 8, BS.index file 10, BS.index file 11) @?= (encoding, alphaType, 1)+  , testCase "a single level says it has no mipmaps" $ do+      Right file <- return (encodeBlpWithStrict defaultBlpEncodeOptions { blpVersion = Blp2, blpFormat = BlpFormatDxt5, blpMipLevels = 1 } sprite)+      BS.index file 11 @?= 0+  , testCase "BGRA is lossless at every level" $ do+      Right file <- return (encode2 BlpFormatBgra sprite)+      levels <- decoded file+      map imageData levels @?= map imageData (take 5 (createMipMaps (convertRGBA8 sprite)))+  , testCase "DXT1 has 1-bit alpha only when some alpha is below 128" $ do+      let opaque = ImageRGBA8 $ generateImage (\x y -> PixelRGBA8 (fromIntegral x) (fromIntegral y) 0 200) 8 8+      fmap (fmap blpInfoAlphaBits . blpInfo) (encode2 BlpFormatDxt1 opaque) @?= Right (Right 0)+      Right file <- return (encode2 BlpFormatDxt1 sprite)+      level <- level0 <$> decoded file+      [a | PixelRGBA8 _ _ _ a <- [pixelAt level 0 0, pixelAt level 8 4]] @?= [0, 255]+  , testCase "formats a version does not have are errors" $ do+      encodeBlpWith defaultBlpEncodeOptions { blpVersion = Blp2 } sprite+        `errorIs` BlpUnsupportedFormat Blp2 (BlpFormatJpeg 90)+      encodeBlpWith defaultBlpEncodeOptions { blpFormat = BlpFormatDxt5 } sprite+        `errorIs` BlpUnsupportedFormat Blp1 BlpFormatDxt5+  , testCase "the size limit and blpMaxSize apply to BLP2" $ do+      Right file <- return (encodeBlpWithStrict defaultBlpEncodeOptions { blpVersion = Blp2, blpFormat = BlpFormatDxt1, blpMaxSize = Just 4 } sprite)+      fmap (\i -> (blpInfoWidth i, blpInfoHeight i)) (blpInfo file) @?= Right (4, 2)+      let wide = ImageRGBA8 $ generateImage (\_ _ -> PixelRGBA8 0 0 0 255) 65536 1+      encodeBlpWith defaultBlpEncodeOptions { blpVersion = Blp2, blpFormat = BlpFormatBgra } wide+        `errorIs` BlpImageTooLarge 65536 1+  , testCase "parsing a written BLP2 gives back its structure" $+      forM_ [BlpFormatPaletted True, BlpFormatDxt1, BlpFormatDxt5, BlpFormatBgra] $ \fmt -> do+        Right struct <- return (toBlp2Struct defaultBlpEncodeOptions { blpVersion = Blp2, blpFormat = fmt } sprite)+        Right parsed <- return (parseBlp2 (BSL.toStrict (encodeBlp2 struct)))+        -- The quantiser may give fewer than 256 entries; the file pads them.+        let content s = case blp2Content s of+              Blp2Paletted p -> show (V.take 256 (p <> V.replicate 256 (PixelRGBA8 0 0 0 0)))+              c -> show c+            summary s = (blp2AlphaDepth s, blp2AlphaType s, blp2HasMips s, blp2Width s, blp2Height s, blp2MipMaps s, content s)+        summary parsed @?= summary struct+  ]++-- | 16x8 with a transparent left half and a gradient on the right.+sprite :: DynamicImage+sprite = ImageRGBA8 $ generateImage (\x y -> PixelRGBA8 (fromIntegral (x * 16)) (fromIntegral (y * 32)) 90 (if x < 8 then 0 else 255)) 16 8++encode2 :: BlpFormat -> DynamicImage -> Either BlpEncodeError ByteString+encode2 fmt = encodeBlpWithStrict defaultBlpEncodeOptions { blpVersion = Blp2, blpFormat = fmt }++encodeBlpWithStrict :: BlpEncodeOptions -> DynamicImage -> Either BlpEncodeError ByteString+encodeBlpWithStrict opts = fmap BSL.toStrict . encodeBlpWith opts++errorIs :: Either BlpEncodeError a -> BlpEncodeError -> Assertion+errorIs r expected = case r of+  Left e -> e @?= expected+  Right _ -> assertFailure $ "expected " ++ show expected

@@ -1,31 +0,0 @@-{-# 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 defaultBlpEncodeOptions { blpFormat = f, blpMipLevels = n } img-      encodeBlpJpeg 90 3 img @?= with (BlpFormatJpeg 90) 3-      encodeBlpUncompressedWithAlpha 3 img @?= with (BlpFormatPaletted True) 3-      encodeBlpUncompressedWithoutAlpha 3 img @?= with (BlpFormatPaletted False) 3-  , 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

@@ -8,6 +8,7 @@ import Fixture (colourBlock, dxt3Alpha, dxt5Alpha) import Data.ByteString (ByteString) import Data.Either (isLeft)+import Control.Monad (forM_) import Data.Word import Test.QuickCheck import Test.Tasty@@ -62,6 +63,7 @@       fmap imageData (decodeDxt (Dxt1 False) 4 4 (block <> BS.replicate 9 0xAB))         @?= fmap imageData (decodeDxt (Dxt1 False) 4 4 block)   , testProperty "matches a direct transcription of the format" matchesReference+  , encoderTests   ]  rgba :: Word8 -> Word8 -> Word8 -> Word8 -> PixelRGBA8@@ -140,3 +142,118 @@         table           | a0 > a1 = [a0, a1] ++ [((7 - j) * a0 + j * a1) `div` 7 | j <- [1 .. 6]]           | otherwise = [a0, a1] ++ [((5 - j) * a0 + j * a1) `div` 5 | j <- [1 .. 4]] ++ [0, 255]++encoderTests :: TestTree+encoderTests = testGroup "encoding"+  [ testCase "output is whole blocks and decodes to the same size" $+      forM_ [Dxt1 False, Dxt1 True, Dxt3, Dxt5] $ \fmt -> do+        let img = generateImage (\x y -> PixelRGBA8 (fromIntegral $ x * 40) (fromIntegral $ y * 70) 99 200) 5 3+            bytes = encodeDxt fmt img+        BS.length bytes @?= dxtLevelBytes fmt 5 3+        fmap (\d -> (imageWidth d, imageHeight d)) (decodeDxt fmt 5 3 bytes) @?= Right (5, 3)+  , testProperty "blocks of at most two RGB565 colours round-trip exactly" twoColours+  , testProperty "a block of one colour is within 1 per channel" oneColour+  , testProperty "DXT1 with alpha: below 128 is transparent, the rest opaque" dxt1Alpha+  , testProperty "DXT3 alpha is the nearest multiple of 17" dxt3Rounding+  , testProperty "DXT5 alpha with two values per block is exact" dxt5TwoAlphas+  , testCase "DXT5 uses the mode with 0 and 255 when it fits better" $ do+      let img = generateImage (\x y -> PixelRGBA8 9 9 9 ([0, 100, 110, 255] !! ((x + y) `mod` 4))) 4 4+          alpha (PixelRGBA8 _ _ _ a) = a+      map alpha (pixels (roundTrip Dxt5 img)) @?= map alpha (pixels img)+  , testCase "two colours whose difference is orthogonal to grey round-trip" $ do+      -- (16, -16, 0) is orthogonal to (1, 1, 1); a principal axis search+      -- started from (1, 1, 1) collapsed here to the mean colour.+      let img = generateImage (\x y -> if even (x + y) then PixelRGBA8 239 239 41 255 else PixelRGBA8 255 223 41 255) 4 4+      pixels (roundTrip (Dxt1 False) img) @?= pixels img+  , testCase "endpoints are refined by least squares" $ do+      -- One black, fourteen mid-grey and one white pixel: the range fit puts+      -- the endpoints at black and white, which no index decodes near the+      -- grey. The squared error was 12802 when this was written; without+      -- refinement it is 19851.+      let grey i = case i of { 0 -> 0; 15 -> 255; _ -> 128 } :: Word8+          img = generateImage (\x y -> let v = grey (4 * y + x) in PixelRGBA8 v v v 255) 4 4+          chans (PixelRGBA8 r g b _) = map fromIntegral [r, g, b] :: [Int]+          err = sum [(a - b) ^ (2 :: Int) | (p, q) <- zip (pixels img) (pixels (roundTrip (Dxt1 False) img)), (a, b) <- zip (chans p) (chans q)]+      assertBool ("squared error " ++ show err) (err < 15000)+  , testCase "a smooth gradient keeps its quality" $ do+      -- 44.0 dB (DXT1) and 45.3 dB (DXT5, with alpha) when this was written.+      let img = generateImage (\x y -> PixelRGBA8 (fromIntegral x) (fromIntegral (y * 2)) (fromIntegral (x + y)) (fromIntegral (255 - y))) 256 128+          quality fmt alpha = psnr alpha img (roundTrip fmt img)+      assertBool "DXT1" (quality (Dxt1 False) False > 42)+      assertBool "DXT5" (quality Dxt5 True > 42)+  ]++roundTrip :: DxtFormat -> Image PixelRGBA8 -> Image PixelRGBA8+roundTrip fmt img = either error id $ decodeDxt fmt (imageWidth img) (imageHeight img) (encodeDxt fmt img)++pixels :: Image PixelRGBA8 -> [PixelRGBA8]+pixels img = [pixelAt img x y | y <- [0 .. imageHeight img - 1], x <- [0 .. imageWidth img - 1]]++psnr :: Bool -> Image PixelRGBA8 -> Image PixelRGBA8 -> Double+psnr alpha a b = 10 * logBase 10 (255 * 255 / (fromIntegral (sum errs) / fromIntegral (length errs)))+  where+    chans (PixelRGBA8 r g bl al) = map fromIntegral ([r, g, bl] ++ [al | alpha]) :: [Int]+    errs = [(x - y) ^ (2 :: Int) | (p, q) <- zip (pixels a) (pixels b), (x, y) <- zip (chans p) (chans q)]++-- | A random image of w x h, each pixel from the given generator.+blocky :: Int -> Int -> (Int -> Int -> Gen PixelRGBA8) -> Gen (Image PixelRGBA8)+blocky w h pixelFor = do+  rows <- sequence [sequence [pixelFor x y | x <- [0 .. w - 1]] | y <- [0 .. h - 1]]+  return $ generateImage (\x y -> rows !! y !! x) w h+++-- | One random value per 4x4 block of a w x h image, looked up by pixel.+perBlock :: Int -> Int -> Gen a -> Gen (Int -> Int -> a)+perBlock w h gen = do+  let across = (w + 3) `div` 4+  values <- vectorOf (across * ((h + 3) `div` 4)) gen+  return $ \x y -> values !! ((y `div` 4) * across + x `div` 4)+-- | A colour whose RGB565 form expands back to itself.+exact565 :: Gen (Word8, Word8, Word8)+exact565 = do+  r <- choose (0, 31 :: Int)+  g <- choose (0, 63 :: Int)+  b <- choose (0, 31 :: Int)+  let e5 v = fromIntegral (v * 8 + v `div` 4)+      e6 v = fromIntegral (v * 4 + v `div` 16)+  return (e5 r, e6 g, e5 b)++sizes :: Gen (Int, Int)+sizes = (,) <$> choose (1, 13) <*> choose (1, 13)++twoColours :: Property+twoColours = forAll sizes $ \(w, h) -> forAll (elements [Dxt1 False, Dxt3, Dxt5]) $ \fmt -> do+  pairOf <- perBlock w h ((,) <$> exact565 <*> exact565)+  img <- blocky w h $ \x y -> do+    let (c1, c2) = pairOf x y+    (r, g, b) <- elements [c1, c2]+    return (PixelRGBA8 r g b 255)+  let rgb (PixelRGBA8 r g b _) = (r, g, b)+  return $ map rgb (pixels (roundTrip fmt img)) === map rgb (pixels img)++oneColour :: Property+oneColour = forAll (elements [Dxt1 False, Dxt1 True, Dxt3, Dxt5]) $ \fmt ->+  forAll ((,,) <$> arbitrary <*> arbitrary <*> arbitrary) $ \(r, g, b) ->+    let img = generateImage (\_ _ -> PixelRGBA8 r g b 255) 4 4+        close a a' = abs (fromIntegral a - fromIntegral a' :: Int) <= 1+    in conjoin [ counterexample (show p) (close r r' && close g g' && close b b')+               | p@(PixelRGBA8 r' g' b' _) <- pixels (roundTrip fmt img) ]++dxt1Alpha :: Property+dxt1Alpha = forAll sizes $ \(w, h) -> do+  img <- blocky w h $ \_ _ -> PixelRGBA8 <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary+  let alpha (PixelRGBA8 _ _ _ a) = a+  return $ map alpha (pixels (roundTrip (Dxt1 True) img)) === [if alpha p < 128 then 0 else 255 | p <- pixels img]++dxt3Rounding :: Property+dxt3Rounding = forAll sizes $ \(w, h) -> do+  img <- blocky w h $ \_ _ -> PixelRGBA8 0 0 0 <$> arbitrary+  let alpha (PixelRGBA8 _ _ _ a) = fromIntegral a :: Int+  return $ map alpha (pixels (roundTrip Dxt3 img)) === [17 * ((alpha p + 8) `div` 17) | p <- pixels img]++dxt5TwoAlphas :: Property+dxt5TwoAlphas = forAll sizes $ \(w, h) -> do+  pairOf <- perBlock w h ((,) <$> arbitrary <*> arbitrary)+  img <- blocky w h $ \x y -> PixelRGBA8 9 9 9 <$> (let (a1, a2) = pairOf x y in elements [a1, a2])+  let alpha (PixelRGBA8 _ _ _ a) = a+  return $ map alpha (pixels (roundTrip Dxt5 img)) === map alpha (pixels img)

@@ -24,9 +24,14 @@   , colourBlock   , dxt3Alpha   , dxt5Alpha+  , assertError+  , assertCorrupt   ) where +import Codec.Picture.Blp (BlpDecodeError(..)) import Data.Bits+import Data.List (isInfixOf)+import Test.Tasty.HUnit import Data.ByteString (ByteString) import Data.Word @@ -172,3 +177,17 @@  le :: Integral a => Int -> a -> [Word8] le n v = [fromIntegral (toInteger v `shiftR` (8 * k)) | k <- [0 .. n - 1]]++-- | Decoding must fail with exactly this error.+assertError :: BlpDecodeError -> Either BlpDecodeError a -> Assertion+assertError expected r = case r of+  Left e -> e @?= expected+  Right _ -> assertFailure $ "expected " ++ show expected++-- | Decoding must fail with 'BlpCorruptImage' whose text mentions the needle.+assertCorrupt :: String -> Either BlpDecodeError a -> Assertion+assertCorrupt needle r = case r of+  Left (BlpCorruptImage what) ->+    assertBool (show what ++ " should mention " ++ show needle) (needle `isInfixOf` what)+  Left e -> assertFailure $ "expected BlpCorruptImage, got " ++ show e+  Right _ -> assertFailure "expected BlpCorruptImage"

@@ -4,10 +4,9 @@ import Codec.Picture.Blp import Codec.Picture.Blp.Internal.Encoder (createMipMaps) import Codec.Picture.Types (convertImage)-import Control.Exception (bracket_, try)+import Control.Exception (bracket_, displayException, throwIO, try) import Control.Monad (forM_) import Data.ByteString (ByteString)-import Data.List (isInfixOf) import Data.Word import System.Directory (getTemporaryDirectory, removeFile) import System.FilePath ((</>))@@ -18,7 +17,6 @@ import qualified Data.ByteString.Lazy as BSL  import Blp2-import Deprecated import Dxt import Properties import Fixture@@ -29,12 +27,13 @@   , malformedTests   , jpegTests   , limitTests+  , errorTests   , qualityTests   , encoderTests   , fileTests-  , deprecatedTests   , dxtTests   , blp2Tests+  , blp2EncodeTests   , propertyTests   ] @@ -66,10 +65,10 @@ pixelsOf img = [pixelAt img x y | y <- [0 .. imageHeight img - 1], x <- [0 .. imageWidth img - 1]]  decodeRGBA :: ByteString -> IO (Image PixelRGBA8)-decodeRGBA bs = either (assertFailure . ("decodeBlp: " ++)) (return . convertRGBA8) $ decodeBlp bs+decodeRGBA bs = either (assertFailure . ("decodeBlp: " ++) . show) return $ decodeBlp bs  decodeLevels :: ByteString -> IO [Image PixelRGBA8]-decodeLevels bs = either (assertFailure . ("decodeBlpMipmaps: " ++)) (return . map convertRGBA8) $ decodeBlpMipmaps bs+decodeLevels bs = either (assertFailure . ("decodeBlpMipmaps: " ++) . show) return $ decodeBlpMipmaps bs  assertPixels :: (Word8 -> PixelRGBA8) -> ByteString -> Assertion assertPixels expected bs = do@@ -77,11 +76,6 @@   (imageWidth img, imageHeight img) @?= (4, 4)   pixelsOf img @?= map expected [0 .. 15] -assertLeft :: String -> Either String a -> Assertion-assertLeft needle r = case r of-  Left e -> assertBool ("error " ++ show e ++ " should mention " ++ show needle) (needle `isInfixOf` e)-  Right _ -> assertFailure "expected a decoding error"- uncompressedTests :: TestTree uncompressedTests = testGroup "uncompressed"   [ testCase "with alpha, picture type 4" $ assertPixels withAlphaPixel (withAlphaFile 4)@@ -147,37 +141,37 @@       levels <- decodeLevels bs       sizes levels @?= [(4, 4)]   , testCase "mip 0 shorter than the image is an error, not an exception (#13)" $-      assertLeft "too short" . decodeBlp $ uncompressed defHeader { hAlphaBits = 0, hExtra = 5 } (palette 256) [BS.take 8 indices]+      assertCorrupt "too short" . decodeBlp $ uncompressed defHeader { hAlphaBits = 0, hExtra = 5 } (palette 256) [BS.take 8 indices]   ]  malformedTests :: TestTree malformedTests = testGroup "malformed input"   [ testCase "wrong version tag" $-      assertLeft "BLP1" . decodeBlp $ "BLP0" <> BS.drop 4 (withAlphaFile 4)+      assertError BlpNotBlp . decodeBlp $ "BLP0" <> BS.drop 4 (withAlphaFile 4)   , testCase "unknown compression" $-      assertLeft "compression" . decodeBlp $ uncompressed defHeader { hCompression = 7 } (palette 256) [indices]+      assertError (BlpUnsupported "BLP1 content type 7") . decodeBlp $ uncompressed defHeader { hCompression = 7 } (palette 256) [indices]   , testCase "truncated header" $-      assertLeft "" . decodeBlp $ BS.take 100 (withAlphaFile 4)+      assertError BlpTruncatedHeader . decodeBlp $ BS.take 100 (withAlphaFile 4)   , testCase "empty input" $-      assertLeft "" $ decodeBlp BS.empty+      assertError BlpNotBlp $ decodeBlp BS.empty   , testCase "file cut inside the header names the field" $-      assertLeft "mipmaps sizes" . decodeBlp $ BS.take 100 (withAlphaFile 4)+      assertError BlpTruncatedHeader . decodeBlp $ BS.take 100 (withAlphaFile 4)   , testCase "JPEG header longer than the file" $-      assertLeft "jpeg header" . decodeBlp $ setDword headerSize 100000 jpegFile+      assertError BlpTruncatedHeader . decodeBlp $ setDword headerSize 100000 jpegFile   , testCase "width or height outside 1..65535 is an error" $ do       let sized w h = uncompressed defHeader { hAlphaBits = 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+      assertError (BlpInvalidSize 0xFFFFFFFF 0xFFFFFFFF) . decodeBlp $ sized 0xFFFFFFFF 0xFFFFFFFF+      assertError (BlpInvalidSize 0 4) . decodeBlp $ sized 0 4+      assertError (BlpInvalidSize 4 65536) . 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)+      assertError BlpNoImageData . decodeBlp $ blpFile defHeader [] (paletteBytes $ palette 256)   , testCase "JPEG file without mipmaps" $-      assertLeft "No JPEG mipmap data" . decodeBlp $ blpFile defHeader { hCompression = 0 } [] "\0\0\0\0"+      assertError BlpNoImageData . decodeBlp $ blpFile defHeader { hCompression = 0 } [] "\0\0\0\0"   ]  -- | 16x16 texture with colour and alpha gradients, enough for three mip levels.@@ -210,6 +204,12 @@       img <- decodeRGBA . BSL.toStrict $ enc (BlpFormatJpeg 100) 1 (ImageRGBA8 opaqueGradient)       let d = maxDiff opaqueGradient img       assertBool ("max channel difference " ++ show d) (d <= 8)+  , testCase "a JPEG level without a frame header is an error" $ do+      -- Turn the shared header's SOF0 segment into an APP1 segment of the+      -- same length, so the stream reaches the scan without a frame size.+      let (before, sof) = BS.breakSubstring (BS.pack [0xFF, 0xC0]) jpegFile+      assertBool "the encoder writes SOF0" (not (BS.null sof))+      assertCorrupt "no frame header" . decodeBlp $ before <> BS.pack [0xFF, 0xE1] <> BS.drop 2 sof   , testCase "all three mip levels decode" $ do       levels <- decodeLevels jpegFile       sizes levels @?= [(16, 16), (8, 8), (4, 4)]@@ -229,7 +229,7 @@   , 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+      assertCorrupt "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@@ -244,24 +244,21 @@       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]+      assertCorrupt "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+      assertCorrupt "JPEG" . decodeBlp $ setDword (sizeSlot 0) 12 jpegFile   , testCase "three-component JPEG decodes to RGBA" $ do       let rgb = generateImage (\x y -> PixelRGB8 (fromIntegral $ x * 16) (fromIntegral $ y * 16) 128) 16 16           jpeg = BSL.toStrict . encodeJpeg $ (convertImage rgb :: Image PixelYCbCr8)           bs = blpFile defHeader { hCompression = 0, hAlphaBits = 0, hWidth = 16, hHeight = 16, hExtra = 2 }             [(fromIntegral headerSize + 4, fromIntegral $ BS.length jpeg)] ("\0\0\0\0" <> jpeg)-      dyn <- either (assertFailure . ("decodeBlp: " ++)) return $ decodeBlp bs-      case dyn of-        ImageRGBA8 img -> do-          direct <- either (assertFailure . ("decodeJpeg: " ++)) (return . convertRGBA8) $ decodeJpeg jpeg-          pixelsOf img @?= pixelsOf direct-        _ -> assertFailure "expected ImageRGBA8"+      img <- decodeRGBA bs+      direct <- either (assertFailure . ("decodeJpeg: " ++)) (return . convertRGBA8) $ decodeJpeg jpeg+      pixelsOf img @?= pixelsOf direct   , testCase "semi-transparent texture round-trips through the encoder (#17)" $ do       img <- decodeRGBA . BSL.toStrict $ enc (BlpFormatJpeg 100) 1 (ImageRGBA8 gradient)       let d = maxDiff gradient img@@ -427,10 +424,10 @@           img = ImageRGBA8 opaqueGradient           check write = bracket_ (write path) (removeFile path) $ do             Right single <- readBlp path-            let d = maxDiff opaqueGradient (convertRGBA8 single)+            let d = maxDiff opaqueGradient single             assertBool ("max channel difference " ++ show d) (d <= 8)             Right levels <- readBlpMipmaps path-            sizes (map convertRGBA8 levels) @?= [(16, 16), (8, 8)]+            sizes levels @?= [(16, 16), (8, 8)]       check $ \p -> writeOk p (BlpFormatJpeg 100) img       check $ \p -> writeOk p (BlpFormatPaletted True) img       check $ \p -> writeOk p (BlpFormatPaletted False) (ImageRGB8 $ convertRGB8 img)@@ -487,12 +484,12 @@ limitTests :: TestTree limitTests = testGroup "limits and inspection"   [ testCase "a small file claiming a huge size is rejected before allocating" $-      assertLeft "above the limit" . decodeBlp $ inflated 16384+      assertError (BlpTooLarge 16384 16384 (8192 * 8192)) . decodeBlp $ inflated 16384   , testCase "blpMaxPixels is checked for JPEG and paletted content" $ do       let limited n = decodeBlpWith (BlpDecodeOptions n)-      assertLeft "above the limit" $ limited 255 jpegFile+      assertError (BlpTooLarge 16 16 255) $ limited 255 jpegFile       assertBool "16x16 JPEG fits 256 pixels" . either (const False) (const True) $ limited 256 jpegFile-      assertLeft "above the limit" $ limited 15 (withAlphaFile 4)+      assertError (BlpTooLarge 4 4 15) $ limited 15 (withAlphaFile 4)       assertBool "4x4 paletted fits 16 pixels" . either (const False) (const True) $ limited 16 (withAlphaFile 4)   , testCase "blpInfo reads the header" $ do       blpInfo jpegFile @?= Right (BlpInfo Blp1 BlpCompressionJPEG 16 16 8 3)@@ -501,8 +498,8 @@   , testCase "blpInfo decodes no pixels" $       fmap (\i -> (blpInfoWidth i, blpInfoHeight i)) (blpInfo (inflated 16384)) @?= Right (16384, 16384)   , testCase "blpInfo rejects what decodeBlp rejects" $ do-      assertLeft "BLP1" . blpInfo $ "BLP0" <> BS.drop 4 (withAlphaFile 4)-      assertLeft "Invalid image size" . blpInfo $ setDword 12 0 (withAlphaFile 4)+      assertError BlpNotBlp . blpInfo $ "BLP0" <> BS.drop 4 (withAlphaFile 4)+      assertError (BlpInvalidSize 0 4) . blpInfo $ setDword 12 0 (withAlphaFile 4)   ]  -- | PSNR in dB between two equally sized images, on premultiplied RGBA so@@ -573,4 +570,24 @@   , testCase "JPEG from fully opaque RGBA has no alpha" $ do       let bs = BSL.toStrict $ enc (BlpFormatJpeg 90) 1 (ImageRGBA8 smoothTexture)       (getDword 8 bs, getDword extraOffset bs) @?= (0, 5)+  ]++errorTests :: TestTree+errorTests = testGroup "errors"+  [ testCase "a cut-off magic is a truncated header, other starts are not BLP" $ do+      assertError BlpTruncatedHeader $ decodeBlp "BL"+      assertError BlpNotBlp $ decodeBlp "PNG\r\n"+      assertError BlpNotBlp $ blpInfo BS.empty+  , testCase "a file without image data is an error for every decoder" $ do+      let file = blpFile defHeader [] (paletteBytes $ palette 256)+      assertError BlpNoImageData $ decodeBlpMipmaps file+      fmap blpInfoMipLevels (blpInfo file) @?= Right 0+  , testCase "errors have readable messages" $ do+      displayBlpDecodeError (BlpTooLarge 16384 16384 100) @?= "Image size 16384x16384 is above the limit of 100 pixels"+      displayBlpDecodeError (BlpUnsupported "BLP2 encoding 4") @?= "Unsupported BLP file: BLP2 encoding 4"+      displayBlpDecodeError BlpNotBlp @?= "Not a BLP file: it starts with neither BLP1 nor BLP2"+  , testCase "errors can be thrown and caught" $ do+      r <- try (throwIO BlpNoImageData)+      r @?= (Left BlpNoImageData :: Either BlpDecodeError ())+      displayException BlpNoImageData @?= displayBlpDecodeError BlpNoImageData   ]

@@ -38,6 +38,10 @@   , encode (BlpFormatJpeg 90) 16 (opaque 8 8)   , encode (BlpFormatPaletted True) 16 (texture 16 16)   , encode (BlpFormatPaletted False) 16 (texture 9 4)+  , encodeAs Blp2 BlpFormatDxt1 16 (texture 9 4)+  , encodeAs Blp2 BlpFormatDxt5 16 (texture 16 8)+  , encodeAs Blp2 BlpFormatBgra 16 (texture 5 7)+  , encodeAs Blp2 (BlpFormatPaletted True) 16 (texture 8 8)   ]   where     opaque w h = ImageRGBA8 . pixelMap (\(PixelRGBA8 r g b _) -> PixelRGBA8 r g b 255) . convertRGBA8 $ texture w h@@ -48,8 +52,11 @@     px x y = PixelRGBA8 (fromIntegral $ x * 37) (fromIntegral $ y * 59) (fromIntegral $ x * y) (fromIntegral $ 255 - x * 13)  encode :: BlpFormat -> Int -> DynamicImage -> ByteString-encode format levels = BSL.toStrict . either (error . show) id . encodeBlpWith defaultBlpEncodeOptions { blpFormat = format, blpMipLevels = levels }+encode = encodeAs Blp1 +encodeAs :: BlpVersion -> BlpFormat -> Int -> DynamicImage -> ByteString+encodeAs version format levels = BSL.toStrict . either (error . show) id . encodeBlpWith defaultBlpEncodeOptions { blpFormat = format, blpMipLevels = levels, blpVersion = version }+ -- | One way of damaging a file. data Damage   = Flip Int Word8 -- ^ XOR a byte@@ -88,7 +95,7 @@ decodingNeverThrows = forAllShow damagedFile showCase $ \(seed, ds) -> monadicIO $ do   let file = foldl damage seed ds   result <- run . timeout 1000000 . trySync . evaluate . force $-    fmap (map (imageData . convertRGBA8)) (decodeBlpMipmaps file)+    fmap (map imageData) (decodeBlpMipmaps file)   case result of     Nothing -> monitor (label "JuicyPixels hang (Juicy.Pixels#230)")     Just (Left e) -> do@@ -118,12 +125,13 @@ -- | Level l of a w x h texture is max 1 (w >> l) by max 1 (h >> l), down to -- 1x1, at most 16 levels. levelSizes :: Property-levelSizes = forAll ((,,) <$> choose (1, 40) <*> choose (1, 40) <*> format) $ \(w, h, f) ->+levelSizes = forAll ((,,) <$> choose (1, 40) <*> choose (1, 40) <*> format) $ \(w, h, (v, f)) ->   let expected = take 16 (chain w h)-      decoded = decodeBlpMipmaps (encode f 16 (texture w h))-  in either (const []) (map (\i -> (dynamicMap imageWidth i, dynamicMap imageHeight i))) decoded === expected+      decoded = decodeBlpMipmaps (encodeAs v f 16 (texture w h))+  in either (const []) (map (\i -> (imageWidth i, imageHeight i))) decoded === expected   where-    format = elements [BlpFormatJpeg 90, BlpFormatPaletted True, BlpFormatPaletted False]+    format = elements $ [(Blp1, f) | f <- [BlpFormatJpeg 90, BlpFormatPaletted True, BlpFormatPaletted False]]+      ++ [(Blp2, f) | f <- [BlpFormatPaletted True, BlpFormatPaletted False, BlpFormatDxt1, BlpFormatDxt3, BlpFormatDxt5, BlpFormatBgra]]     chain w h = go 0       where         go l = let s = (max 1 (w `shiftR` l), max 1 (h `shiftR` l))@@ -135,7 +143,7 @@ fewColoursExact = forAll gen $ \(w, h, colours, picks) ->   let img = generateImage (\x y -> colours !! (picks !! (y * w + x))) w h       decoded = decodeBlp (encode (BlpFormatPaletted False) 1 (ImageRGBA8 img))-  in fmap (imageData . convertRGBA8) decoded === Right (imageData img)+  in fmap imageData decoded === Right (imageData img)   where     gen = do       w <- choose (1, 24)