{-# OPTIONS_HADDOCK hide #-}
module Codec.BMP.Unpack
        (unpackBMPToRGBA32)
where   
import Codec.BMP.Base
import Codec.BMP.BitmapInfo
import Codec.BMP.BitmapInfoV3
import Foreign.Ptr
import Foreign.Marshal.Alloc
import Foreign.Storable
import System.IO.Unsafe
import Data.Word
import Data.ByteString          as BS
import Data.ByteString.Unsafe   as BS
import Prelude                  as P


-- | Unpack a BMP image to a string of RGBA component values.
unpackBMPToRGBA32 :: BMP -> ByteString
unpackBMPToRGBA32 :: BMP -> ByteString
unpackBMPToRGBA32 BMP
bmp 
 = let  info :: BitmapInfoV3
info            = BitmapInfo -> BitmapInfoV3
getBitmapInfoV3 (BitmapInfo -> BitmapInfoV3) -> BitmapInfo -> BitmapInfoV3
forall a b. (a -> b) -> a -> b
$ BMP -> BitmapInfo
bmpBitmapInfo BMP
bmp
        width :: Int
width           = Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Int) -> Word32 -> Int
forall a b. (a -> b) -> a -> b
$ BitmapInfoV3 -> Word32
dib3Width  BitmapInfoV3
info
        height :: Int
height          = Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Int) -> Word32 -> Int
forall a b. (a -> b) -> a -> b
$ BitmapInfoV3 -> Word32
dib3Height BitmapInfoV3
info
        flipX :: Bool
flipX           = BitmapInfoV3 -> Bool
dib3HeightFlipped BitmapInfoV3
info
        bitCount :: Word16
bitCount        = BitmapInfoV3 -> Word16
dib3BitCount BitmapInfoV3
info
   in   case Word16
bitCount of
         Word16
24     -> Int -> Int -> Bool -> ByteString -> ByteString
packRGB24ToRGBA32 Int
width Int
height Bool
flipX (BMP -> ByteString
bmpRawImageData BMP
bmp)
         Word16
32     -> Int -> Int -> Bool -> ByteString -> ByteString
packRGB32ToRGBA32 Int
width Int
height Bool
flipX (BMP -> ByteString
bmpRawImageData BMP
bmp)
         Word16
_      -> [Char] -> ByteString
forall a. HasCallStack => [Char] -> a
error [Char]
"Codec.BMP: Unhandled bitcount."


-- | Unpack raw, uncompressed 24 bit BMP image data to a string of
--   RGBA component values.
--
--   The alpha component is set to 255 for every pixel.
packRGB24ToRGBA32
        :: Int                  -- ^ Width of image.
        -> Int                  -- ^ Height of image.
        -> Bool                 -- ^ Image data is flipped along the X axis.
        -> ByteString           -- ^ Input string.
        -> ByteString
                
packRGB24ToRGBA32 :: Int -> Int -> Bool -> ByteString -> ByteString
packRGB24ToRGBA32 Int
width Int
height Bool
flipX ByteString
str
 = let  -- Number of bytes per line in the source file, 
        -- including padding bytes.
        srcBytesPerLine :: Int
srcBytesPerLine = ByteString -> Int
BS.length ByteString
str Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
height
        sizeDest :: Int
sizeDest        = Int
width Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
height Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
4

        -- We allow padding bytes on the end of the image data.
   in   if ByteString -> Int
BS.length ByteString
str Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
height Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
srcBytesPerLine
         then [Char] -> ByteString
forall a. HasCallStack => [Char] -> a
error [Char]
"Codec.BMP: Image data is truncated."
         else IO ByteString -> ByteString
forall a. IO a -> a
unsafePerformIO
                (IO ByteString -> ByteString) -> IO ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> (Ptr CChar -> IO ByteString) -> IO ByteString
forall a b. Int -> (Ptr a -> IO b) -> IO b
allocaBytes Int
sizeDest      ((Ptr CChar -> IO ByteString) -> IO ByteString)
-> (Ptr CChar -> IO ByteString) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \Ptr CChar
bufDest -> 
                  ByteString -> (Ptr CChar -> IO ByteString) -> IO ByteString
forall a. ByteString -> (Ptr CChar -> IO a) -> IO a
BS.unsafeUseAsCString ByteString
str ((Ptr CChar -> IO ByteString) -> IO ByteString)
-> (Ptr CChar -> IO ByteString) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \Ptr CChar
bufSrc  ->
                   do   Int -> Int -> Bool -> Int -> Ptr Any -> Ptr Any -> IO ()
forall {b} {b}.
Int -> Int -> Bool -> Int -> Ptr b -> Ptr b -> IO ()
packRGB24ToRGBA32' 
                                Int
