{-# 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 
 = let  info            = getBitmapInfoV3 $ bmpBitmapInfo bmp
        width           = fromIntegral $ dib3Width  info
        height          = fromIntegral $ dib3Height info
        flipX           = dib3HeightFlipped info
        bitCount        = dib3BitCount info
   in   case bitCount of
         24     -> packRGB24ToRGBA32 width height flipX (bmpRawImageData bmp)
         32     -> packRGB32ToRGBA32 width height flipX (bmpRawImageData bmp)
         _      -> error "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 width height flipX str
 = let  -- Number of bytes per line in the source file, 
        -- including padding bytes.
        srcBytesPerLine = BS.length str `div` height
        sizeDest        = width * height * 4

        -- We allow padding bytes on the end of the image data.
   in   if BS.length str < height * srcBytesPerLine
         then error "Codec.BMP: Image data is truncated."
         else unsafePerformIO
                $ allocaBytes sizeDest      $ \bufDest -> 
                  BS.unsafeUseAsCString str $ \bufSrc  ->
                   do   packRGB24ToRGBA32' 
                                width height flipX 
                                srcBytesPerLine
                                (castPtr bufSrc) (castPtr bufDest)
                        packCStringLen (bufDest, 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' width height flipX srcBytesPerLine ptrSrc ptrDst 
 = go 0
 where  
        go posY
         -- we've finished the image.
         | posY == height
         = return ()

         -- Image source data is flipped along the X axis.
         | flipX
         = let  !oSrc   = srcBytesPerLine * (height - 1 - posY)
                !oDst   = width * 4 * posY
           in   go_line 0 posY oSrc oDst

         -- Image source data is in the natural order.
         | otherwise
         = let  !oSrc   = srcBytesPerLine * posY
                !oDst   = width * 4 * posY
           in   go_line 0 posY oSrc oDst

        go_line posX posY oSrc oDst
         -- move to the next line.
         | posX == width 
         = go (posY + 1)
                
         -- process a pixel.
         | otherwise
         = do   blue  :: Word8  <- peekByteOff ptrSrc (oSrc + 0)
                green :: Word8  <- peekByteOff ptrSrc (oSrc + 1)
                red   :: Word8  <- peekByteOff ptrSrc (oSrc + 2)

                pokeByteOff ptrDst (oDst + 0) red
                pokeByteOff ptrDst (oDst + 1) green
                pokeByteOff ptrDst (oDst + 2) blue
                pokeByteOff ptrDst (oDst + 3) (255 :: Word8)
                
                go_line (posX + 1) posY (oSrc + 3) (oDst + 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 width height flipX str
  = let sizeDest = height * width * 4
    in  if  BS.length str < sizeDest
         then error "Codec.BMP: Image data is truncated."
         else unsafePerformIO
                $ allocaBytes sizeDest      $ \bufDest -> 
                  BS.unsafeUseAsCString str $ \bufSrc  ->
                   do   packRGB32ToRGBA32' width height
                                flipX
                                (castPtr bufSrc) (castPtr bufDest)
                        packCStringLen (bufDest, 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' width height flipX ptrSrc ptrDst
 = go 0
 where  
        go posY
         -- we've finished the image.
         | posY == height
         = return ()

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

        go_line posX posY oSrc oDst
         -- move to the next line.
         | posX == width 
         = go (posY + 1)
        
         -- process a pixel.
         | otherwise
         = do   blue   :: Word8 <- peekByteOff ptrSrc (oSrc + 0)
                green  :: Word8 <- peekByteOff ptrSrc (oSrc + 1)
                red    :: Word8 <- peekByteOff ptrSrc (oSrc + 2)
                alpha  :: Word8 <- peekByteOff ptrSrc (oSrc + 3)

                pokeByteOff ptrDst (oDst + 0) red
                pokeByteOff ptrDst (oDst + 1) green
                pokeByteOff ptrDst (oDst + 2) blue
                pokeByteOff ptrDst (oDst + 3) alpha
                
                go_line (posX + 1) posY (oSrc + 4) (oDst + 4)