JuicyPixels-blp (empty) → 0.1.0.0
raw patch · 14 files changed
+1215/−0 lines, 14 filesdep +JuicyPixelsdep +JuicyPixels-blpdep +attoparsecsetup-changed
Dependencies added: JuicyPixels, JuicyPixels-blp, attoparsec, base, binary, bytestring, directory, filepath, hashable, optparse-simple, text-show, unordered-containers, vector
Files
- CHANGELOG.md +4/−0
- JuicyPixels-blp.cabal +68/−0
- LICENSE +30/−0
- README.md +17/−0
- Setup.hs +2/−0
- blp2any/Convert.hs +171/−0
- blp2any/File.hs +32/−0
- blp2any/Main.hs +47/−0
- blp2any/Statistics.hs +59/−0
- src/Codec/Picture/Blp.hs +118/−0
- src/Codec/Picture/Blp/Internal/Convert.hs +118/−0
- src/Codec/Picture/Blp/Internal/Data.hs +124/−0
- src/Codec/Picture/Blp/Internal/Encoder.hs +297/−0
- src/Codec/Picture/Blp/Internal/Parser.hs +128/−0
+ CHANGELOG.md view
@@ -0,0 +1,4 @@+0.1.0.0+=======++Initial release.
+ JuicyPixels-blp.cabal view
@@ -0,0 +1,68 @@+name: JuicyPixels-blp+version: 0.1.0.0+synopsis: BLP format decoder/encoder over JuicyPixels library+description: Please see README.md+homepage: http://github.com/NCrashed/JuicyPixels-blp#readme+license: BSD3+license-file: LICENSE+author: Anton Gushcha+maintainer: ncrashed@gmail.com+copyright: 2015-2018 Anton Gushcha+category: Codec, Graphics, Image+build-type: Simple+cabal-version: >=1.10+extra-source-files: README.md, CHANGELOG.md++source-repository head+ type: git+ location: git@github.com:NCrashed/JuicyPixels-blp.git++library+ hs-source-dirs: src+ exposed-modules:+ Codec.Picture.Blp+ Codec.Picture.Blp.Internal.Convert+ Codec.Picture.Blp.Internal.Data+ Codec.Picture.Blp.Internal.Encoder+ Codec.Picture.Blp.Internal.Parser++ default-language: Haskell2010+ build-depends:+ base >= 4.7 && < 5+ , attoparsec >= 0.12 && < 0.14+ , binary >= 0.8 && < 0.9+ , bytestring >= 0.10 && < 0.11+ , hashable >= 1.2 && < 1.3+ , JuicyPixels >= 3.2 && < 3.3+ , text-show >= 3.7 && < 3.8+ , vector >= 0.10 && < 0.13++ default-extensions:+ BangPatterns+ DeriveGeneric+ MultiWayIf+ OverloadedStrings+ RecordWildCards++executable blp2any+ hs-source-dirs: blp2any+ main-is: Main.hs+ other-modules:+ Convert+ File+ Statistics+ ghc-options: -threaded -O2 -rtsopts -with-rtsopts=-N+ default-language: Haskell2010+ build-depends:+ base >= 4.7 && < 5+ , bytestring+ , directory >= 1.2 && < 1.4+ , filepath >= 1.4 && < 1.5+ , JuicyPixels+ , JuicyPixels-blp+ , optparse-simple >= 0.0.3 && < 0.2+ , text-show+ , unordered-containers >= 0.2 && < 0.3++ default-extensions:+ RecordWildCards
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2015++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,17 @@+JuicyPixels-blp+===============++The library provides decoding/encoding functions for BLP1 texture format of Warcraft III game.+The result is represented in types of [JuicyPixels](http://hackage.haskell.org/package/JuicyPixels) library.++Features:++- Supported all three subtypes of BLP1: JPEG with alpha, paletted without alpha and paletted with alpha.++- Command line utility to convert BLPs from/to PNG, JPEG, BMP, TGA, TIFF, GIF, Radiance formats.++TODO:++- BLP0 support++- BLP2 support
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ blp2any/Convert.hs view
@@ -0,0 +1,171 @@+module Convert(+ convertFiles+ , ConvertFormat(..)+ , ConvertOptions(..)+ , readConvertFormat+ , BlpFormat(..)+ , readBlpFormat+ ) where++import Codec.Picture+import Codec.Picture.Blp+import Control.Monad+import Data.Char+import Data.Maybe+import Data.Monoid+import System.Directory+import System.FilePath++import qualified Data.ByteString as BS++import File++data BlpFormat =+ BlpJpeg+ | BlpUncompressedWithAlpha+ | BlpUncompressedWithoutAlpha+ deriving (Eq, Ord, Show, Enum, Bounded)++readBlpFormat :: String -> Maybe BlpFormat+readBlpFormat s = case toLower <$> s of+ "jpeg" -> Just BlpJpeg+ "jpg" -> Just BlpJpeg+ "uncompressed1" -> Just BlpUncompressedWithAlpha+ "uncompressedwithalpha" -> Just BlpUncompressedWithAlpha+ "uncompressed2" -> Just BlpUncompressedWithoutAlpha+ "uncompressedwithoutalpha" -> Just BlpUncompressedWithoutAlpha+ _ -> Nothing++data ConvertFormat =+ Blp+ | Png+ | Jpeg+ | Tiff+ | Gif+ | Bmp+ | UnspecifiedFormat+ deriving (Eq, Ord, Show, Enum, Bounded)++readConvertFormat :: String -> Maybe ConvertFormat+readConvertFormat s = case toLower <$> s of+ "blp" -> Just Blp+ "png" -> Just Png+ "jpeg" -> Just Jpeg+ "jpg" -> Just Jpeg+ "jpe" -> Just Jpeg+ "jif" -> Just Jpeg+ "jfif" -> Just Jpeg+ "jfi" -> Just Jpeg+ "tiff" -> Just Tiff+ "gif" -> Just Gif+ "bmp" -> Just Bmp+ _ -> Nothing++-- | Replaces Unspecified+defaultFormat :: ConvertFormat+defaultFormat = Png++formatExtension :: ConvertFormat -> [String]+formatExtension c = case c of+ Blp -> [".blp"]+ Png -> [".png"]+ Jpeg -> [".jpeg", ".jpg", ".jpe", ".jif", ".jfif", ".jfi"]+ Tiff -> [".tiff"]+ Gif -> [".gif"]+ Bmp -> [".bmp"]+ UnspecifiedFormat -> []++supportedExtensions :: [String]+supportedExtensions = concat $ formatExtension <$> [Blp .. Bmp]++data ConvertOptions = ConvertOptions {+ convertInput :: FilePath+, convertOutput :: FilePath+, convertInputFormat :: ConvertFormat+, convertFormat :: ConvertFormat+, convertQuality :: Int+, convertPreservesDirs :: Bool+, convertShallow :: Bool+, convertBlpFormat :: BlpFormat+, convertBlpMinMipSize :: Int+}++convertFiles :: ConvertOptions -> IO ()+convertFiles opts@ConvertOptions{..} = do+ efx <- doesFileExist convertInput+ if efx+ then convertFile opts False convertInput+ else do+ edx <- doesDirectoryExist convertInput+ if edx then forEachFile' convertInput fileFilter $ convertFile opts True+ else fail "Given path is not exists!"+ where+ fileFilter s = case convertFormat of+ Blp -> or $ ((takeExtension s) ==) <$> supportedExtensions+ _ -> (".blp" ==) . takeExtension $ s++-- | Trye to guess format from name of file+guessFormat :: FilePath -> Maybe ConvertFormat+guessFormat = readConvertFormat . drop 1 . takeExtension++-- | Try to load input file with desired format+readInputFile :: FilePath -> ConvertFormat -> IO DynamicImage+readInputFile inputFile format = case format of+ Blp -> do+ fc <- BS.readFile inputFile+ case decodeBlp fc of+ Left err -> fail $ "Failed to load file " <> inputFile <> ", parse error: " <> err+ Right img -> pure img+ Png -> loadJuicy readPng+ Jpeg -> loadJuicy readJpeg+ Tiff -> loadJuicy readTiff+ Gif -> loadJuicy readGif+ Bmp -> loadJuicy readBitmap+ UnspecifiedFormat -> case guessFormat inputFile of+ Just newFormat -> readInputFile inputFile newFormat+ Nothing -> fail $ "Cannot infer format from filename " <> inputFile+ where+ loadJuicy :: (FilePath -> IO (Either String DynamicImage)) -> IO DynamicImage+ loadJuicy f = do+ mres <- f inputFile+ case mres of+ Left err -> fail $ "Failed to load file " <> inputFile <> " as " <> show format <> ", error: " <> err+ Right img -> pure img++convertFile :: ConvertOptions -> Bool -> FilePath -> IO ()+convertFile ConvertOptions{..} isDir inputFile = do+ img <- readInputFile inputFile convertInputFormat+ let distFormat = case convertFormat of+ UnspecifiedFormat -> if isDir then defaultFormat+ else case guessFormat convertOutput of+ Just f -> f+ Nothing -> defaultFormat+ _ -> convertFormat++ when isDir $ createDirectoryIfMissing True convertOutput+ let outputFile = if isDir+ then convertOutput <> "/" <> takeBaseName inputFile <> fromMaybe "" (listToMaybe $ formatExtension distFormat)+ else convertOutput++ let mipsCount = mipMapsUpTo convertBlpMinMipSize img+ res <- (convertionFunction distFormat convertQuality convertBlpFormat) outputFile mipsCount img+ case res of+ Left err -> fail $ inputFile <> ": " <> err+ Right _ -> putStrLn $ inputFile <> ": Success"++convertionFunction :: ConvertFormat -> Int -> BlpFormat -> FilePath -> Int -> DynamicImage -> IO (Either String ())+convertionFunction f quality blpFormat path mipsCount img = case f of+ Blp -> case blpFormat of+ BlpJpeg -> writeBlpJpeg path quality mipsCount img >> pure (Right ())+ BlpUncompressedWithAlpha -> writeBlpUncompressedWithAlpha path mipsCount img >> pure (Right ())+ BlpUncompressedWithoutAlpha -> writeBlpUncompressedWithoutAlpha path mipsCount img >> pure (Right ())+ Png -> do+ res <- writeDynamicPng path img+ pure $ void res+ Jpeg -> saveJpgImage quality path img >> pure (Right ())+ Tiff -> saveTiffImage path img >> pure (Right ())+ Gif -> case saveGifImage path img of+ Left er -> pure $ Left er+ Right io -> io >> pure (Right ())+ Bmp -> saveBmpImage path img >> pure (Right ())+ UnspecifiedFormat -> pure $ Left "no conversion format specified"
+ blp2any/File.hs view
@@ -0,0 +1,32 @@+module File(+ forEachFile+ , forEachFile'+ ) where++import System.Directory+import System.FilePath+import Control.Monad ++-- | Performs width traversion of given directory+forEachFile :: FilePath -- ^ Directory to traverse+ -> (FilePath -> Bool) -- ^ File selector+ -> (a -> FilePath -> IO a) -- ^ Function to perform (mimics fold)+ -> a -- ^ Start value of acum+ -> IO a -- ^ Last value of accum+forEachFile path predf f acc = go acc path+ where+ go a inputPath = do + names <- fmap (\p -> inputPath ++ "/" ++ p) <$> getDirectoryContents inputPath+ dirs <- filter (not . isSystemDir) <$> filterM doesDirectoryExist names+ files <- filter predf <$> filterM doesFileExist names+ a' <- foldM f a files + a' `seq` foldM go a' dirs++ isSystemDir s = let bs = takeFileName s in bs == "." || bs == ".."++-- | Performs width traversion of given directory, simplified versino of forEachFile+forEachFile' :: FilePath -- ^ Directory to traverse+ -> (FilePath -> Bool) -- ^ File selector+ -> (FilePath -> IO ()) -- ^ Function to perform+ -> IO ()+forEachFile' path predf f = forEachFile path predf (const f) ()
+ blp2any/Main.hs view
@@ -0,0 +1,47 @@+module Main where++import Data.Monoid+import Options.Applicative.Simple++import Statistics+import Convert++-- | Helper for lifting pure parsing functions into ReadM monad+readMPure :: String -- ^ Name of argument for pretty error message+ -> (String -> Maybe a) -- ^ Function that parses the argument+ -> ReadM a -- ^ Optparse parser monad+readMPure desc f = do+ s <- str+ case f s of+ Nothing -> fail $ "Unknown " ++ desc ++ " " ++ s+ Just v -> return v++-- | How to parse ConvertFormat+convertFormatR :: ReadM ConvertFormat+convertFormatR = readMPure "format" readConvertFormat++-- | How to parse BlpFormat+blpFormatR :: ReadM BlpFormat+blpFormatR = readMPure "blp format" readBlpFormat++main :: IO ()+main = do+ (_,runCmd) <- simpleOptions ver headerDesc desc (pure ()) $ do+ addCommand "convert" "Converts given blp or folder with blps to PNG" convertFiles $ (<*>) helper $ ConvertOptions+ <$> strArgument (metavar "INPUT_PATH" <> help "input file or directory (batch mode)")+ <*> strArgument (metavar "OUTPUT_PATH" <> help "output file name or directory (need explicit format option)")+ <*> option convertFormatR (long "input-format" <> short 'i' <> value UnspecifiedFormat <> help "Input file format, if not specified tries to infer from input file name. Values: blp png jpg tiff gif bmp.")+ <*> option convertFormatR (long "format" <> short 'f' <> value UnspecifiedFormat <> help "Output file format, if not specified tries to infer from output file name. Values: blp png jpg tiff gif bmp.")+ <*> option auto (long "quality" <> short 'q' <> value 90 <> help "Quality level for formats with lossy compression (default 90)")+ <*> fmap not (switch (long "notPreserveStructure" <> short 'p' <> help "Will not produce subfolders while batch converting" ))+ <*> switch (long "shallow" <> short 's' <> help "Not look into subfolders while batch converting")+ <*> option blpFormatR (long "blpFormat" <> short 'b' <> value BlpJpeg <> help "Specifies what BLP internal format to use when converting to BLP. Values: jpg uncompressedWithAlpha uncompressedWithoutAlpha")+ <*> option auto (long "min-mipmap-size" <> value 1 <> help "Minimum size of mimmap side to include in resulted BLP file")+ addCommand "stats" "Collects statistics about BLP images in folder and saves examples of BLP's for each sample" (uncurry collectStatistics) $ (<*>) helper $ (,)+ <$> strArgument (metavar "DIRECTORY" <> help "Input folder that stores blps (subfolders are processed)")+ <*> strArgument (metavar "OUTPUT_PATH" <> help "Here blp samples would be stored")+ runCmd+ where+ ver = "0.1.0.0"+ headerDesc = ""+ desc = "Converting BLP1 Warcraft III format to/from PNG, JPEG, TGA, TIFF, BMP, GIF"
+ blp2any/Statistics.hs view
@@ -0,0 +1,59 @@+module Statistics(+ collectSamples + , printStatistics+ , collectStatistics+ ) where++import Codec.Picture.Blp.Internal.Data+import Codec.Picture.Blp.Internal.Parser+import Control.Monad +import Data.Word +import System.Directory+import System.FilePath++import qualified Data.ByteString as BS+import qualified Data.HashMap.Strict as H +import qualified Data.List as L ++import File ++type BlpInfo = (BlpCompression, [BlpFlag], BlpPictureType, Word32)+type BlpStat = (FilePath, Int)++type StatMap = H.HashMap BlpInfo BlpStat++collectSamples :: FilePath -> IO StatMap+collectSamples dir = do + f <- doesDirectoryExist dir+ unless f $ fail $ "Provided directory " ++ dir ++ " doesn't exists!"+ forEachFile dir ((".blp" ==).takeExtension) collectSample H.empty+ +collectSample :: StatMap -> FilePath -> IO StatMap +collectSample stats inputFile = do + putStrLn $ "Sampling " ++ inputFile+ fc <- BS.readFile inputFile+ case parseBlp fc of + Left err -> fail $ inputFile ++ ": " ++ err + Right blp -> return $ adjust' (updateStat inputFile) (blpType blp) stats++blpType :: BlpStruct -> BlpInfo +blpType BlpStruct{..} = (blpCompression, blpFlags, blpPictureType, blpPictureSubType)++adjust' :: (Maybe BlpStat -> BlpStat) -> BlpInfo -> StatMap -> StatMap +adjust' f k m = H.insert k (f $ H.lookup k m) m++updateStat :: FilePath -> Maybe BlpStat -> BlpStat +updateStat path Nothing = (path, 1)+updateStat _ (Just (p, i)) = (p, i+1)++printStatistics :: FilePath -> StatMap -> IO () +printStatistics dir stats = do+ createDirectoryIfMissing True dir+ forM_ (H.toList stats) $ \((compression, flags, pictureType, pictureSubType), (path, i)) -> do + let postfix = L.intercalate "-" [show compression, show flags, show pictureType, show pictureSubType]+ copyFile path $ dir ++ "/" ++ dropExtension (takeFileName path) ++ "-"+ ++ postfix ++ ".blp"+ putStrLn $ postfix ++ ": " ++ show i ++ " images"++collectStatistics :: FilePath -> FilePath -> IO ()+collectStatistics dir outputDir = printStatistics outputDir =<< collectSamples dir
+ src/Codec/Picture/Blp.hs view
@@ -0,0 +1,118 @@+module Codec.Picture.Blp(+ readBlp+ , readBlpMipmaps+ , decodeBlp+ , decodeBlpMipmaps+ , writeBlpJpeg+ , writeBlpUncompressedWithAlpha+ , writeBlpUncompressedWithoutAlpha+ , encodeBlpJpeg+ , encodeBlpUncompressedWithAlpha+ , encodeBlpUncompressedWithoutAlpha+ , mipMapsUpTo+ ) where++import Codec.Picture+import Codec.Picture.Types+import Data.ByteString (ByteString)+import Data.Monoid+import Data.Word+import TextShow.Debug.Trace++import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BSL+import qualified Data.Vector as V++import Codec.Picture.Blp.Internal.Convert+import Codec.Picture.Blp.Internal.Data+import Codec.Picture.Blp.Internal.Encoder+import Codec.Picture.Blp.Internal.Parser++-- | Read BLP from given file without mipmaps+readBlp :: FilePath -> IO (Either String DynamicImage)+readBlp fp = decodeBlp `fmap` BS.readFile fp++-- | Read BLP from given file with mipmaps+readBlpMipmaps :: FilePath -> IO (Either String [DynamicImage])+readBlpMipmaps fp = decodeBlpMipmaps `fmap` BS.readFile fp++-- | Decodes BLP without mipmaps+decodeBlp :: ByteString -> Either String DynamicImage+decodeBlp bs = do+ is <- decodeBlpMipmaps bs+ if null is then Left "No data in BLP"+ else return $ head is++-- | Decodes BLP and returns original image plus all mipmaps+decodeBlpMipmaps :: ByteString -> Either String [DynamicImage]+decodeBlpMipmaps bs = do+ blp <- parseBlp bs+ case blpExt $ traceTextShowId blp of+ BlpJpeg {..} -> do+ let jpegs = (blpJpegHeader <>) `fmap` blpJpegData+ mips <- mapM decodeJpeg jpegs+ return $ toPngRepresentable <$> mips++ BlpUncompressed1 {..} -> do+ let mkImage mip = ImageRGBA8 $ generateImage (gen mip) (fromIntegral $ blpWidth blp) (fromIntegral $ blpHeight blp)+ return $ mkImage `fmap` blpU1MipMaps+ where+ palette :: Word8 -> PixelRGBA8+ palette i = blpU1Palette V.! fromIntegral i++ makeIndex x y = y*(fromIntegral $ blpWidth blp)+x+ takeColor mip x y = palette $ fst mip `BS.index` makeIndex x y+ takeAlpha mip x y = snd mip `BS.index` makeIndex x y+ gen mip x y = let+ PixelRGBA8 r g b _ = takeColor mip x y+ a = takeAlpha mip x y+ in PixelRGBA8 b g r a++ BlpUncompressed2 {..} -> do+ let mkImage mip = ImageRGBA8 $ generateImage (gen mip) (fromIntegral $ blpWidth blp) (fromIntegral $ blpHeight blp)+ return $ mkImage `fmap` blpU2MipMaps+ where+ palette :: Word8 -> PixelRGBA8+ palette i = blpU2Palette V.! fromIntegral i++ makeIndex x y = y*(fromIntegral $ blpWidth blp)+x+ takeColor mip x y = palette $ mip `BS.index` makeIndex x y+ gen mip x y = let+ PixelRGBA8 r g b a = takeColor mip x y+ in PixelRGBA8 b g r (255 - a)++-- | Calculate needed count of mipmaps to cover sizes up to given minimum size (helper for 'writeBlp*' functions)+mipMapsUpTo :: Int -- ^ Minimum size of picture side for generation of mipmap (ex. 2, 4, 16, 32, 64, 512, 1024 and etc)+ -> DynamicImage -- ^ Image for which we generate mipmaps+ -> Int+mipMapsUpTo minSize img = maxNum - minSizeNum+ where+ w = dynamicMap imageWidth img+ h = dynamicMap imageHeight img+ minSide = min w h+ maxNum = ceiling $ logBase 2 (fromIntegral minSide)+ minSizeNum = floor $ logBase 2 (fromIntegral (max 1 minSize))++writeBlpJpeg :: FilePath -> Int -> Int -> DynamicImage -> IO ()+writeBlpJpeg fp quality numMips img = do+ let bs = encodeBlpJpeg quality numMips img+ BSL.writeFile fp bs++writeBlpUncompressedWithAlpha :: FilePath -> Int -> DynamicImage -> IO ()+writeBlpUncompressedWithAlpha fp numMips img = do+ let bs = encodeBlpUncompressedWithAlpha numMips img+ BSL.writeFile fp bs++writeBlpUncompressedWithoutAlpha :: FilePath -> Int -> DynamicImage -> IO ()+writeBlpUncompressedWithoutAlpha fp numMips img = do+ let bs = encodeBlpUncompressedWithoutAlpha numMips img+ BSL.writeFile fp bs++encodeBlpJpeg :: Int -> Int -> DynamicImage -> BSL.ByteString+encodeBlpJpeg quality numMips = encodeBlp numMips {-. traceTextShowId-} . toBlpStruct BlpCompressionJPEG quality numMips++encodeBlpUncompressedWithAlpha :: Int -> DynamicImage -> BSL.ByteString+encodeBlpUncompressedWithAlpha numMips = encodeBlp numMips {-. traceTextShowId-} . toBlpStruct BlpCompressionUncompressed 100 numMips++encodeBlpUncompressedWithoutAlpha :: Int -> DynamicImage -> BSL.ByteString+encodeBlpUncompressedWithoutAlpha numMips = encodeBlp numMips {-. traceTextShowId-} . toBlpStruct BlpCompressionUncompressed 100 numMips
+ src/Codec/Picture/Blp/Internal/Convert.hs view
@@ -0,0 +1,118 @@+module Codec.Picture.Blp.Internal.Convert(+ toPngRepresentable+ , toBlpUncompressable+ , toBlpCMYK8+ ) where++import Codec.Picture+import Codec.Picture.Types+import Data.Word++toPngRepresentable :: DynamicImage -> DynamicImage+toPngRepresentable i = case i of+ ImageY8 _ -> i+ ImageY16 _ -> i+ ImageYF p -> ImageRGB16 . convertFloatImage16 . promoteImage $ p+ ImageYA8 _ -> i+ ImageYA16 _ -> i+ ImageRGB8 _ -> i+ ImageRGB16 _ -> i+ ImageRGBF p -> ImageRGB16 . convertFloatImage16 $ p+ ImageRGBA8 _ -> i+ ImageRGBA16 _ -> i+ ImageYCbCr8 p -> ImageRGB8 . convertImage $ p+ ImageCMYK8 p -> ImageRGBA8 . convertCMYK8Image $ p+ ImageCMYK16 p -> ImageRGBA16 . convertCMYK16Image $ p++toBlpUncompressable :: DynamicImage -> Image PixelRGBA8+toBlpUncompressable i = case i of+ ImageY8 p -> toBlpRGB8 (promoteImage p :: Image PixelRGB8)+ ImageY16 p -> toBlpRGB8 (dropBits (promoteImage p :: Image PixelRGB16) :: Image PixelRGB8)+ ImageYF p -> toBlpRGB8 (convertFloatImage8 (promoteImage p :: Image PixelRGBF) :: Image PixelRGB8)+ ImageYA8 p -> toBlpRGBA8 (promoteImage p :: Image PixelRGBA8)+ ImageYA16 p -> toBlpRGBA8 (dropBitsA (promoteImage p :: Image PixelRGBA16) :: Image PixelRGBA8)+ ImageRGB8 p -> toBlpRGB8 p+ ImageRGB16 p -> toBlpRGB8 (dropBits p :: Image PixelRGB8)+ ImageRGBF p -> toBlpRGB8 (convertFloatImage8 p :: Image PixelRGB8)+ ImageRGBA8 p -> toBlpRGBA8 p+ ImageRGBA16 p -> toBlpRGBA8 (dropBitsA p :: Image PixelRGBA8)+ ImageYCbCr8 p -> toBlpRGB8 (convertImage p :: Image PixelRGB8)+ ImageCMYK8 p -> toBlpRGB8 (convertImage p :: Image PixelRGB8)+ ImageCMYK16 p -> toBlpRGB8 (dropBits (convertImage p :: Image PixelRGB16) :: Image PixelRGB8)++dropBits :: Image PixelRGB16 -> Image PixelRGB8+dropBits = pixelMap $ \(PixelRGB16 r g b) -> PixelRGB8 (f r) (f g) (f b)+ where+ f :: Word16 -> Word8+ f x = round $ 255 * (fromIntegral x :: Double) / 65535++dropBitsA :: Image PixelRGBA16 -> Image PixelRGBA8+dropBitsA = pixelMap $ \(PixelRGBA16 r g b a) -> PixelRGBA8 (f r) (f g) (f b) (f a)+ where+ f :: Word16 -> Word8+ f x = round $ 255 * (fromIntegral x :: Double) / 65535++convertFloatImage8 :: Image PixelRGBF -> Image PixelRGB8+convertFloatImage8 = pixelMap convert+ where+ convert (PixelRGBF rf gf bf) = PixelRGB8+ (round $ 255 * rf)+ (round $ 255 * gf)+ (round $ 255 * bf)++convertFloatImage16 :: Image PixelRGBF -> Image PixelRGB16+convertFloatImage16 = pixelMap convert+ where+ convert (PixelRGBF rf gf bf) = PixelRGB16+ (round $ 65535 * rf)+ (round $ 65535 * gf)+ (round $ 65535 * bf)++convertCMYK8Image :: Image PixelCMYK8 -> Image PixelRGBA8+convertCMYK8Image = pixelMap convert+ where+ clampWord8 = fromIntegral . max 0 . min 255 . (`div` 256)+ convert (PixelCMYK8 c m y k) =+ PixelRGBA8 (clampWord8 r) (clampWord8 g) (clampWord8 b) k+ where+ ik :: Int+ ik = fromIntegral k+ r = fromIntegral y * ik+ g = fromIntegral m * ik+ b = fromIntegral c * ik++toBlpCMYK8 :: Image PixelRGBA8 -> Image PixelCMYK8+toBlpCMYK8 = pixelMap convert+ where+ clampWord8 = fromIntegral . max 0 . min 255+ convert (PixelRGBA8 r g b a) = PixelCMYK8 (clampWord8 c) (clampWord8 m) (clampWord8 y) a+ where+ ik = fromIntegral a :: Double+ c, m, y :: Int+ c = round $ 256 * fromIntegral b / ik+ m = round $ 256 * fromIntegral g / ik+ y = round $ 256 * fromIntegral r / ik++toBlpRGBA8 :: Image PixelRGBA8 -> Image PixelRGBA8+toBlpRGBA8 = pixelMap convert+ where+ convert (PixelRGBA8 r g b a) = PixelRGBA8 b g r a++toBlpRGB8 :: Image PixelRGB8 -> Image PixelRGBA8+toBlpRGB8 = pixelMap convert+ where+ convert (PixelRGB8 r g b) = PixelRGBA8 b g r 0++convertCMYK16Image :: Image PixelCMYK16 -> Image PixelRGBA16+convertCMYK16Image = pixelMap convert+ where+ convert (PixelCMYK16 c m y k) =+ PixelRGBA16 (clampWord16 r) (clampWord16 g) (clampWord16 b) 65535+ where+ clampWord16 = fromIntegral . max 0 . min 65535 . (`div` 65535)++ ik :: Int+ ik = fromIntegral k+ r = fromIntegral y * ik+ g = fromIntegral m * ik+ b = fromIntegral c * ik
+ src/Codec/Picture/Blp/Internal/Data.hs view
@@ -0,0 +1,124 @@+module Codec.Picture.Blp.Internal.Data(+ BlpStruct(..)+ , BlpCompression(..)+ , BlpFlag(..)+ , BlpPictureType(..)+ , BlpExt(..)+ ) where++import Codec.Picture+import Data.Bifunctor+import Data.ByteString (ByteString)+import Data.Hashable+import Data.Monoid+import Data.Vector (Vector)+import Data.Word+import GHC.Generics+import TextShow++import qualified Data.ByteString as BS+import qualified Data.Vector as V++data BlpStruct = BlpStruct {+ blpCompression :: !BlpCompression+, blpFlags :: ![BlpFlag]+, blpWidth :: !Word32+, blpHeight :: !Word32+, blpPictureType :: !BlpPictureType+, blpPictureSubType :: !Word32 -- is not used+, blpExt :: BlpExt+} deriving (Show, Generic)++instance TextShow BlpStruct where+ showb BlpStruct{..} = "BlpStruct {\n"+ <> " blpCompression = " <> showb blpCompression <> "\n"+ <> ", blpFlags = " <> showb blpFlags <> "\n"+ <> ", blpWidth = " <> showb blpWidth <> "\n"+ <> ", blpHeight = " <> showb blpHeight <> "\n"+ <> ", blpPictureType = " <> showb blpPictureType <> "\n"+ <> ", blpPictureSubType = " <> showb blpPictureSubType <> "\n"+ <> ", blpExt = " <> showb blpExt <> "\n"+ <> "}"++data BlpExt =+ BlpJpeg {+ blpJpegHeader :: !ByteString+ , blpJpegData :: ![ByteString]+ }+ | BlpUncompressed1 {+ blpU1Palette :: !(Vector PixelRGBA8)+ , blpU1MipMaps :: ![(ByteString, ByteString)]+ }+ | BlpUncompressed2 {+ blpU2Palette :: !(Vector PixelRGBA8)+ , blpU2MipMaps :: ![ByteString]+ }+ deriving (Show, Generic)++-- | Helper to display bytestring as placeholder with length+showBinary :: ByteString -> Builder+showBinary v = "<bslength " <> tl v <> ">"+ where+ tl = showb . BS.length++-- | Helper to display bytestring as placeholder with length+showVector :: Vector a -> Builder+showVector v = "<veclength " <> tl v <> ">"+ where+ tl = showb . V.length++-- | Helper that works as Data.Text.intercalate+intercalateb :: Builder -> [Builder] -> Builder+intercalateb _ [] = mempty+intercalateb _ [x] = x +intercalateb spacer (x:xs) = x <> spacer <> intercalateb spacer xs++instance TextShow BlpExt where+ showb v = case v of+ BlpJpeg{..} -> "BlpJpeg { \n"+ <> " blpJpegHeader = " <> showBinary blpJpegHeader <> "\n"+ <> ", blpJpegData = [" <> intercalateb ", " (fmap showBinary blpJpegData) <> "]\n"+ <> "}"+ BlpUncompressed1{..} -> "BlpUncompressed1 { \n"+ <> " blpU1Palette = " <> showVector blpU1Palette <> "\n"+ <> ", blpU1MipMaps = [" <> intercalateb ", " ( (\(a, b) -> "(" <> showBinary a <> ", " <> showBinary b <> ")") <$> blpU1MipMaps) <> "]\n"+ <> "}"+ BlpUncompressed2{..} -> "BlpUncompressed2 { \n"+ <> " blpU2Palette = " <> showVector blpU2Palette <> "\n"+ <> ", blpU2MipMaps = [" <> intercalateb ", " (fmap showBinary blpU2MipMaps) <> "]\n"+ <> "}"++data BlpCompression =+ BlpCompressionJPEG+ | BlpCompressionUncompressed+ deriving (Eq, Ord, Enum, Bounded, Show, Generic)++instance TextShow BlpCompression where+ showb v = case v of+ BlpCompressionJPEG -> "BlpCompressionJPEG"+ BlpCompressionUncompressed -> "BlpCompressionUncompressed"++instance Hashable BlpCompression++data BlpFlag = BlpFlagAlphaChannel+ deriving (Eq, Ord, Enum, Bounded, Show, Generic)++instance TextShow BlpFlag where+ showb v = case v of+ BlpFlagAlphaChannel -> "BlpFlagAlphaChannel"++instance Hashable BlpFlag++data BlpPictureType =+ JPEGType+ | UncompressedWithAlpha+ | UncompressedWithoutAlpha+ deriving (Eq, Ord, Enum, Bounded, Show, Generic)++instance TextShow BlpPictureType where+ showb v = case v of+ JPEGType -> "JPEGType"+ UncompressedWithAlpha -> "UncompressedWithAlpha"+ UncompressedWithoutAlpha -> "UncompressedWithoutAlpha"++instance Hashable BlpPictureType
+ src/Codec/Picture/Blp/Internal/Encoder.hs view
@@ -0,0 +1,297 @@+module Codec.Picture.Blp.Internal.Encoder(+ encodeBlp+ , blpEncoder+ , createMipMaps+ , createMipMapsIndexed+ , scanHeader+ , toBlpStruct+ , toBlpExt+ ) where++import Codec.Picture+import Codec.Picture.ColorQuant+import Codec.Picture.Jpg+import Codec.Picture.Types+import Data.Binary.Put+import Data.Bits+import Data.ByteString.Lazy (ByteString, toStrict)+import Data.Foldable (traverse_)+import Data.Maybe+import Data.Monoid+import Data.Word+import Foreign+import System.IO.Unsafe (unsafePerformIO)++import qualified Codec.Picture.Metadata as CM+import qualified Data.ByteString as BS+import qualified Data.ByteString.Unsafe as BS+import qualified Data.Foldable as F+import qualified Data.Vector as V+import qualified Data.Vector.Storable as VS++import Codec.Picture.Blp.Internal.Convert+import Codec.Picture.Blp.Internal.Data++-- | Convert spare BLP structure into compact stream of bytes+encodeBlp :: Int -> BlpStruct -> ByteString+encodeBlp numMips = runPut . blpEncoder numMips++-- | Raw encoder for BLP+blpEncoder :: Int -> BlpStruct -> Put+blpEncoder numMips BlpStruct{..} = do+ putBlpVersion+ putCompression+ putFlags+ putWidth+ putHeight+ putPictureType+ putPictureSubType+ putMipMapOffsets+ putMipMapSizes+ putBlpExt+ where+ putBlpVersion = putByteString "BLP1"+ putCompression = putWord32le $ case blpCompression of+ BlpCompressionJPEG -> 0+ BlpCompressionUncompressed -> 1+ putFlags = let+ addFlag acc flag = (acc +) $ case flag of+ BlpFlagAlphaChannel -> 1 `shiftL` 3+ in putWord32le $ F.foldl' addFlag 0 blpFlags+ putWidth = putWord32le blpWidth+ putHeight = putWord32le blpHeight+ putPictureType = putWord32le $ case blpPictureType of+ JPEGType -> 2+ UncompressedWithAlpha -> 3+ -- UncompressedWithAlpha -> 4+ UncompressedWithoutAlpha -> 5+ putPictureSubType = putWord32le blpPictureSubType+ headerSize = 4 -- BLP1+ + 4 -- Compression+ + 4 -- Flags+ + 4 -- Width+ + 4 -- Height+ + 4 -- Picture type+ + 4 -- Picture subtype+ + 16 * 4 -- Mipmaps offsets+ + 16 * 4 -- Mipmaps sizes+ mipmaps = let+ mkOffsetSize :: BS.ByteString -> (Int, [(Word32, Word32)]) -> (Int, [(Word32, Word32)])+ mkOffsetSize bs (!offset, !acc) = (offset + BS.length bs, (fromIntegral offset, fromIntegral $ BS.length bs) : acc)+ uncomprStartOffset = headerSize + 4 * 256+ in reverse . snd $ case blpExt of+ BlpJpeg{..} -> let+ startOffset = headerSize + 4 + BS.length blpJpegHeader+ in F.foldr' mkOffsetSize (startOffset, []) $ reverse blpJpegData+ BlpUncompressed1{..} -> let+ mkOffsetSizeU (indbs, alpbs) (!offset, !acc) = (offset + BS.length indbs + BS.length alpbs, (fromIntegral offset, fromIntegral $ BS.length indbs + BS.length alpbs) : acc)+ in F.foldr' mkOffsetSizeU (uncomprStartOffset, []) $ reverse blpU1MipMaps+ BlpUncompressed2{..} -> F.foldr' mkOffsetSize (uncomprStartOffset, []) $ reverse blpU2MipMaps+ ensureLength _ [] = []+ ensureLength n xs = if length xs < n+ then xs ++ replicate (n - length xs) (last xs)+ else take n xs+ ensureLengthV n a xs = if V.length xs < n then xs <> V.replicate (n - V.length xs) a else V.take n xs+ putMipMapOffsets = traverse_ putWord32le . ensureLength 16 . take numMips . fmap fst $ mipmaps+ putMipMapSizes = traverse_ putWord32le . ensureLength 16 . take numMips . fmap snd $ mipmaps+ putRgba8 (PixelRGBA8 r g b a) = putWord8 r >> putWord8 g >> putWord8 b >> putWord8 a+ putBlpExt = case blpExt of -- TODO: check sync of compression flag and BlpExt+ BlpJpeg{..} -> do+ putWord32le $ fromIntegral $ BS.length blpJpegHeader+ putByteString blpJpegHeader+ traverse_ putByteString $ take numMips blpJpegData+ BlpUncompressed1{..} -> do+ traverse_ putRgba8 . ensureLengthV 256 (PixelRGBA8 0 0 0 0) $ blpU1Palette+ traverse_ (\(indbs, alpbs) -> putByteString indbs >> putByteString alpbs) $ take numMips blpU1MipMaps+ BlpUncompressed2{..} -> do+ traverse_ putRgba8 . ensureLengthV 256 (PixelRGBA8 0 0 0 0) $ blpU2Palette+ traverse_ putByteString $ take numMips blpU2MipMaps++-- | Return 'True' if given picture format has alpha channel+hasAlpha :: DynamicImage -> Bool+hasAlpha img = case img of+ ImageYA8 _ -> True+ ImageYA16 _ -> True+ ImageRGBA8 _ -> True+ ImageRGBA16 _ -> True+ _ -> False++-- | Convert to BLP structure some image with given BLP options and quality (for JPEG compression)+toBlpStruct :: BlpCompression -> Int -> Int -> DynamicImage -> BlpStruct+toBlpStruct compression quality numMips img = BlpStruct {+ blpCompression = compression+ , blpFlags = if hasAlpha img+ then [BlpFlagAlphaChannel]+ else []+ , blpWidth = fromIntegral $ dynamicMap imageWidth img+ , blpHeight = fromIntegral $ dynamicMap imageHeight img+ , blpPictureType = pictype+ , blpPictureSubType = 5 -- world edit use this for war3mapMap.blp+ , blpExt = toBlpExt compression pictype quality numMips img'+ }+ where+ pictype = if hasAlpha img+ then UncompressedWithAlpha+ else UncompressedWithoutAlpha+ img' = convertRGBA8 img++-- | Take only first N mipmaps in list, fill rest with last non-fake mipmap+fakeMipMaps :: Int -- ^ How much true values to preserve (if <= 0, the function does nothing)+ -> [a] -- ^ List of mimpaps+ -> [a] -- ^ Result with fakes+fakeMipMaps = go Nothing+ where+ go mprev n xs+ | n <= 0 = case mprev of+ Nothing -> xs+ Just v -> case xs of+ [] -> []+ _ : xs' -> v : go (Just v) 0 xs'+ | otherwise = case xs of+ [] -> []+ x : xs' -> x : go (Just x) (n-1) xs'++-- | Scale image to form the sequence of mipmaps. The first element is always the original picture.+--+-- The scale procedure assumes that original image has power of 2 sides, that allows to simply pick+-- average of 4 pixels.+createMipMaps :: Image PixelRGBA8 -> [Image PixelRGBA8]+createMipMaps img = img : go img+ where+ avg' v1 v2 v3 v4 = let+ v = fromIntegral v1 + fromIntegral v2 + fromIntegral v3 + fromIntegral v4 :: Double+ in round $ v / 4+ avg i x y = let+ PixelRGBA8 p00r p00g p00b p00a = pixelAt i (x*2) (y*2)+ PixelRGBA8 p10r p10g p10b p10a = pixelAt i (x*2 + 1) (y*2)+ PixelRGBA8 p01r p01g p01b p01a = pixelAt i (x*2) (y*2 + 1)+ PixelRGBA8 p11r p11g p11b p11a = pixelAt i (x*2 + 1) (y*2 + 1)+ in PixelRGBA8 (avg' p00r p10r p01r p11r) (avg' p00g p10g p01g p11g) (avg' p00b p10b p01b p11b) (avg' p00a p10a p01a p11a)+ power2Scale i = generateImage (avg i) (downgrade $ imageWidth i) (downgrade $ imageHeight i)+ downgrade v = max 1 $ v `div` 2+ go i | imageWidth i <= 1 && imageHeight i <= 1 = []+ | otherwise = let i' = power2Scale i in i' : go i'++-- | Scale image to form the sequence of mipmaps. The first element is always the original picture.+--+-- The scale procedure assumes that original image has power of 2 sides, that allows to simply pick+-- 1 of 4 pixels.+createMipMapsIndexed :: Pixel a => Image a -> [Image a]+createMipMapsIndexed img = img : go img+ where+ power2Scale i = generateImage (\x y -> pixelAt i (x*2) (y*2)) (downgrade $ imageWidth i) (downgrade $ imageHeight i)+ downgrade v = max 1 $ v `div` 2+ go i | imageWidth i <= 1 && imageHeight i <= 1 = []+ | otherwise = let i' = power2Scale i in i' : go i'++-- | Convert picture to BLP payload+toBlpExt :: BlpCompression -> BlpPictureType -> Int -> Int -> Image PixelRGBA8 -> BlpExt+toBlpExt compr pictype quality numMips img = case compr of+ BlpCompressionJPEG -> toBlpJpg (fromIntegral quality) numMips hasAlpha img+ BlpCompressionUncompressed -> case pictype of+ UncompressedWithAlpha -> toBlpUncompressed1 numMips img+ UncompressedWithoutAlpha -> toBlpUncompressed2 numMips img+ JPEGType -> toBlpUncompressed2 numMips img -- Consider this as without alpha+ where+ hasAlpha = case pictype of+ UncompressedWithAlpha -> True+ _ -> False++-- | Convert picture to BLP JPEG and create mipmaps+toBlpJpg :: Word8 -> Int -> Bool -> Image PixelRGBA8 -> BlpExt+toBlpJpg quality numMips hasAlpha img = BlpJpeg {+ blpJpegHeader = header+ , blpJpegData = mipmapsRawWithoutHeader+ }+ where+ processAlpha :: Image PixelRGBA8 -> Image PixelRGBA8+ processAlpha = pixelMap $ \p@(PixelRGBA8 r g b a) -> if hasAlpha then p else PixelRGBA8 r g b 255++ mipmaps :: [Image PixelCMYK8]+ mipmaps = toBlpCMYK8 <$> (fakeMipMaps numMips . createMipMaps . processAlpha $ img)++ metadata :: CM.Metadatas+ metadata = CM.insert (CM.Unknown "JPEG Quality") (CM.Int $ fromIntegral quality) mempty++ mipmapsRaw :: [BS.ByteString]+ mipmapsRaw = toStrict . encodeDirectJpegAtQualityWithMetadata quality metadata <$> mipmaps++ header :: BS.ByteString+ header = scanHeader 624 mipmapsRaw++ mipmapsRawWithoutHeader :: [BS.ByteString]+ mipmapsRawWithoutHeader = BS.drop (BS.length header) <$> mipmapsRaw++-- | Manually scan shared prefix of each mipmap+scanHeader :: Int -> [BS.ByteString] -> BS.ByteString+scanHeader _ [] = mempty+scanHeader maxheader [x] = BS.take maxheader x+scanHeader maxheader mipmaps = go mipmaps mempty+ where+ go !mps !acc = let+ unconses = BS.uncons <$> mps :: [Maybe (Word8, BS.ByteString)]+ heads = fmap fst <$> unconses :: [Maybe Word8]+ tails = catMaybes $ fmap snd <$> unconses :: [BS.ByteString]+ hitEmpty = any isNothing heads+ firstByte = case heads of+ (Just v : _) -> v+ _ -> 0+ allEqual = all (Just firstByte ==) heads+ in if | hitEmpty -> acc+ | maxheader >= BS.length acc -> acc+ | allEqual -> go tails (acc `BS.snoc` firstByte)+ | otherwise -> acc++-- | Helper to quantise colors to 256 colour pallete+makePallette :: Image PixelRGBA8 -> (Image Pixel8, Palette)+makePallette = palettize defaultPaletteOptions . pixelMap dropTransparency++instance Storable PixelRGBA8 where+ sizeOf _ = sizeOf (undefined :: Word32)+ alignment _ = alignment (undefined :: Word32)+ peek ptr = unpackPixel <$> peek (castPtr ptr :: Ptr Word32)+ poke ptr px = poke (castPtr ptr :: Ptr Word32) . packPixel $ px++-- | Convert palette to format that we need for BLP+convertPalette :: Palette -> V.Vector PixelRGBA8+convertPalette = V.convert . VS.unsafeCast . imageData . pixelMap ((\(PixelRGBA8 r g b a) -> PixelRGBA8 b g r a) . promotePixel :: PixelRGB8 -> PixelRGBA8)++-- | Convert indexed image to raw bytestring+convertIndexed :: Image Pixel8 -> BS.ByteString+convertIndexed img = let+ (fptr, l) = VS.unsafeToForeignPtr0 . imageData $ img+ in unsafePerformIO $ withForeignPtr fptr $ \ptr -> BS.unsafePackCStringLen (castPtr ptr, l)++-- | Convert picture to BLP uncompressed with alpha and create mipmaps+toBlpUncompressed1 :: Int -> Image PixelRGBA8 -> BlpExt+toBlpUncompressed1 numMips img = BlpUncompressed1 {+ blpU1Palette = convertPalette palette+ , blpU1MipMaps = fmap convertIndexed mipmaps `zip` fmap convertIndexed alphaMaps+ }+ where+ img' :: Image Pixel8+ palette :: Palette+ (img', palette) = makePallette img++ alphaImg :: Image Pixel8+ alphaImg = extractComponent PlaneAlpha img++ mipmaps :: [Image Pixel8]+ mipmaps = fakeMipMaps numMips $ createMipMapsIndexed img'++ alphaMaps :: [Image Pixel8]+ alphaMaps = fakeMipMaps numMips $ createMipMapsIndexed alphaImg++-- | Convert picture to BLP uncompressed without alpha and create mipmaps+toBlpUncompressed2 :: Int -> Image PixelRGBA8 -> BlpExt+toBlpUncompressed2 numMips img = BlpUncompressed2 {+ blpU2Palette = convertPalette palette+ , blpU2MipMaps = convertIndexed <$> mipmaps+ }+ where+ img' :: Image Pixel8+ palette :: Palette+ (img', palette) = makePallette img++ mipmaps :: [Image Pixel8]+ mipmaps = fakeMipMaps numMips $ createMipMapsIndexed img'
+ src/Codec/Picture/Blp/Internal/Parser.hs view
@@ -0,0 +1,128 @@+module Codec.Picture.Blp.Internal.Parser(+ blpParser+ , blpVersion+ , dword+ , compressionParser+ , flagsParser+ , pictureTypeParser+ , blpJpegParser+ , getPos+ , skipToOffset+ , blpUncompressed1Parser+ , blpUncompressed2Parser+ , parseBlp+ ) where++import Codec.Picture+import Control.Monad+import Data.Attoparsec.ByteString as AT+import Data.Bits+import Data.ByteString (ByteString)+import Data.List (nub)+import Data.Word++import qualified Data.Vector as V+import qualified Data.Attoparsec.Internal.Types as AT+import qualified Data.ByteString as BS++import Codec.Picture.Blp.Internal.Data++blpParser :: Parser BlpStruct+blpParser = do+ _ <- blpVersion+ blpCompression <- compressionParser+ blpFlags <- flagsParser+ blpWidth <- dword <?> "width"+ blpHeight <- dword <?> "height"+ blpPictureType <- pictureTypeParser+ blpPictureSubType <- dword <?> "picture subtype"+ blpMipMapOffset <- replicateM 16 dword <?> "mipmaps offsets"+ blpMipMapSize <- replicateM 16 dword <?> "mipmaps sizes"+ let mipMapsInfo = nub . filter ((> 0) . snd) $ blpMipMapOffset `zip` blpMipMapSize+ blpExt <- case blpCompression of+ BlpCompressionJPEG -> blpJpegParser mipMapsInfo+ BlpCompressionUncompressed -> case blpPictureType of+ JPEGType -> fail "JPEG type with Uncompressed type mix"+ UncompressedWithAlpha -> blpUncompressed1Parser mipMapsInfo+ UncompressedWithoutAlpha -> blpUncompressed2Parser mipMapsInfo++ return $ BlpStruct {..}++blpVersion :: Parser ByteString+blpVersion = string "BLP1" <?> "BLP1 version tag"++dword :: Parser Word32+dword = do+ bs <- AT.take 4+ return . pack . BS.reverse $ bs+ where+ pack = BS.foldl' (\n h -> (n `shiftL` 8) .|. fromIntegral h) 0++rgba8 :: Parser PixelRGBA8+rgba8 = PixelRGBA8 <$> anyWord8 <*> anyWord8 <*> anyWord8 <*> anyWord8++compressionParser :: Parser BlpCompression+compressionParser = (<?> "compression") $ do+ i <- dword+ case i of+ 0 -> return BlpCompressionJPEG+ 1 -> return BlpCompressionUncompressed+ _ -> fail $ "Unknown compression " ++ show i++flagsParser :: Parser [BlpFlag]+flagsParser = (<?> "flags") $ do+ i <- dword+ return $ if i `testBit` 3+ then [BlpFlagAlphaChannel]+ else []++pictureTypeParser :: Parser BlpPictureType+pictureTypeParser = (<?> "picture type") $ do+ i <- dword+ case i of+ 2 -> return JPEGType+ 3 -> return UncompressedWithAlpha+ 4 -> return UncompressedWithAlpha+ 5 -> return UncompressedWithoutAlpha+ _ -> fail $ "Unknown picture type " ++ show i++blpJpegParser :: [(Word32, Word32)] -> Parser BlpExt+blpJpegParser mps = (<?> "blp jpeg") $ do+ headerSize <- dword <?> "jpeg header size"+ blpJpegHeader <- AT.take (fromIntegral headerSize) <?> "jpeg header"+ blpJpegData <- forM mps $ \(offset, size) -> do+ skipToOffset offset+ AT.take $ fromIntegral size+ return $ BlpJpeg {..}++getPos :: Parser Int+getPos = AT.Parser $ \t pos more _ succ' -> succ' t pos more (AT.fromPos pos)++skipToOffset :: Word32 -> Parser ()+skipToOffset i = do+ pos <- getPos+ let diff = fromIntegral i - pos+ if diff <= 0 then return ()+ else void $ AT.take diff++blpUncompressed1Parser :: [(Word32, Word32)] -> Parser BlpExt+blpUncompressed1Parser mps = do+ blpU1Palette <- V.replicateM 256 rgba8+ blpU1MipMaps <- forM mps $ \(offset, size) -> do+ skipToOffset offset+ let halfSize = fromIntegral size `div` 2+ indexList <- AT.take halfSize <?> "index list"+ alphaList <- AT.take halfSize <?> "alpha list"+ return (indexList, alphaList)+ return $ BlpUncompressed1 {..}++blpUncompressed2Parser :: [(Word32, Word32)] -> Parser BlpExt+blpUncompressed2Parser mps = do+ blpU2Palette <- V.replicateM 256 rgba8+ blpU2MipMaps <- forM mps $ \(offset, size) -> do+ skipToOffset offset+ AT.take (fromIntegral size) <?> "index list"+ return $ BlpUncompressed2 {..}++parseBlp :: ByteString -> Either String BlpStruct+parseBlp = parseOnly blpParser