width Int
height Bool
flipX 
                                Int
srcBytesPerLine
                                (Ptr CChar -> Ptr Any
forall a b. Ptr a -> Ptr b
castPtr Ptr CChar
bufSrc) (Ptr CChar -> Ptr Any
forall a b. Ptr a -> Ptr b
castPtr Ptr CChar
bufDest)
                        CStringLen -> IO ByteString
packCStringLen (Ptr CChar
bufDest, Int
sizeDest)

                
-- We're doing this via Ptrs because we don't want to take the
-- overhead of doing the bounds checks in ByteString.index.
packRGB24ToRGBA32' :: Int -> Int -> Bool -> Int -> Ptr b -> Ptr b -> IO ()
packRGB24ToRGBA32' Int
width Int
height Bool
flipX Int
srcBytesPerLine Ptr b
ptrSrc Ptr b
ptrDst 
 = Int -> IO ()
go Int
0
 where  
        go :: Int -> IO ()
go Int
posY
         -- we've finished the image.
         | Int
posY Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
height
         = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

         -- Image source data is flipped along the X axis.
         | Bool
flipX
         = let  !oSrc :: Int
oSrc   = Int
srcBytesPerLine Int -> Int -> Int
forall a. Num a => a -> a -> a
* (Int
height Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
posY)
                !oDst :: Int
oDst   = Int
width Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
posY
           in   Int -> Int -> Int -> Int -> IO ()
go_line Int
0 Int
posY Int
oSrc Int
oDst

         -- Image source data is in the natural order.
         | Bool
otherwise
         = let  !oSrc :: Int
oSrc   = Int
srcBytesPerLine Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
posY
                !oDst :: Int
oDst   = Int
width Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
posY
           in   Int -> Int -> Int -> Int -> IO ()
go_line Int
0 Int
posY Int
oSrc Int
oDst

        go_line :: Int -> Int -> Int -> Int -> IO ()
go_line Int
posX Int
posY Int
oSrc Int
oDst
         -- move to the next line.
         | Int
posX Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
width 
         = Int -> IO ()
