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
readBlp :: FilePath -> IO (Either String DynamicImage)
readBlp fp = decodeBlp `fmap` BS.readFile fp
readBlpMipmaps :: FilePath -> IO (Either String [DynamicImage])
readBlpMipmaps fp = decodeBlpMipmaps `fmap` BS.readFile fp
decodeBlp :: ByteString -> Either String DynamicImage
decodeBlp bs = do
is <- decodeBlpMipmaps bs
if null is then Left "No data in BLP"
else return $ head is
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)
mipMapsUpTo :: Int
-> DynamicImage
-> 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 . toBlpStruct BlpCompressionJPEG quality numMips
encodeBlpUncompressedWithAlpha :: Int -> DynamicImage -> BSL.ByteString
encodeBlpUncompressedWithAlpha numMips = encodeBlp numMips . toBlpStruct BlpCompressionUncompressed 100 numMips
encodeBlpUncompressedWithoutAlpha :: Int -> DynamicImage -> BSL.ByteString
encodeBlpUncompressedWithoutAlpha numMips = encodeBlp numMips . toBlpStruct BlpCompressionUncompressed 100 numMips