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 :: Int -> BlpStruct -> ByteString
encodeBlp numMips :: Int
numMips = Put -> ByteString
runPut (Put -> ByteString)
-> (BlpStruct -> Put) -> BlpStruct -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> BlpStruct -> Put
blpEncoder Int
numMips

-- | Raw encoder for BLP
blpEncoder :: Int -> BlpStruct -> Put
blpEncoder :: Int -> BlpStruct -> Put
blpEncoder numMips :: Int
numMips BlpStruct{..} = do
  Put
putBlpVersion
  Put
putCompression
  Put
putFlags
  Put
putWidth
  Put
putHeight
  Put
putPictureType
  Put
putPictureSubType
  Put
putMipMapOffsets
  Put
putMipMapSizes
  Put
putBlpExt
  where
    putBlpVersion :: Put
putBlpVersion = ByteString -> Put
putByteString "BLP1"
    putCompression :: Put
putCompression = Word32 -> Put
putWord32le (Word32 -> Put) -> Word32 -> Put
forall a b. (a -> b) -> a -> b
$ case BlpCompression
blpCompression of
      BlpCompressionJPEG -> 0
      BlpCompressionUncompressed -> 1
    putFlags :: Put
putFlags = let
      addFlag :: a -> BlpFlag -> a
addFlag acc :: a
acc flag :: BlpFlag
flag = (a
acc a -> a -> a
forall a. Num a => a -> a -> a
+) (a -> a) -> a -> a
forall a b. (a -> b) -> a -> b
$ case BlpFlag
flag of
         BlpFlagAlphaChannel -> 1 a -> Int -> a
forall a. Bits a => a -> Int -> a
`shiftL` 3
      in Word32 -> Put
putWord32le (Word32 -> Put) -> Word32 -> Put
forall a b. (a -> b) -> a -> b
$ (Word32 -> BlpFlag -> Word32) -> Word32 -> [BlpFlag] -> Word32
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
F.foldl' Word32 -> BlpFlag -> Word32
forall a. (Num a, Bits a) => a -> BlpFlag -> a
addFlag 0 [BlpFlag]
blpFlags
    putWidth :: Put
putWidth = Word32 -> Put
putWord32le Word32
blpWidth
    putHeight :: Put
putHeight = Word32 -> Put
putWord32le Word32
blpHeight
    putPictureType :: Put
putPictureType = Word32 -> Put
putWord32le (Word32 -> Put) -> Word32 -> Put
forall a b. (a -> b) -> a -> b
$ case BlpPictureType
blpPictureType of
      JPEGType -> 2
      UncompressedWithAlpha -> 3
      -- UncompressedWithAlpha -> 4
      UncompressedWithoutAlpha -> 5
    putPictureSubType :: Put
putPictureSubType = Word32 -> Put
putWord32le Word32
blpPictureSubType
    headerSize :: Int
headerSize = 4 -- BLP1
      Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 4 -- Compression
      Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 4 -- Flags
      Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 4 -- Width
      Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 4 -- Height
      Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 4 -- Picture type
      Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 4 -- Picture subtype
      Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 16 Int -> Int -> Int
forall a. Num a => a -> a -> a
* 4 -- Mipmaps offsets
      Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 16 Int -> Int -> Int
forall a. Num a => a -> a -> a
* 4 -- Mipmaps sizes
    mipmaps :: [(Word32, Word32)]
mipmaps = let
      mkOffsetSize :: BS.ByteString -> (Int, [(Word32, Word32)]) ->  (Int, [(Word32, Word32)])
      mkOffsetSize :: ByteString
-> (Int, [(Word32, Word32)]) -> (Int, [(Word32, Word32)])
mkOffsetSize bs :: ByteString
bs (!Int
offset, ![(Word32, Word32)]
acc) = (Int
offset Int -> Int -> Int
forall a. Num a => a -> a -> a
+ ByteString -> Int
BS.length ByteString
bs, (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
offset, Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word32) -> Int -> Word32
forall a b. (a -> b) -> a -> b
$ ByteString -> Int
BS.length ByteString
bs) (Word32, Word32) -> [(Word32, Word32)] -> [(Word32, Word32)]
forall a. a -> [a] -> [a]
: [(Word32, Word32)]
acc)
      uncomprStartOffset :: Int
uncomprStartOffset = Int
headerSize Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 4 Int -> Int -> Int
forall a. Num a => a -> a -> a
* 256
      in [(Word32, Word32)] -> [(Word32, Word32)]
forall a. [a] -> [a]
reverse ([(Word32, Word32)] -> [(Word32, Word32)])
-> ((Int, [(Word32, Word32)]) -> [(Word32, Word32)])
-> (Int, [(Word32, Word32)])
-> [(Word32, Word32)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, [(Word32, Word32)]) -> [(Word32, Word32)]
forall a b. (a, b) -> b
snd ((Int, [(Word32, Word32)]) -> [(Word32, Word32)])
-> (Int, [(Word32, Word32)]) -> [(Word32, Word32)]
forall a b. (a -> b) -> a -> b
$ case BlpExt
blpExt of
        BlpJpeg{..} -> let
          startOffset :: Int
startOffset = Int
headerSize Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 4 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ ByteString -> Int
BS.length ByteString
blpJpegHeader
          in (ByteString
 -> (Int, [(Word32, Word32)]) -> (Int, [(Word32, Word32)]))
-> (Int, [(Word32, Word32)])
-> [ByteString]
-> (Int, [(Word32, Word32)])
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
F.foldr' ByteString
-> (Int, [(Word32, Word32)]) -> (Int, [(Word32, Word32)])
mkOffsetSize (Int
startOffset, []) ([ByteString] -> (Int, [(Word32, Word32)]))
-> [ByteString] -> (Int, [(Word32, Word32)])
forall a b. (a -> b) -> a -> b
$ [ByteString] -> [ByteString]
forall a. [a] -> [a]
reverse [ByteString]
blpJpegData
        BlpUncompressed1{..} -> let
          mkOffsetSizeU :: (ByteString, ByteString) -> (Int, [(a, b)]) -> (Int, [(a, b)])
