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 :: 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

-- | Read BLP from given file with mipmaps
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

-- | Decodes BLP without mipmaps
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

-- | Decodes BLP and returns original image plus all mipmaps
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)

-- | 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 :: 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 {-. traceTextShowId-} (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 {-. traceTextShowId-} (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 {-. traceTextShowId-} (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