go (Int
posY Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
                
         -- process a pixel.
         | Bool
otherwise
         = do   Word8
blue  :: Word8  <- Ptr b -> Int -> IO Word8
forall b. Ptr b -> Int -> IO Word8
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr b
ptrSrc (Int
oSrc Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
0)
                Word8
green :: Word8  <- Ptr b -> Int -> IO Word8
forall b. Ptr b -> Int -> IO Word8
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr b
ptrSrc (Int
oSrc Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
                Word8
red   :: Word8  <- Ptr b -> Int -> IO Word8
forall b. Ptr b -> Int -> IO Word8
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr b
ptrSrc (Int
oSrc Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2)

                Ptr b -> Int -> Word8 -> IO ()
forall b. Ptr b -> Int -> Word8 -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr b
ptrDst (Int
oDst Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
0) Word8
red
                Ptr b -> Int -> Word8 -> IO ()
forall b. Ptr b -> Int -> Word8 -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr b
ptrDst (Int
oDst Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Word8
green
                Ptr b -> Int -> Word8 -> IO ()
forall b. Ptr b -> Int -> Word8 -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr b
ptrDst (Int
oDst Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2) Word8
blue
                Ptr b -> Int -> Word8 -> IO ()
forall b. Ptr b -> Int -> Word8 -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr b
ptrDst (Int
oDst Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
3) (Word8
255 :: Word8)
                
                Int -> Int -> Int -> Int -> IO ()
go_line (Int
posX Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int
posY (Int
oSrc Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
3) (Int
oDst Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
4)


-- | Unpack raw, uncompressed 32 bit BMP image data to a string of
--   RGBA component values.
--   Note in the BMP file the components are arse-around ABGR instead of RGBA. 
--   The 'unpacking' here is really just flipping the components around.
packRGB32ToRGBA32
        :: Int                  -- ^ Width of image.
        -> Int                  -- ^ Height of image.
        -> Bool                 -- ^ Image data is flipped along the X axis.
        -> ByteString           -- ^ Input string.
        -> ByteString
                
packRGB32ToRGBA32 :: Int -> Int -> Bool -> ByteString -> ByteString
packRGB32ToRGBA32 Int
width Int
height Bool
flipX ByteString
str
  = let sizeDest :: Int
sizeDest = Int
height Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
width Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
4
    in  if  ByteString -> Int
BS.length ByteString
str Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
sizeDest
         then [Char] -> ByteString
forall a. HasCallStack => [Char] -> a
error [Char]
"Codec.BMP: Image data is truncated."
         else IO ByteString -> ByteString
forall a. IO a -> a
unsafePerformIO
                (IO ByteString -> ByteString) -> IO ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> (Ptr CChar -> IO ByteString) -> IO ByteString
forall a b. Int -> (Ptr a -> IO b) -> IO b
allocaBytes Int
sizeDest      ((Ptr CChar -> IO ByteString) -> IO ByteString)
-> (Ptr CChar -> IO ByteString) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \Ptr CChar
bufDest -> 
                  ByteString -> (Ptr CChar -> IO ByteString) -> IO ByteString
forall a. ByteString -> (Ptr CChar -> IO a) -> IO a
BS.unsafeUseAsCString ByteString
str ((Ptr CChar -> IO ByteString) -> IO ByteString)
-> (Ptr CChar -> IO ByteString) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \Ptr CChar
bufSrc  ->
                   do   Int -> Int -> Bool -> Ptr Any -> Ptr Any -> IO ()
forall {b} {b}. Int -> Int -> Bool -> Ptr b -> Ptr b -> IO ()
packRGB32ToRGBA32' Int
width Int
height
                                Bool
flipX
                                (Ptr CChar -> Ptr Any
forall a b. Ptr a -> Ptr b
castPtr Ptr CChar
bufSrc) (Ptr CChar -> Ptr Any
forall a b. Ptr a -> Ptr b
castPtr Ptr CChar
bufDest)
                        CStringLen -> IO ByteString
packCStringLen (Ptr CChar
bufDest, Int
sizeDest)

                
-- We're doing this via Ptrs because we don't want to take the
-- overhead of doing the bounds checks in ByteString.index.
packRGB32ToRGBA32' :: Int -> Int -> Bool -> Ptr b -> Ptr b -> IO ()
packRGB32ToRGBA32' Int
width Int
height Bool
flipX Ptr b
ptrSrc Ptr b
ptrDst
 = Int -> IO ()
go Int
0
 where  
        go :: Int -> IO ()
go Int
posY
         -- we've finished the image.
         | Int
posY Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
height
         = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

         -- Image source data is flipped along the X axis.
         | Bool
flipX
         = let  !oSrc :: Int
oSrc   = Int
width Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
* (Int
height Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
posY)
                !oDst :: Int
oDst   = Int
width Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
posY
           in   Int -> Int -> Int -> Int -> IO ()
go_line Int
0 Int
posY Int
oSrc Int
oDst
        
         -- Image source data is in the natural order.
         | Bool
otherwise
         = let  !oSrc :: Int
oSrc   = Int
width Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
posY
                !oDst :: Int
oDst   = Int
width Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
posY
           in   Int -> Int -> Int -> Int -> IO ()
go_line Int
0 Int
posY Int
oSrc Int
oDst

        go_line :: Int -> Int -> Int -> Int -> IO ()
go_line Int
posX Int
posY Int
oSrc Int
oDst
         -- move to the next line.
         | Int
posX Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
width 
         = Int -> IO ()
go (Int
posY Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
        
         -- process a pixel.
         | Bool
otherwise
         = do   Word8
blue   :: Word8 <- Ptr b -> Int -> IO Word8
forall b. Ptr b -> Int -> IO Word8
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr b
ptrSrc (Int
oSrc Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
0)
                Word8
green  :: Word8 <- Ptr b -> Int -> IO Word8
forall b. Ptr b -> Int -> IO Word8
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr b
ptrSrc (Int
oSrc Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
                Word8
red    :: Word8 <- Ptr b -> Int -> IO Word8
forall b. Ptr b -> Int -> IO Word8
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr b
ptrSrc (Int
oSrc Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2)
                Word8
alpha  :: Word8 <- Ptr b -> Int -> IO Word8
forall b. Ptr b -> Int -> IO Word8
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr b
ptrSrc (Int
oSrc Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
3)

                Ptr b -> Int -> Word8 -> IO ()
forall b. Ptr b -> Int -> Word8 -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr b
ptrDst (Int
oDst Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
0) Word8
red
                Ptr b -> Int -> Word8 -> IO ()
forall b. Ptr b -> Int -> Word8 -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr b
ptrDst (Int
oDst Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Word8
green
                Ptr b -> Int -> Word8 -> IO ()
forall b. Ptr b -> Int -> Word8 -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr b
ptrDst (Int
oDst Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2) Word8
blue
                Ptr b -> Int -> Word8 -> IO ()
forall b. Ptr b -> Int -> Word8 -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr b
ptrDst (Int
oDst Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
3) Word8
alpha
                
                Int -> Int -> Int -> Int -> IO ()
go_line (Int
posX Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int
posY (Int
oSrc Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
4) (Int
oDst Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
4)