mkOffsetSizeU (indbs :: ByteString
indbs, alpbs :: ByteString
alpbs) (!Int
offset, ![(a, b)]
acc) = (Int
offset Int -> Int -> Int
forall a. Num a => a -> a -> a
+ ByteString -> Int
BS.length ByteString
indbs Int -> Int -> Int
forall a. Num a => a -> a -> a
+ ByteString -> Int
BS.length ByteString
alpbs, (Int -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
offset, Int -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> b) -> Int -> b
forall a b. (a -> b) -> a -> b
$ ByteString -> Int
BS.length ByteString
indbs Int -> Int -> Int
forall a. Num a => a -> a -> a
+ ByteString -> Int
BS.length ByteString
alpbs) (a, b) -> [(a, b)] -> [(a, b)]
forall a. a -> [a] -> [a]
: [(a, b)]
acc)
          in ((ByteString, ByteString)
 -> (Int, [(Word32, Word32)]) -> (Int, [(Word32, Word32)]))
-> (Int, [(Word32, Word32)])
-> [(ByteString, ByteString)]
-> (Int, [(Word32, Word32)])
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
F.foldr' (ByteString, ByteString)
-> (Int, [(Word32, Word32)]) -> (Int, [(Word32, Word32)])
forall a b.
(Num a, Num b) =>
(ByteString, ByteString) -> (Int, [(a, b)]) -> (Int, [(a, b)])
mkOffsetSizeU (Int
uncomprStartOffset, []) ([(ByteString, ByteString)] -> (Int, [(Word32, Word32)]))
-> [(ByteString, ByteString)] -> (Int, [(Word32, Word32)])
forall a b. (a -> b) -> a -> b
$ [(ByteString, ByteString)] -> [(ByteString, ByteString)]
forall a. [a] -> [a]
reverse [(ByteString, ByteString)]
blpU1MipMaps
        BlpUncompressed2{..} -> (ByteString
 -> (Int, [(Word32, Word32)]) -> (Int, [(Word32, Word32)]))
-> (Int, [(Word32, Word32)])
-> [ByteString]
-> (Int, [(Word32, Word32)])
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
F.foldr' ByteString
-> (Int, [(Word32, Word32)]) -> (Int, [(Word32, Word32)])
mkOffsetSize (Int
uncomprStartOffset, []) ([ByteString] -> (Int, [(Word32, Word32)]))
-> [ByteString] -> (Int, [(Word32, Word32)])
forall a b. (a -> b) -> a -> b
$ [ByteString] -> [ByteString]
forall a. [a] -> [a]
reverse [ByteString]
blpU2MipMaps
    ensureLength :: Int -> [a] -> [a]
ensureLength _ [] = []
    ensureLength n :: Int
n xs :: [a]
xs = if [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
n
      then [a]
xs [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ Int -> a -> [a]
forall a. Int -> a -> [a]
replicate (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs) ([a] -> a
forall a. [a] -> a
last [a]
xs)
      else Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take Int
n [a]
xs
    ensureLengthV :: Int -> a -> Vector a -> Vector a
ensureLengthV n :: Int
n a :: a
a xs :: Vector a
xs = if Vector a -> Int
forall a. Vector a -> Int
V.length Vector a
xs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
n then Vector a
xs Vector a -> Vector a -> Vector a
forall a. Semigroup a => a -> a -> a
<> Int -> a -> Vector a
forall a. Int -> a -> Vector a
V.replicate (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Vector a -> Int
forall a. Vector a -> Int
V.length Vector a
xs) a
a else Int -> Vector a -> Vector a
forall a. Int -> Vector a -> Vector a
V.take Int
n Vector a
xs
    putMipMapOffsets :: Put
putMipMapOffsets = (Word32 -> Put) -> [Word32] -> Put
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ Word32 -> Put
putWord32le ([Word32] -> Put)
-> ([(Word32, Word32)] -> [Word32]) -> [(Word32, Word32)] -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Word32] -> [Word32]
forall a. Int -> [a] -> [a]
ensureLength 16 ([Word32] -> [Word32])
-> ([(Word32, Word32)] -> [Word32])
-> [(Word32, Word32)]
-> [Word32]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Word32] -> [Word32]
forall a. Int -> [a] -> [a]
take Int
numMips ([Word32] -> [Word32])
-> ([(Word32, Word32)] -> [Word32])
-> [(Word32, Word32)]
-> [Word32]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Word32, Word32) -> Word32) -> [(Word32, Word32)] -> [Word32]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Word32, Word32) -> Word32
forall a b. (a, b) -> a
fst ([(Word32, Word32)] -> Put) -> [(Word32, Word32)] -> Put
forall a b. (a -> b) -> a -> b
$ [(Word32, Word32)]
mipmaps
    putMipMapSizes :: Put
putMipMapSizes = (Word32 -> Put) -> [Word32] -> Put
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ Word32 -> Put
putWord32le ([Word32] -> Put)
-> ([(Word32, Word32)] -> [Word32]) -> [(Word32, Word32)] -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Word32] -> [Word32]
forall a. Int -> [a] -> [a]
ensureLength 16 ([Word32] -> [Word32])
-> ([(Word32, Word32)] -> [Word32])
-> [(Word32, Word32)]
-> [Word32]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Word32] -> [Word32]
forall a. Int -> [a] -> [a]
take Int
numMips ([Word32] -> [Word32])
-> ([(Word32, Word32)] -> [Word32])
-> [(Word32, Word32)]
-> [Word32]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Word32, Word32) -> Word32) -> [(Word32, Word32)] -> [Word32]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Word32, Word32) -> Word32
forall a b. (a, b) -> b
snd ([(Word32, Word32)] -> Put) -> [(Word32, Word32)] -> Put
forall a b. (a -> b) -> a -> b
$ [(Word32, Word32)]
mipmaps
    putRgba8 :: PixelRGBA8 -> Put
putRgba8 (PixelRGBA8 r :: Pixel8
r g :: Pixel8
g b :: Pixel8
b a :: Pixel8
a) = Pixel8 -> Put
putWord8 Pixel8
r Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Pixel8 -> Put
putWord8 Pixel8
g Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Pixel8 -> Put
putWord8 Pixel8
b Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Pixel8 -> Put
putWord8 Pixel8
a
    putBlpExt :: Put
