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
unpackBMPToRGBA32 :: BMP -> ByteString
unpackBMPToRGBA32 bmp
= let info = getBitmapInfoV3 $ bmpBitmapInfo bmp
width = fromIntegral $ dib3Width info
height = fromIntegral $ dib3Height info
bitCount = dib3BitCount info
in case bitCount of
24 -> packRGB24ToRGBA32 width height (bmpRawImageData bmp)
32 -> packRGB32ToRGBA32 width height (bmpRawImageData bmp)
_ -> error "Codec.BMP.unpackBMPToRGBA32: unhandled bitcount."
packRGB24ToRGBA32
:: Int
-> Int
-> ByteString
-> ByteString
packRGB24ToRGBA32 width height str
= let bytesPerLine = BS.length str `div` height
padPerLine = bytesPerLine width * 3
sizeDest = width * height * 4
in if BS.length str < height * (width * 3 + padPerLine)
then error "Codec.BMP.unpackRGB24ToRGBA32: image data is truncated."
else unsafePerformIO
$ allocaBytes sizeDest $ \bufDest ->
BS.unsafeUseAsCString str $ \bufSrc ->
do packRGB24ToRGBA32' width height padPerLine (castPtr bufSrc) (castPtr bufDest)
packCStringLen (bufDest, sizeDest)
packRGB24ToRGBA32' width height pad ptrSrc ptrDest
= go 0 0 0 0
where
go posX posY oSrc oDest
| posX == width
= go 0 (posY + 1) (oSrc + pad) oDest
| posY == height
= return ()
| otherwise
= do blue :: Word8 <- peekByteOff ptrSrc (oSrc + 0)
green :: Word8 <- peekByteOff ptrSrc (oSrc + 1)
red :: Word8 <- peekByteOff ptrSrc (oSrc + 2)
pokeByteOff ptrDest (oDest + 0) red
pokeByteOff ptrDest (oDest + 1) green
pokeByteOff ptrDest (oDest + 2) blue
pokeByteOff ptrDest (oDest + 3) (255 :: Word8)
go (posX + 1) posY (oSrc + 3) (oDest + 4)
packRGB32ToRGBA32
:: Int
-> Int
-> ByteString
-> ByteString
packRGB32ToRGBA32 width height str
= let sizeDest = height * width * 4
in if BS.length str < sizeDest
then error "Codec.BMP.packRGB24ToRGBA32: image data is truncated."
else unsafePerformIO
$ allocaBytes sizeDest $ \bufDest ->
BS.unsafeUseAsCString str $ \bufSrc ->
do packRGB32ToRGBA32' width height (castPtr bufSrc) (castPtr bufDest)
packCStringLen (bufDest, sizeDest)
packRGB32ToRGBA32' width height ptrSrc ptrDest
= go 0 0 0 0
where
go posX posY oSrc oDest
| posX == width
= go 0 (posY + 1) oSrc oDest
| posY == height
= return ()
| 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 ptrDest (oDest + 0) red
pokeByteOff ptrDest (oDest + 1) green
pokeByteOff ptrDest (oDest + 2) blue
pokeByteOff ptrDest (oDest + 3) alpha
go (posX + 1) posY (oSrc + 4) (oDest + 4)