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 :: FilePath -> IO (Either FilePath DynamicImage)
readBlp fp :: FilePath
fp = ByteString -> Either FilePath DynamicImage
decodeBlp (ByteString -> Either FilePath DynamicImage)
-> IO ByteString -> IO (Either FilePath DynamicImage)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` FilePath -> IO ByteString
BS.readFile FilePath
fp
readBlpMipmaps :: FilePath -> IO (Either String [DynamicImage])
readBlpMipmaps :: FilePath -> IO (Either FilePath [DynamicImage])
readBlpMipmaps fp :: FilePath
fp = ByteString -> Either FilePath [DynamicImage]
decodeBlpMipmaps (ByteString -> Either FilePath [DynamicImage])
-> IO ByteString -> IO (Either FilePath [DynamicImage])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` FilePath -> IO ByteString
BS.readFile FilePath
fp
decodeBlp :: ByteString -> Either String DynamicImage
decodeBlp :: ByteString -> Either FilePath DynamicImage
decodeBlp bs :: ByteString
bs = do
[DynamicImage]
is <- ByteString -> Either FilePath [DynamicImage]
decodeBlpMipmaps ByteString
bs
if [DynamicImage] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [DynamicImage]
is then FilePath -> Either FilePath DynamicImage
forall a b. a -> Either a b
Left "No data in BLP"
else DynamicImage -> Either FilePath DynamicImage
forall (m :: * -> *) a. Monad m => a -> m a
return (DynamicImage -> Either FilePath DynamicImage)
-> DynamicImage -> Either FilePath DynamicImage
forall a b. (a -> b) -> a -> b
$ [DynamicImage] -> DynamicImage
forall a. [a] -> a
head [DynamicImage]
is
decodeBlpMipmaps :: ByteString -> Either String [DynamicImage]
decodeBlpMipmaps :: ByteString -> Either FilePath [DynamicImage]
decodeBlpMipmaps bs :: ByteString
bs = do
BlpStruct
blp <- ByteString -> Either FilePath BlpStruct
parseBlp ByteString
bs
case BlpStruct -> BlpExt
blpExt (BlpStruct -> BlpExt) -> BlpStruct -> BlpExt
forall a b. (a -> b) -> a -> b
$ BlpStruct -> BlpStruct
forall a. TextShow a => a -> a
traceTextShowId BlpStruct
blp of
BlpJpeg {..} -> do
let jpegs :: [ByteString]
jpegs = (ByteString
blpJpegHeader ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<>) (ByteString -> ByteString) -> [ByteString] -> [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` [ByteString]
blpJpegData
[DynamicImage]
mips <- (ByteString -> Either FilePath DynamicImage)
-> [ByteString] -> Either FilePath [DynamicImage]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ByteString -> Either FilePath DynamicImage
decodeJpeg [ByteString]
jpegs
[DynamicImage] -> Either FilePath [DynamicImage]
forall (m :: * -> *) a. Monad m => a -> m a
return ([DynamicImage] -> Either FilePath [DynamicImage])
-> [DynamicImage] -> Either FilePath [DynamicImage]
forall a b. (a -> b) -> a -> b
$ DynamicImage -> DynamicImage
toPngRepresentable (DynamicImage -> DynamicImage) -> [DynamicImage] -> [DynamicImage]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [DynamicImage]
mips
BlpUncompressed1 {..} -> do
let mkImage :: (ByteString, ByteString) -> DynamicImage
mkImage mip :: (ByteString, ByteString)
mip = Image PixelRGBA8 -> DynamicImage
ImageRGBA8 (Image PixelRGBA8 -> DynamicImage)
-> Image PixelRGBA8 -> DynamicImage
forall a b. (a -> b) -> a -> b
$ (Int -> Int -> PixelRGBA8) -> Int -> Int -> Image PixelRGBA8
forall px. Pixel px => (Int -> Int -> px) -> Int -> Int -> Image px
generateImage ((ByteString, ByteString) -> Int -> Int -> PixelRGBA8
gen (ByteString, ByteString)
mip) (Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Int) -> Word32 -> Int
forall a b. (a -> b) -> a -> b
$ BlpStruct -> Word32
blpWidth BlpStruct
blp) (Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Int) -> Word32 -> Int
forall a b. (a -> b) -> a -> b
$ BlpStruct -> Word32
blpHeight BlpStruct
blp)
[DynamicImage] -> Either FilePath [DynamicImage]
forall (m :: * -> *) a. Monad m => a -> m a
return ([DynamicImage] -> Either FilePath [DynamicImage])
-> [DynamicImage] -> Either FilePath [DynamicImage]
forall a b. (a -> b) -> a -> b
$ (ByteString, ByteString) -> DynamicImage
mkImage ((ByteString, ByteString) -> DynamicImage)
-> [(ByteString, ByteString)] -> [DynamicImage]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` [(ByteString, ByteString)]
blpU1MipMaps
where
palette :: Word8 -> PixelRGBA8
palette :: Word8 -> PixelRGBA8
palette i :: Word8
i = Vector PixelRGBA8
blpU1Palette Vector PixelRGBA8 -> Int -> PixelRGBA8
forall a. Vector a -> Int -> a
V.! Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
i
makeIndex :: a -> a -> a
makeIndex x :: a
x y :: a
y = a
ya -> a -> a
forall a. Num a => a -> a -> a
*(Word32 -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> a) -> Word32 -> a
forall a b. (a -> b) -> a -> b
$ BlpStruct -> Word32
blpWidth BlpStruct
blp)a -> a -> a
forall a. Num a => a -> a -> a
+a
x
takeColor :: (ByteString, b) -> Int -> Int -> PixelRGBA8
takeColor mip :: (ByteString, b)
mip x :: Int
x y :: Int
y = Word8 -> PixelRGBA8
palette (Word8 -> PixelRGBA8) -> Word8 -> PixelRGBA8
forall a b. (a -> b) -> a -> b
$ (ByteString, b) -> ByteString
forall a b. (a, b) -> a
fst (ByteString, b)
mip ByteString -> Int -> Word8
`BS.index` Int -> Int -> Int
forall a. Num a => a -> a -> a
makeIndex Int
x Int
y
takeAlpha :: (a, ByteString) -> Int -> Int -> Word8
takeAlpha mip :: (a, ByteString)
mip x :: Int
x y :: Int
y = (a, ByteString) -> ByteString
forall a b. (a, b) -> b
snd (a, ByteString)
mip ByteString -> Int -> Word8
`BS.index` Int -> Int -> Int
forall a. Num a => a -> a -> a
makeIndex Int
x Int
y
gen :: (ByteString, ByteString) -> Int -> Int -> PixelRGBA8
gen mip :: (ByteString, ByteString)
mip x :: Int
x y :: Int
y = let
PixelRGBA8 r :: Word8
r g :: Word8
g b :: Word8
b _ = (ByteString, ByteString) -> Int -> Int -> PixelRGBA8
forall b. (ByteString, b) -> Int -> Int -> PixelRGBA8
takeColor (ByteString, ByteString)
mip Int
x Int
y
a :: Word8
a = (ByteString, ByteString) -> Int -> Int -> Word8
forall a. (a, ByteString) -> Int -> Int -> Word8
takeAlpha (ByteString, ByteString)
mip Int
x Int
y
in Word8 -> Word8 -> Word8 -> Word8 -> PixelRGBA8
PixelRGBA8 Word8
b Word8
g Word8
r Word8
a
BlpUncompressed2 {..} -> do
let mkImage :: ByteString -> DynamicImage
mkImage mip :: ByteString
mip = Image PixelRGBA8 -> DynamicImage
ImageRGBA8 (Image PixelRGBA8 -> DynamicImage)
-> Image PixelRGBA8 -> DynamicImage
forall a b. (a -> b) -> a -> b
$ (Int -> Int -> PixelRGBA8) -> Int -> Int -> Image PixelRGBA8
forall px. Pixel px => (Int -> Int -> px) -> Int -> Int -> Image px
generateImage (ByteString -> Int -> Int -> PixelRGBA8
gen ByteString
mip) (Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Int) -> Word32 -> Int
forall a b. (a -> b) -> a -> b
$ BlpStruct -> Word32
blpWidth BlpStruct
blp) (Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Int) -> Word32 -> Int
forall a b. (a -> b) -> a -> b
$ BlpStruct -> Word32
blpHeight BlpStruct
blp)
[DynamicImage] -> Either FilePath [DynamicImage]
forall (m :: * -> *) a. Monad m => a -> m a
return ([DynamicImage] -> Either FilePath [DynamicImage])
-> [DynamicImage] -> Either FilePath [DynamicImage]
forall a b. (a -> b) -> a -> b
$ ByteString -> DynamicImage
mkImage (ByteString -> DynamicImage) -> [ByteString] -> [DynamicImage]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` [ByteString]
blpU2MipMaps
where
palette :: Word8 -> PixelRGBA8
palette :: Word8 -> PixelRGBA8
palette i :: Word8
i = Vector PixelRGBA8
blpU2Palette Vector PixelRGBA8 -> Int -> PixelRGBA8
forall a. Vector a -> Int -> a
V.! Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
i
makeIndex :: a -> a -> a
makeIndex x :: a
x y :: a
y = a
ya -> a -> a
forall a. Num a => a -> a -> a
*(Word32 -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> a) -> Word32 -> a
forall a b. (a -> b) -> a -> b
$ BlpStruct -> Word32
blpWidth BlpStruct
blp)a -> a -> a
forall a. Num a => a -> a -> a
+a
x
takeColor :: ByteString -> Int -> Int -> PixelRGBA8
takeColor mip :: ByteString
mip x :: Int
x y :: Int
y = Word8 -> PixelRGBA8
palette (Word8 -> PixelRGBA8) -> Word8 -> PixelRGBA8
forall a b. (a -> b) -> a -> b
$ ByteString
mip ByteString -> Int -> Word8
`BS.index` Int -> Int -> Int
forall a. Num a => a -> a -> a
makeIndex Int
x Int
y
gen :: ByteString -> Int -> Int -> PixelRGBA8
gen mip :: ByteString
mip x :: Int
x y :: Int
y = let
PixelRGBA8 r :: Word8
r g :: Word8
g b :: Word8
b a :: Word8
a = ByteString -> Int -> Int -> PixelRGBA8
takeColor ByteString
mip Int
x Int
y
in Word8 -> Word8 -> Word8 -> Word8 -> PixelRGBA8
PixelRGBA8 Word8
b Word8
g Word8
r (255 Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
- Word8
a)
mipMapsUpTo :: Int
-> DynamicImage
-> Int
mipMapsUpTo :: Int -> DynamicImage -> Int
mipMapsUpTo minSize :: Int
minSize img :: DynamicImage
img = Int
maxNum Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
minSizeNum
where
w :: Int
w = (forall pixel. Pixel pixel => Image pixel -> Int)
-> DynamicImage -> Int
forall a.
(forall pixel. Pixel pixel => Image pixel -> a)
-> DynamicImage -> a
dynamicMap forall a. Image a -> Int
forall pixel. Pixel pixel => Image pixel -> Int
imageWidth DynamicImage
img
h :: Int
h = (forall pixel. Pixel pixel => Image pixel -> Int)
-> DynamicImage -> Int
forall a.
(forall pixel. Pixel pixel => Image pixel -> a)
-> DynamicImage -> a
dynamicMap forall a. Image a -> Int
forall pixel. Pixel pixel => Image pixel -> Int
imageHeight DynamicImage
img
minSide :: Int
minSide = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
w Int
h
maxNum :: Int
maxNum = Double -> Int
forall a b. (RealFrac a, Integral b) => a -> b
ceiling (Double -> Int) -> Double -> Int
forall a b. (a -> b) -> a -> b
$ Double -> Double -> Double
forall a. Floating a => a -> a -> a
logBase 2 (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
minSide)
minSizeNum :: Int
minSizeNum = Double -> Int
forall a b. (RealFrac a, Integral b) => a -> b
floor (Double -> Int) -> Double -> Int
forall a b. (a -> b) -> a -> b
$ Double -> Double -> Double
forall a. Floating a => a -> a -> a
logBase 2 (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max 1 Int
minSize))
writeBlpJpeg :: FilePath -> Int -> Int -> DynamicImage -> IO ()
writeBlpJpeg :: FilePath -> Int -> Int -> DynamicImage -> IO ()
writeBlpJpeg fp :: FilePath
fp quality :: Int
quality numMips :: Int
numMips img :: DynamicImage
img = do
let bs :: ByteString
bs = Int -> Int -> DynamicImage -> ByteString
encodeBlpJpeg Int
quality Int
numMips DynamicImage
img
FilePath -> ByteString -> IO ()
BSL.writeFile FilePath
fp ByteString
bs
writeBlpUncompressedWithAlpha :: FilePath -> Int -> DynamicImage -> IO ()
writeBlpUncompressedWithAlpha :: FilePath -> Int -> DynamicImage -> IO ()
writeBlpUncompressedWithAlpha fp :: FilePath
fp numMips :: Int
numMips img :: DynamicImage
img = do
let bs :: ByteString
bs = Int -> DynamicImage -> ByteString
encodeBlpUncompressedWithAlpha Int
numMips DynamicImage
img
FilePath -> ByteString -> IO ()
BSL.writeFile FilePath
fp ByteString
bs
writeBlpUncompressedWithoutAlpha :: FilePath -> Int -> DynamicImage -> IO ()
writeBlpUncompressedWithoutAlpha :: FilePath -> Int -> DynamicImage -> IO ()
writeBlpUncompressedWithoutAlpha fp :: FilePath
fp numMips :: Int
numMips img :: DynamicImage
img = do
let bs :: ByteString
bs = Int -> DynamicImage -> ByteString
encodeBlpUncompressedWithoutAlpha Int
numMips DynamicImage
img
FilePath -> ByteString -> IO ()
BSL.writeFile FilePath
fp ByteString
bs
encodeBlpJpeg :: Int -> Int -> DynamicImage -> BSL.ByteString
encodeBlpJpeg :: Int -> Int -> DynamicImage -> ByteString
encodeBlpJpeg quality :: Int
quality numMips :: Int
numMips = Int -> BlpStruct -> ByteString
encodeBlp Int
numMips (BlpStruct -> ByteString)
-> (DynamicImage -> BlpStruct) -> DynamicImage -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlpCompression -> Int -> Int -> DynamicImage -> BlpStruct
toBlpStruct BlpCompression
BlpCompressionJPEG Int
quality Int
numMips
encodeBlpUncompressedWithAlpha :: Int -> DynamicImage -> BSL.ByteString
encodeBlpUncompressedWithAlpha :: Int -> DynamicImage -> ByteString
encodeBlpUncompressedWithAlpha numMips :: Int
numMips = Int -> BlpStruct -> ByteString
encodeBlp Int
numMips (BlpStruct -> ByteString)
-> (DynamicImage -> BlpStruct) -> DynamicImage -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlpCompression -> Int -> Int -> DynamicImage -> BlpStruct
toBlpStruct BlpCompression
BlpCompressionUncompressed 100 Int
numMips
encodeBlpUncompressedWithoutAlpha :: Int -> DynamicImage -> BSL.ByteString
encodeBlpUncompressedWithoutAlpha :: Int -> DynamicImage -> ByteString
encodeBlpUncompressedWithoutAlpha numMips :: Int
numMips = Int -> BlpStruct -> ByteString
encodeBlp Int
numMips (BlpStruct -> ByteString)
-> (DynamicImage -> BlpStruct) -> DynamicImage -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlpCompression -> Int -> Int -> DynamicImage -> BlpStruct
toBlpStruct BlpCompression
BlpCompressionUncompressed 100 Int
numMips