putBlpExt = case BlpExt
blpExt of -- TODO: check sync of compression flag and BlpExt
       BlpJpeg{..} -> do
         Word32 -> Put
putWord32le (Word32 -> Put) -> Word32 -> Put
forall a b. (a -> b) -> a -> b
$ Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word32) -> Int -> Word32
forall a b. (a -> b) -> a -> b
$ ByteString -> Int
BS.length ByteString
blpJpegHeader
         ByteString -> Put
putByteString ByteString
blpJpegHeader
         (ByteString -> Put) -> [ByteString] -> Put
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ ByteString -> Put
putByteString ([ByteString] -> Put) -> [ByteString] -> Put
forall a b. (a -> b) -> a -> b
$ Int -> [ByteString] -> [ByteString]
forall a. Int -> [a] -> [a]
take Int
numMips [ByteString]
blpJpegData
       BlpUncompressed1{..} -> do
         (PixelRGBA8 -> Put) -> Vector PixelRGBA8 -> Put
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ PixelRGBA8 -> Put
putRgba8 (Vector PixelRGBA8 -> Put)
-> (Vector PixelRGBA8 -> Vector PixelRGBA8)
-> Vector PixelRGBA8
-> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> PixelRGBA8 -> Vector PixelRGBA8 -> Vector PixelRGBA8
forall a. Int -> a -> Vector a -> Vector a
ensureLengthV 256 (Pixel8 -> Pixel8 -> Pixel8 -> Pixel8 -> PixelRGBA8
PixelRGBA8 0 0 0 0) (Vector PixelRGBA8 -> Put) -> Vector PixelRGBA8 -> Put
forall a b. (a -> b) -> a -> b
$ Vector PixelRGBA8
blpU1Palette
         ((ByteString, ByteString) -> Put)
-> [(ByteString, ByteString)] -> Put
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (\(indbs :: ByteString
indbs, alpbs :: ByteString
alpbs) -> ByteString -> Put
putByteString ByteString
indbs Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ByteString -> Put
putByteString ByteString
alpbs) ([(ByteString, ByteString)] -> Put)
-> [(ByteString, ByteString)] -> Put
forall a b. (a -> b) -> a -> b
$ Int -> [(ByteString, ByteString)] -> [(ByteString, ByteString)]
forall a. Int -> [a] -> [a]
take Int
numMips [(ByteString, ByteString)]
blpU1MipMaps
       BlpUncompressed2{..} -> do
         (PixelRGBA8 -> Put) -> Vector PixelRGBA8 -> Put
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ PixelRGBA8 -> Put
putRgba8 (Vector PixelRGBA8 -> Put)
-> (Vector PixelRGBA8 -> Vector PixelRGBA8)
-> Vector PixelRGBA8
-> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> PixelRGBA8 -> Vector PixelRGBA8 -> Vector PixelRGBA8
forall a. Int -> a -> Vector a -> Vector a
ensureLengthV 256 (Pixel8 -> Pixel8 -> Pixel8 -> Pixel8 -> PixelRGBA8
PixelRGBA8 0 0 0 0) (Vector PixelRGBA8 -> Put) -> Vector PixelRGBA8 -> Put
forall a b. (a -> b) -> a -> b
$ Vector PixelRGBA8
blpU2Palette
         (ByteString -> Put) -> [ByteString] -> Put
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ ByteString -> Put
putByteString ([ByteString] -> Put) -> [ByteString] -> Put
forall a b. (a -> b) -> a -> b
$ Int -> [ByteString] -> [ByteString]
forall a. Int -> [a] -> [a]
take Int
numMips [ByteString]
blpU2MipMaps

-- | Return 'True' if given picture format has alpha channel
hasAlpha :: DynamicImage -> Bool
hasAlpha :: DynamicImage -> Bool
hasAlpha img :: DynamicImage
img = case DynamicImage
img of
  ImageYA8 _ -> Bool
True
  ImageYA16 _ -> Bool
True
  ImageRGBA8 _ -> Bool
True
  ImageRGBA16 _ -> Bool
True
  _ -> Bool
False

-- | Convert to BLP structure some image with given BLP options and quality (for JPEG compression)
toBlpStruct :: BlpCompression -> Int -> Int -> DynamicImage -> BlpStruct
toBlpStruct :: BlpCompression -> Int -> Int -> DynamicImage -> BlpStruct
toBlpStruct compression :: BlpCompression
compression quality :: Int
quality numMips :: Int
numMips img :: DynamicImage
img = $WBlpStruct :: BlpCompression
-> [BlpFlag]
-> Word32
-> Word32
-> BlpPictureType
-> Word32
-> BlpExt
-> BlpStruct
BlpStruct {
    blpCompression :: BlpCompression
blpCompression = BlpCompression
compression
  , blpFlags :: [BlpFlag]
blpFlags = if DynamicImage -> Bool
hasAlpha DynamicImage
img
      then [BlpFlag
BlpFlagAlphaChannel]
      else []
  , blpWidth :: Word32
blpWidth = Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word32) -> Int -> Word32
forall a b. (a -> b) -> a -> b
$ (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
  , blpHeight :: Word32
blpHeight = Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word32) -> Int -> Word32
forall a b. (a -> b) -> a -> b
$ (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
  , blpPictureType :: BlpPictureType
blpPictureType = BlpPictureType
pictype
  , blpPictureSubType :: Word32
blpPictureSubType = 5 -- world edit use this for war3mapMap.blp
  , blpExt :: BlpExt
blpExt = BlpCompression
-> BlpPictureType -> Int -> Int -> Image PixelRGBA8 -> BlpExt
toBlpExt BlpCompression
compression BlpPictureType
pictype Int
quality Int
numMips Image PixelRGBA8
img'
  }
  where
    pictype :: BlpPictureType
pictype = if DynamicImage -> Bool
hasAlpha DynamicImage
img
      then BlpPictureType
UncompressedWithAlpha
      else BlpPictureType
UncompressedWithoutAlpha
    img' :: Image PixelRGBA8
img' = DynamicImage -> Image PixelRGBA8
convertRGBA8 DynamicImage
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 :: Int -> [a] -> [a]
fakeMipMaps = Maybe a -> Int -> [a] -> [a]
forall t a. (Ord t, Num t) => Maybe a -> t -> [a] -> [a]
go Maybe a
forall a. Maybe a
Nothing
  where
    go :: Maybe a -> t -> [a] -> [a]
go mprev :: Maybe a
mprev n :: t
n xs :: [a]
xs
      | t
n t -> t -> Bool
forall a. Ord a => a -> a -> Bool
<= 0 = case Maybe a
mprev of
        Nothing -> [a]
xs
        Just v :: a
v -> case [a]
xs of
          [] -> []
          _ : xs' :: [a]
xs' -> a
v a -> [a] -> [a]
forall a. a -> [a] -> [a]
: Maybe a -> t -> [a] -> [a]
go (a -> Maybe a
forall a. a -> Maybe a
Just a
v) 0 [a]
xs'
      | Bool
otherwise = case [a]
xs of
        [] -> []
        x :: a
x : xs' :: [a]
xs' -> a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: Maybe a -> t -> [a] -> [a]
go (a -> Maybe a
forall a. a -> Maybe a
Just a
x) (t
nt -> t -> t
forall a. Num a => a -> a -> a
-1) [a]
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 :: Image PixelRGBA8 -> [Image PixelRGBA8]
createMipMaps img :: Image PixelRGBA8
img = Image PixelRGBA8
img Image PixelRGBA8 -> [Image PixelRGBA8] -> [Image PixelRGBA8]
forall a. a -> [a] -> [a]
: Image PixelRGBA8 -> [Image PixelRGBA8]
go Image PixelRGBA8
img
  where
    avg' :: a -> a -> a -> a -> b
avg' v1 :: a
v1 v2 :: a
v2 v3 :: a
v3 v4 :: a
v4 = let
      v :: Double
v = a -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
v1 Double -> Double -> Double
forall a. Num a => a -> a -> a
+ a -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
v2 Double -> Double -> Double
forall a. Num a => a -> a -> a
+ a -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
v3 Double -> Double -> Double
forall a. Num a => a -> a -> a
+ a -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
v4 :: Double
      in Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (Double -> b) -> Double -> b
forall a b. (a -> b) -> a -> b
$ Double
v Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ 4
    avg :: Image PixelRGBA8 -> Int -> Int -> PixelRGBA8
avg i :: Image PixelRGBA8
i x :: Int
x y :: Int
y = let
      PixelRGBA8 p00r :: Pixel8
p00r p00g :: Pixel8
p00g p00b :: Pixel8
p00b p00a :: Pixel8
p00a = Image PixelRGBA8 -> Int -> Int -> PixelRGBA8
forall a. Pixel a => Image a -> Int -> Int -> a
pixelAt Image PixelRGBA8
i (Int
xInt -> Int -> Int
forall a. Num a => a -> a -> a
*2) (Int
yInt -> Int -> Int
forall a. Num a => a -> a -> a
*2)
      PixelRGBA8 p10r :: Pixel8
p10r p10g :: Pixel8
p10g p10b :: Pixel8
p10b p10a :: Pixel8
p10a = Image PixelRGBA8 -> Int -> Int -> PixelRGBA8
forall a. Pixel a => Image a -> Int -> Int -> a
pixelAt Image PixelRGBA8
i (Int
xInt -> Int -> Int
forall a. Num a => a -> a -> a
*2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) (Int
yInt -> Int -> Int
forall a. Num a => a -> a -> a
*2)
      PixelRGBA8 p01r :: Pixel8
p01r p01g :: Pixel8
p01g p01b :: Pixel8
p01b p01a :: Pixel8
p01a = Image PixelRGBA8 -> Int -> Int -> PixelRGBA8
forall a. Pixel a => Image a -> Int -> Int -> a
pixelAt Image PixelRGBA8
i (Int
xInt -> Int -> Int
forall a. Num a => a -> a -> a
*2) (Int
yInt -> Int -> Int
forall a. Num a => a -> a -> a
*2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1)
      PixelRGBA8 p11r :: Pixel8
p11r p11g :: Pixel8
p11g p11b :: Pixel8
p11b p11a :: Pixel8
p11a = Image PixelRGBA8 -> Int -> Int -> PixelRGBA8
forall a. Pixel a => Image a -> Int -> Int -> a
pixelAt Image PixelRGBA8
i (Int
xInt -> Int -> Int
forall a. Num a => a -> a -> a
*2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) (Int
yInt -> Int -> Int
forall a. Num a => a -> a -> a
*2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1)
      in Pixel8 -> Pixel8 -> Pixel8 -> Pixel8 -> PixelRGBA8
PixelRGBA8 (Pixel8 -> Pixel8 -> Pixel8 -> Pixel8 -> Pixel8
forall b a a a a.
(Integral b, Integral a, Integral a, Integral a, Integral a) =>
a -> a -> a -> a -> b
avg' Pixel8
p00r Pixel8
p10r Pixel8
p01r Pixel8
p11r) (Pixel8 -> Pixel8 -> Pixel8 -> Pixel8 -> Pixel8
forall b a a a a.
(Integral b, Integral a, Integral a, Integral a, Integral a) =>
a -> a -> a -> a -> b
avg' Pixel8
p00g Pixel8
p10g Pixel8
p01g Pixel8
p11g) (Pixel8 -> Pixel8 -> Pixel8 -> Pixel8 -> Pixel8
forall b a a a a.
(Integral b, Integral a, Integral a, Integral a, Integral a) =>
a -> a -> a -> a -> b
avg' Pixel8
p00b Pixel8
p10b Pixel8
p01b Pixel8
p11b) (Pixel8 -> Pixel8 -> Pixel8 -> Pixel8 -> Pixel8
forall b a a a a.
(Integral b, Integral a, Integral a, Integral a, Integral a) =>
a -> a -> a -> a -> b
avg' Pixel8
p00a Pixel8
p10a Pixel8
p01a Pixel8
p11a)
    power2Scale :: Image PixelRGBA8 -> Image PixelRGBA8
power2Scale i :: Image PixelRGBA8
i = (Int -> Int -> PixelRGBA8) -> Int -> Int -> Image PixelRGBA8
forall px. Pixel px => (Int -> Int -> px) -> Int -> Int -> Image px
generateImage (Image PixelRGBA8 -> Int -> Int -> PixelRGBA8
avg Image PixelRGBA8
i) (Int -> Int
forall a. Integral a => a -> a
downgrade (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Image PixelRGBA8 -> Int
forall a. Image a -> Int
imageWidth Image PixelRGBA8
i) (Int -> Int
forall a. Integral a => a -> a
downgrade (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Image PixelRGBA8 -> Int
forall a. Image a -> Int
imageHeight Image PixelRGBA8
i)
    downgrade :: a -> a
downgrade v :: a
v = a -> a -> a
forall a. Ord a => a -> a -> a
max 1 (a -> a) -> a -> a
forall a b. (a -> b) -> a -> b
$ a
v a -> a -> a
forall a. Integral a => a -> a -> a
`div` 2
    go :: Image PixelRGBA8 -> [Image PixelRGBA8]
go i :: Image PixelRGBA8
i | Image PixelRGBA8 -> Int
forall a. Image a -> Int
imageWidth Image PixelRGBA8
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= 1 Bool -> Bool -> Bool
|| Image PixelRGBA8 -> Int
forall a. Image a -> Int
imageHeight Image PixelRGBA8
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= 1 = []
         | Bool
otherwise = let i' :: Image PixelRGBA8
i' = Image PixelRGBA8 -> Image PixelRGBA8
power2Scale Image PixelRGBA8
i in Image PixelRGBA8
i' Image PixelRGBA8 -> [Image PixelRGBA8] -> [Image PixelRGBA8]
forall a. a -> [a] -> [a]
: Image PixelRGBA8 -> [Image PixelRGBA8]
go Image PixelRGBA8
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 :: Image a -> [Image a]
createMipMapsIndexed img :: Image a
img = Image a
img Image a -> [Image a] -> [Image a]
forall a. a -> [a] -> [a]
: Image a -> [Image a]
forall a. Pixel a => Image a -> [Image a]
go Image a
img
  where
    power2Scale :: Image a -> Image a
power2Scale i :: Image a
i = (Int -> Int -> a) -> Int -> Int -> Image a
forall px. Pixel px => (Int -> Int -> px) -> Int -> Int -> Image px
generateImage (\x :: Int
x y :: Int
y -> Image a -> Int -> Int -> a
forall a. Pixel a => Image a -> Int -> Int -> a
pixelAt Image a
i (Int
xInt -> Int -> Int
forall a. Num a => a -> a -> a
*2) (Int
yInt -> Int -> Int
forall a. Num a => a -> a -> a
*2)) (Int -> Int
forall a. Integral a => a -> a
downgrade (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Image a -> Int
forall a. Image a -> Int
imageWidth Image a
i) (Int -> Int
forall a. Integral a => a -> a
downgrade (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Image a -> Int
forall a. Image a -> Int
imageHeight Image a
i)
    downgrade :: a -> a
downgrade v :: a
v = a -> a -> a
forall a. Ord a => a -> a -> a
max 1 (a -> a) -> a -> a
forall a b. (a -> b) -> a -> b
$ a
v a -> a -> a
forall a. Integral a => a -> a -> a
`div` 2
    go :: Image a -> [Image a]
go i :: Image a
i | Image a -> Int
forall a. Image a -> Int
imageWidth Image a
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= 1 Bool -> Bool -> Bool
|| Image a -> Int
forall a. Image a -> Int
imageHeight Image a
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= 1 = []
         | Bool
otherwise = let i' :: Image a
i' = Image a -> Image a
forall a. Pixel a => Image a -> Image a
power2Scale Image a
i in Image a
i' Image a -> [Image a] -> [Image a]
forall a. a -> [a] -> [a]
: Image a -> [Image a]
go Image a
i'

-- | Convert picture to BLP payload
toBlpExt :: BlpCompression -> BlpPictureType -> Int -> Int -> Image PixelRGBA8 -> BlpExt
toBlpExt :: BlpCompression
-> BlpPictureType -> Int -> Int -> Image PixelRGBA8 -> BlpExt
toBlpExt compr :: BlpCompression
compr pictype :: BlpPictureType
pictype quality :: Int
quality numMips :: Int
numMips img :: Image PixelRGBA8
img = case BlpCompression
compr of
  BlpCompressionJPEG -> Pixel8 -> Int -> Bool -> Image PixelRGBA8 -> BlpExt
toBlpJpg (Int -> Pixel8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
quality) Int
numMips Bool
hasAlpha Image PixelRGBA8
img
  BlpCompressionUncompressed -> case BlpPictureType
pictype of
    UncompressedWithAlpha -> Int -> Image PixelRGBA8 -> BlpExt
toBlpUncompressed1 Int
numMips Image PixelRGBA8
img
    UncompressedWithoutAlpha -> Int -> Image PixelRGBA8 -> BlpExt
toBlpUncompressed2 Int
numMips Image PixelRGBA8
img
    JPEGType -> Int -> Image PixelRGBA8 -> BlpExt
toBlpUncompressed2 Int
numMips Image PixelRGBA8
img -- Consider this as without alpha
  where
    hasAlpha :: Bool
hasAlpha = case BlpPictureType
pictype of
      UncompressedWithAlpha -> Bool
True
      _ -> Bool
False

-- | Convert picture to BLP JPEG and create mipmaps
toBlpJpg :: Word8 -> Int -> Bool -> Image PixelRGBA8 -> BlpExt
toBlpJpg :: Pixel8 -> Int -> Bool -> Image PixelRGBA8 -> BlpExt
toBlpJpg quality :: Pixel8
quality numMips :: Int
numMips hasAlpha :: Bool
hasAlpha img :: Image PixelRGBA8
img = $WBlpJpeg :: ByteString -> [ByteString] -> BlpExt
BlpJpeg {
    blpJpegHeader :: ByteString
blpJpegHeader = ByteString
header
  , blpJpegData :: [ByteString]
blpJpegData = [ByteString]
mipmapsRawWithoutHeader
  }
  where
    processAlpha :: Image PixelRGBA8 -> Image PixelRGBA8
    processAlpha :: Image PixelRGBA8 -> Image PixelRGBA8
processAlpha = (PixelRGBA8 -> PixelRGBA8) -> Image PixelRGBA8 -> Image PixelRGBA8
forall a b. (Pixel a, Pixel b) => (a -> b) -> Image a -> Image b
pixelMap ((PixelRGBA8 -> PixelRGBA8)
 -> Image PixelRGBA8 -> Image PixelRGBA8)
-> (PixelRGBA8 -> PixelRGBA8)
-> Image PixelRGBA8
-> Image PixelRGBA8
forall a b. (a -> b) -> a -> b
$ \p :: PixelRGBA8
p@(PixelRGBA8 r :: Pixel8
r g :: Pixel8
g b :: Pixel8
b a :: Pixel8
a) -> if Bool
hasAlpha then PixelRGBA8
p else Pixel8 -> Pixel8 -> Pixel8 -> Pixel8 -> PixelRGBA8
PixelRGBA8 Pixel8
r Pixel8
g Pixel8
b 255

    mipmaps :: [Image PixelCMYK8]
    mipmaps :: [Image PixelCMYK8]
mipmaps = Image PixelRGBA8 -> Image PixelCMYK8
toBlpCMYK8 (Image PixelRGBA8 -> Image PixelCMYK8)
-> [Image PixelRGBA8] -> [Image PixelCMYK8]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int -> [Image PixelRGBA8] -> [Image PixelRGBA8]
forall a. Int -> [a] -> [a]
fakeMipMaps Int
numMips ([Image PixelRGBA8] -> [Image PixelRGBA8])
-> (Image PixelRGBA8 -> [Image PixelRGBA8])
-> Image PixelRGBA8
-> [Image PixelRGBA8]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Image PixelRGBA8 -> [Image PixelRGBA8]
createMipMaps (Image PixelRGBA8 -> [Image PixelRGBA8])
-> (Image PixelRGBA8 -> Image PixelRGBA8)
-> Image PixelRGBA8
-> [Image PixelRGBA8]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Image PixelRGBA8 -> Image PixelRGBA8
processAlpha (Image PixelRGBA8 -> [Image PixelRGBA8])
-> Image PixelRGBA8 -> [Image PixelRGBA8]
forall a b. (a -> b) -> a -> b
$ Image PixelRGBA8
img)

    metadata :: CM.Metadatas
    metadata :: Metadatas
metadata = Keys Value -> Value -> Metadatas -> Metadatas
forall a.
(Show a, NFData a) =>
Keys a -> a -> Metadatas -> Metadatas
CM.insert (String -> Keys Value
CM.Unknown "JPEG Quality") (Int -> Value
CM.Int (Int -> Value) -> Int -> Value
forall a b. (a -> b) -> a -> b
$ Pixel8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Pixel8
quality) Metadatas
forall a. Monoid a => a
mempty

    mipmapsRaw :: [BS.ByteString]
    mipmapsRaw :: [ByteString]
mipmapsRaw = ByteString -> ByteString
toStrict (ByteString -> ByteString)
-> (Image PixelCMYK8 -> ByteString)
-> Image PixelCMYK8
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pixel8 -> Metadatas -> Image PixelCMYK8 -> ByteString
forall px.
JpgEncodable px =>
Pixel8 -> Metadatas -> Image px -> ByteString
encodeDirectJpegAtQualityWithMetadata Pixel8
quality Metadatas
metadata (Image PixelCMYK8 -> ByteString)
-> [Image PixelCMYK8] -> [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Image PixelCMYK8]
mipmaps

    header :: BS.ByteString
    header :: ByteString
header = Int -> [ByteString] -> ByteString
scanHeader 624 [ByteString]
mipmapsRaw

    mipmapsRawWithoutHeader :: [BS.ByteString]
    mipmapsRawWithoutHeader :: [ByteString]
mipmapsRawWithoutHeader = Int -> ByteString -> ByteString
BS.drop (ByteString -> Int
BS.length ByteString
header) (ByteString -> ByteString) -> [ByteString] -> [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ByteString]
mipmapsRaw

-- | Manually scan shared prefix of each mipmap
scanHeader :: Int -> [BS.ByteString] -> BS.ByteString
scanHeader :: Int -> [ByteString] -> ByteString
scanHeader _ [] = ByteString
forall a. Monoid a => a
mempty
scanHeader maxheader :: Int
maxheader [x :: ByteString
x] = Int -> ByteString -> ByteString
BS.take Int
maxheader ByteString
x
scanHeader maxheader :: Int
maxheader mipmaps :: [ByteString]
mipmaps = [ByteString] -> ByteString -> ByteString
go [ByteString]
mipmaps ByteString
forall a. Monoid a => a
mempty
  where
    go :: [ByteString] -> ByteString -> ByteString
go ![ByteString]
mps !ByteString
acc = let
      unconses :: [Maybe (Pixel8, ByteString)]
unconses = ByteString -> Maybe (Pixel8, ByteString)
BS.uncons (ByteString -> Maybe (Pixel8, ByteString))
-> [ByteString] -> [Maybe (Pixel8, ByteString)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ByteString]
mps :: [Maybe (Word8, BS.ByteString)]
      heads :: [Maybe Pixel8]
heads = ((Pixel8, ByteString) -> Pixel8)
-> Maybe (Pixel8, ByteString) -> Maybe Pixel8
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Pixel8, ByteString) -> Pixel8
forall a b. (a, b) -> a
fst (Maybe (Pixel8, ByteString) -> Maybe Pixel8)
-> [Maybe (Pixel8, ByteString)] -> [Maybe Pixel8]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Maybe (Pixel8, ByteString)]
unconses :: [Maybe Word8]
      tails :: [ByteString]
tails = [Maybe ByteString] -> [ByteString]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe ByteString] -> [ByteString])
-> [Maybe ByteString] -> [ByteString]
forall a b. (a -> b) -> a -> b
$ ((Pixel8, ByteString) -> ByteString)
-> Maybe (Pixel8, ByteString) -> Maybe ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Pixel8, ByteString) -> ByteString
forall a b. (a, b) -> b
snd (Maybe (Pixel8, ByteString) -> Maybe ByteString)
-> [Maybe (Pixel8, ByteString)] -> [Maybe ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Maybe (Pixel8, ByteString)]
unconses :: [BS.ByteString]
      hitEmpty :: Bool
hitEmpty = (Maybe Pixel8 -> Bool) -> [Maybe Pixel8] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Maybe Pixel8 -> Bool
forall a. Maybe a -> Bool
isNothing [Maybe Pixel8]
heads
      firstByte :: Pixel8
firstByte = case [Maybe Pixel8]
heads of
        (Just v :: Pixel8
v : _) -> Pixel8
v
        _ -> 0
      allEqual :: Bool
allEqual = (Maybe Pixel8 -> Bool) -> [Maybe Pixel8] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Pixel8 -> Maybe Pixel8
forall a. a -> Maybe a
Just Pixel8
firstByte Maybe Pixel8 -> Maybe Pixel8 -> Bool
forall a. Eq a => a -> a -> Bool
==) [Maybe Pixel8]
heads
      in if | Bool
hitEmpty -> ByteString
acc
            | Int
maxheader Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= ByteString -> Int
BS.length ByteString
acc -> ByteString
acc
            | Bool
allEqual -> [ByteString] -> ByteString -> ByteString
go [ByteString]
tails (ByteString
acc ByteString -> Pixel8 -> ByteString
`BS.snoc` Pixel8
firstByte)
            | Bool
otherwise -> ByteString
acc

-- | Helper to quantise colors to 256 colour pallete
makePallette :: Image PixelRGBA8 -> (Image Pixel8, Palette)
makePallette :: Image PixelRGBA8 -> (Image Pixel8, Palette)
makePallette = PaletteOptions -> Palette -> (Image Pixel8, Palette)
palettize PaletteOptions
defaultPaletteOptions (Palette -> (Image Pixel8, Palette))
-> (Image PixelRGBA8 -> Palette)
-> Image PixelRGBA8
-> (Image Pixel8, Palette)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PixelRGBA8 -> PixelRGB8) -> Image PixelRGBA8 -> Palette
forall a b. (Pixel a, Pixel b) => (a -> b) -> Image a -> Image b
pixelMap PixelRGBA8 -> PixelRGB8
forall a b. TransparentPixel a b => a -> b
dropTransparency

instance Storable PixelRGBA8 where
  sizeOf :: PixelRGBA8 -> Int
sizeOf _ = Word32 -> Int
forall a. Storable a => a -> Int
sizeOf (Word32
forall a. HasCallStack => a
undefined :: Word32)
  alignment :: PixelRGBA8 -> Int
alignment _ = Word32 -> Int
forall a. Storable a => a -> Int
alignment (Word32
forall a. HasCallStack => a
undefined :: Word32)
  peek :: Ptr PixelRGBA8 -> IO PixelRGBA8
peek ptr :: Ptr PixelRGBA8
ptr = Word32 -> PixelRGBA8
forall a. PackeablePixel a => PackedRepresentation a -> a
unpackPixel (Word32 -> PixelRGBA8) -> IO Word32 -> IO PixelRGBA8
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr Word32 -> IO Word32
forall a. Storable a => Ptr a -> IO a
peek (Ptr PixelRGBA8 -> Ptr Word32
forall a b. Ptr a -> Ptr b
castPtr Ptr PixelRGBA8
ptr :: Ptr Word32)
  poke :: Ptr PixelRGBA8 -> PixelRGBA8 -> IO ()
poke ptr :: Ptr PixelRGBA8
ptr px :: PixelRGBA8
px = Ptr Word32 -> Word32 -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke (Ptr PixelRGBA8 -> Ptr Word32
forall a b. Ptr a -> Ptr b
castPtr Ptr PixelRGBA8
ptr :: Ptr Word32) (Word32 -> IO ()) -> (PixelRGBA8 -> Word32) -> PixelRGBA8 -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PixelRGBA8 -> Word32
forall a. PackeablePixel a => a -> PackedRepresentation a
packPixel (PixelRGBA8 -> IO ()) -> PixelRGBA8 -> IO ()
forall a b. (a -> b) -> a -> b
$ PixelRGBA8
px

-- | Convert palette to format that we need for BLP
convertPalette :: Palette -> V.Vector PixelRGBA8
convertPalette :: Palette -> Vector PixelRGBA8
convertPalette = Vector PixelRGBA8 -> Vector PixelRGBA8
forall (v :: * -> *) a (w :: * -> *).
(Vector v a, Vector w a) =>
v a -> w a
V.convert (Vector PixelRGBA8 -> Vector PixelRGBA8)
-> (Palette -> Vector PixelRGBA8) -> Palette -> Vector PixelRGBA8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector Pixel8 -> Vector PixelRGBA8
forall a b. (Storable a, Storable b) => Vector a -> Vector b
VS.unsafeCast (Vector Pixel8 -> Vector PixelRGBA8)
-> (Palette -> Vector Pixel8) -> Palette -> Vector PixelRGBA8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Image PixelRGBA8 -> Vector Pixel8
forall a. Image a -> Vector (PixelBaseComponent a)
imageData (Image PixelRGBA8 -> Vector Pixel8)
-> (Palette -> Image PixelRGBA8) -> Palette -> Vector Pixel8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PixelRGB8 -> PixelRGBA8) -> Palette -> Image PixelRGBA8
forall a b. (Pixel a, Pixel b) => (a -> b) -> Image a -> Image b
pixelMap ((\(PixelRGBA8 r :: Pixel8
r g :: Pixel8
g b :: Pixel8
b a :: Pixel8
a) -> Pixel8 -> Pixel8 -> Pixel8 -> Pixel8 -> PixelRGBA8
PixelRGBA8 Pixel8
b Pixel8
g Pixel8
r Pixel8
a) (PixelRGBA8 -> PixelRGBA8)
-> (PixelRGB8 -> PixelRGBA8) -> PixelRGB8 -> PixelRGBA8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PixelRGB8 -> PixelRGBA8
forall a b. ColorConvertible a b => a -> b
promotePixel :: PixelRGB8 -> PixelRGBA8)

-- | Convert indexed image to raw bytestring
convertIndexed :: Image Pixel8 -> BS.ByteString
convertIndexed :: Image Pixel8 -> ByteString
convertIndexed img :: Image Pixel8
img = let
  (fptr :: ForeignPtr Pixel8
fptr, l :: Int
l) = Vector Pixel8 -> (ForeignPtr Pixel8, Int)
forall a. Storable a => Vector a -> (ForeignPtr a, Int)
VS.unsafeToForeignPtr0 (Vector Pixel8 -> (ForeignPtr Pixel8, Int))
-> (Image Pixel8 -> Vector Pixel8)
-> Image Pixel8
-> (ForeignPtr Pixel8, Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Image Pixel8 -> Vector Pixel8
forall a. Image a -> Vector (PixelBaseComponent a)
imageData (Image Pixel8 -> (ForeignPtr Pixel8, Int))
-> Image Pixel8 -> (ForeignPtr Pixel8, Int)
forall a b. (a -> b) -> a -> b
$ Image Pixel8
img
  in IO ByteString -> ByteString
forall a. IO a -> a
unsafePerformIO (IO ByteString -> ByteString) -> IO ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ForeignPtr Pixel8 -> (Ptr Pixel8 -> IO ByteString) -> IO ByteString
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Pixel8
fptr ((Ptr Pixel8 -> IO ByteString) -> IO ByteString)
-> (Ptr Pixel8 -> IO ByteString) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \ptr :: Ptr Pixel8
ptr -> CStringLen -> IO ByteString
BS.unsafePackCStringLen (Ptr Pixel8 -> Ptr CChar
forall a b. Ptr a -> Ptr b
castPtr Ptr Pixel8
ptr, Int
l)

-- | Convert picture to BLP uncompressed with alpha and create mipmaps
toBlpUncompressed1 :: Int -> Image PixelRGBA8 -> BlpExt
toBlpUncompressed1 :: Int -> Image PixelRGBA8 -> BlpExt
toBlpUncompressed1 numMips :: Int
numMips img :: Image PixelRGBA8
img =  $WBlpUncompressed1 :: Vector PixelRGBA8 -> [(ByteString, ByteString)] -> BlpExt
BlpUncompressed1 {
    blpU1Palette :: Vector PixelRGBA8
blpU1Palette = Palette -> Vector PixelRGBA8
convertPalette Palette
palette
  , blpU1MipMaps :: [(ByteString, ByteString)]
blpU1MipMaps = (Image Pixel8 -> ByteString) -> [Image Pixel8] -> [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Image Pixel8 -> ByteString
convertIndexed [Image Pixel8]
mipmaps [ByteString] -> [ByteString] -> [(ByteString, ByteString)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` (Image Pixel8 -> ByteString) -> [Image Pixel8] -> [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Image Pixel8 -> ByteString
convertIndexed [Image Pixel8]
alphaMaps
  }
  where
    img'    :: Image Pixel8
    palette :: Palette
    (img' :: Image Pixel8
img', palette :: Palette
palette) = Image PixelRGBA8 -> (Image Pixel8, Palette)
makePallette Image PixelRGBA8
img

    alphaImg :: Image Pixel8
    alphaImg :: Image Pixel8
alphaImg = PlaneAlpha
-> Image PixelRGBA8 -> Image (PixelBaseComponent PixelRGBA8)
forall px plane.
(Pixel px, Pixel (PixelBaseComponent px),
 PixelBaseComponent (PixelBaseComponent px) ~ PixelBaseComponent px,
 ColorPlane px plane) =>
plane -> Image px -> Image (PixelBaseComponent px)
extractComponent PlaneAlpha
PlaneAlpha Image PixelRGBA8
img

    mipmaps :: [Image Pixel8]
    mipmaps :: [Image Pixel8]
mipmaps = Int -> [Image Pixel8] -> [Image Pixel8]
forall a. Int -> [a] -> [a]
fakeMipMaps Int
numMips ([Image Pixel8] -> [Image Pixel8])
-> [Image Pixel8] -> [Image Pixel8]
forall a b. (a -> b) -> a -> b
$ Image Pixel8 -> [Image Pixel8]
forall a. Pixel a => Image a -> [Image a]
createMipMapsIndexed Image Pixel8
img'

    alphaMaps :: [Image Pixel8]
    alphaMaps :: [Image Pixel8]
alphaMaps = Int -> [Image Pixel8] -> [Image Pixel8]
forall a. Int -> [a] -> [a]
fakeMipMaps Int
numMips ([Image Pixel8] -> [Image Pixel8])
-> [Image Pixel8] -> [Image Pixel8]
forall a b. (a -> b) -> a -> b
$ Image Pixel8 -> [Image Pixel8]
forall a. Pixel a => Image a -> [Image a]
createMipMapsIndexed Image Pixel8
alphaImg

-- | Convert picture to BLP uncompressed without alpha and create mipmaps
toBlpUncompressed2 :: Int -> Image PixelRGBA8 -> BlpExt
toBlpUncompressed2 :: Int -> Image PixelRGBA8 -> BlpExt
toBlpUncompressed2 numMips :: Int
numMips img :: Image PixelRGBA8
img = $WBlpUncompressed2 :: Vector PixelRGBA8 -> [ByteString] -> BlpExt
BlpUncompressed2 {
    blpU2Palette :: Vector PixelRGBA8
blpU2Palette = Palette -> Vector PixelRGBA8
convertPalette Palette
palette
  , blpU2MipMaps :: [ByteString]
blpU2MipMaps = Image Pixel8 -> ByteString
convertIndexed (Image Pixel8 -> ByteString) -> [Image Pixel8] -> [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Image Pixel8]
mipmaps
  }
  where
    img'    :: Image Pixel8
    palette :: Palette
    (img' :: Image Pixel8
img', palette :: Palette
palette) = Image PixelRGBA8 -> (Image Pixel8, Palette)
makePallette Image PixelRGBA8
img

    mipmaps :: [Image Pixel8]
    mipmaps :: [Image Pixel8]
mipmaps = Int -> [Image Pixel8] -> [Image Pixel8]
forall a. Int -> [a] -> [a]
fakeMipMaps Int
numMips ([Image Pixel8] -> [Image Pixel8])
-> [Image Pixel8] -> [Image Pixel8]
forall a b. (a -> b) -> a -> b
$ Image Pixel8 -> [Image Pixel8]
forall a. Pixel a => Image a -> [Image a]
createMipMapsIndexed Image Pixel8
img'