diff --git a/Codec/BMP.hs b/Codec/BMP.hs --- a/Codec/BMP.hs +++ b/Codec/BMP.hs @@ -1,12 +1,9 @@ -{-# LANGUAGE ScopedTypeVariables, PatternGuards #-} -- | Reading and writing uncompressed BMP files. -- --- Reading works for both uncompressed 24bit RGB and 32bit RGBA --- WindowsV3, WindowsV4 and WindowsV5 formats. +-- Supports uncompressed 24bit RGB and 32bit RGBA +-- WindowsV3, WindowsV4 and WindowsV5 formats. -- --- Writing is limited to the uncompressed 24bit RGB WindowsV3 format. --- -- We don't support the plain OS/2 BitmapCoreHeader -- and BitmapCoreHeader2 image headers, but I haven't yet seen one of -- these in the wild. @@ -26,22 +23,18 @@ -- -- Release Notes: -- +-- > * bmp 1.2.5 +-- > Add support for writing uncompressed 32-bit files. +-- > +-- > * bmp 1.2.4 +-- > Update to use binary 0.6. +-- > -- > * bmp 1.2.3 -- > Add pure parseBMP / renderBMP API. -- > -- > * bmp 1.2.2 -- > Allow the physical image buffer to be larger than the image -- > size stated in the header, to accept output of foolish Win7 codec. --- > --- > * bmp 1.2.1 --- > Fix slow ByteString conversion via lists. --- > --- > * bmp 1.2.0 --- > Accept files with zero padding on the end of the file. --- > Accept RGBA files with V3 headers. --- > --- > * bmp 1.1.2 --- > Accept files with the image size field set to zero. -- module Codec.BMP ( -- * Data Structures @@ -62,7 +55,9 @@ , writeBMP, hPutBMP, renderBMP -- * Pack and Unpack - , packRGBA32ToBMP + , packRGBA32ToBMP + , packRGBA32ToBMP32 + , packRGBA32ToBMP24 , unpackBMPToRGBA32 , bmpDimensions) where diff --git a/Codec/BMP/BitmapInfoV3.hs b/Codec/BMP/BitmapInfoV3.hs --- a/Codec/BMP/BitmapInfoV3.hs +++ b/Codec/BMP/BitmapInfoV3.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE PatternGuards #-} {-# OPTIONS_HADDOCK hide #-} module Codec.BMP.BitmapInfoV3 ( BitmapInfoV3 (..) @@ -82,7 +81,7 @@ let (height, flipped) = if heightI32 < 0 then (fromIntegral (abs heightI32), True) - else (heightW32, False) + else (heightW32, False) planes <- getWord16le bitc <- getWord16le diff --git a/Codec/BMP/BitmapInfoV4.hs b/Codec/BMP/BitmapInfoV4.hs --- a/Codec/BMP/BitmapInfoV4.hs +++ b/Codec/BMP/BitmapInfoV4.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE PatternGuards #-} {-# OPTIONS_HADDOCK hide #-} module Codec.BMP.BitmapInfoV4 ( BitmapInfoV4 (..) @@ -88,7 +87,6 @@ putWord32le $ dib4GammaGreen header putWord32le $ dib4GammaBlue header - -- | Check headers for problems and unsupported features. -- With a V4 header we support both the uncompressed 24bit RGB format, @@ -159,7 +157,8 @@ -- set this to zero. -- -- * We also can't use the physical size of the data in the file because --- some encoders add zero padding bytes on the end. +-- some encoders add zero padding bytes on the end. +-- imageSizeFromBitmapInfoV4 :: BitmapInfoV4 -> Maybe Int imageSizeFromBitmapInfoV4 headerV4 | dib3BitCount headerV3 == 32 diff --git a/Codec/BMP/Pack.hs b/Codec/BMP/Pack.hs --- a/Codec/BMP/Pack.hs +++ b/Codec/BMP/Pack.hs @@ -1,7 +1,8 @@ {-# OPTIONS_HADDOCK hide #-} -{-# LANGUAGE ScopedTypeVariables #-} module Codec.BMP.Pack - (packRGBA32ToBMP) + ( packRGBA32ToBMP + , packRGBA32ToBMP24 + , packRGBA32ToBMP32) where import Codec.BMP.Base import Codec.BMP.BitmapInfo @@ -18,36 +19,93 @@ import Prelude as P --- | Pack a string of RGBA component values into a BMP image. +-- | Pack a string of RGBA component values into a 32-bit BMP image. +-- +-- Alias for `packRGBA32ToBMP32`. -- +packRGBA32ToBMP + :: Int -- ^ Width of image (must be positive). + -> Int -- ^ Height of image (must be positive). + -> ByteString -- ^ A string of RGBA component values. + -- Must have length (@width * height * 4@) + -> BMP + +packRGBA32ToBMP = packRGBA32ToBMP32 +{-# INLINE packRGBA32ToBMP #-} + + +-- BMP 32 bit ----------------------------------------------------------------- +-- | Pack a string of RGBA component values into a 32-bit BMP image. +-- -- * If the given dimensions don't match the input string then `error`. -- -- * If the width or height fields are negative then `error`. -- --- * This currently ignores the alpha component of the input string and --- produces a 24bit RGB image. +packRGBA32ToBMP32 + :: Int -- ^ Width of image (must be positive). + -> Int -- ^ Height of image (must be positive). + -> ByteString -- ^ A string of RGBA component values. + -- Must have length (@width * height * 4@) + -> BMP + +packRGBA32ToBMP32 width height str + | width < 0 + = error "Codec.BMP: Negative width field." + + | height < 0 + = error "Codec.BMP: Negative height field." + + | height * width * 4 /= BS.length str + = error "Codec.BMP: Image dimensions don't match input data." + + | otherwise + = let imageData = packRGBA32ToBGRA32 width height str + in packDataToBMP 32 width height imageData + + +-- BMP 24 bit ----------------------------------------------------------------- +-- | Pack a string of RGBA component values into a 24-bit BMP image, +-- discarding the alpha channel of the source data. -- -packRGBA32ToBMP - :: Int -- ^ Width of image (must be positive). - -> Int -- ^ Height of image (must be positive). - -> ByteString -- ^ A string of RGBA component values. +-- * If the given dimensions don't match the input string then `error`. +-- +-- * If the width or height fields are negative then `error`. + +packRGBA32ToBMP24 + :: Int -- ^ Width of image (must be positive). + -> Int -- ^ Height of image (must be positive). + -> ByteString -- ^ A string of RGBA component values. -- Must have length (@width * height * 4@) - -> BMP - -packRGBA32ToBMP width height str - | width < 0 + -> BMP + +packRGBA32ToBMP24 width height str + | width < 0 = error "Codec.BMP: Negative width field." - | height < 0 + | height < 0 = error "Codec.BMP: Negative height field." | height * width * 4 /= BS.length str = error "Codec.BMP: Image dimensions don't match input data." | otherwise - = let (imageData, _) = packRGBA32ToRGB24 width height str + = let imageData = packRGBA32ToBGR24 width height str + in packDataToBMP 24 width height imageData - fileHeader + +-- data ----------------------------------------------------------------------- +-- | Wrap pre-packed image data into BMP image. +-- +packDataToBMP + :: Int -- ^ Number of bits per pixel + -> Int -- ^ Width of image (must be positive). + -> Int -- ^ Height of image (must be positive). + -> ByteString -- ^ A string of RGBA component values. + -- Must have length (@width * height * 4@) + -> BMP + +packDataToBMP bits width height imageData + = let fileHeader = FileHeader { fileHeaderType = bmpMagic @@ -68,7 +126,7 @@ , dib3Height = fromIntegral height , dib3HeightFlipped = False , dib3Planes = 1 - , dib3BitCount = 24 + , dib3BitCount = fromIntegral bits , dib3Compression = CompressionRGB , dib3ImageSize = fromIntegral $ BS.length imageData @@ -98,15 +156,15 @@ ++ show errs - -packRGBA32ToRGB24 +------------------------------------------------------------------------------- +-- | Pack RGBA data into the format need by BMP image data. +packRGBA32ToBGR24 :: Int -- ^ Width of image. -> Int -- ^ Height of image. -> ByteString -- ^ Source bytestring holding the image data. - -> (ByteString, Int) -- output bytestring, and number of pad - -- bytes per line. + -> ByteString -- output bytestring. -packRGBA32ToRGB24 width height str +packRGBA32ToBGR24 width height str | height * width * 4 /= BS.length str = error "Codec.BMP: Image dimensions don't match input data." @@ -120,13 +178,13 @@ in unsafePerformIO $ allocaBytes sizeDest $ \bufDest -> BS.unsafeUseAsCString str $ \bufSrc -> - do packRGBA32ToRGB24' width height padPerLine + do packRGBA32ToBGR24' width height padPerLine (castPtr bufSrc) (castPtr bufDest) bs <- packCStringLen (bufDest, sizeDest) - return (bs, padPerLine) + return bs -packRGBA32ToRGB24' width height pad ptrSrc ptrDest +packRGBA32ToBGR24' width height pad ptrSrc ptrDest = go 0 0 0 0 where go posX posY oSrc oDest @@ -152,4 +210,54 @@ pokeByteOff ptrDest (oDest + 2) red go (posX + 1) posY (oSrc + 4) (oDest + 3) + + +------------------------------------------------------------------------------- +-- | Pack RGBA data into the byte order needed by BMP image data. +packRGBA32ToBGRA32 + :: Int -- ^ Width of image. + -> Int -- ^ Height of image. + -> ByteString -- ^ Source bytestring holding the image data. + -> ByteString + +packRGBA32ToBGRA32 width height str + | height * width * 4 /= BS.length str + = error "Codec.BMP: Image dimensions don't match input data." + + | otherwise + = let sizeDest = height * (width * 4) + in unsafePerformIO + $ allocaBytes sizeDest $ \bufDest -> + BS.unsafeUseAsCString str $ \bufSrc -> + do packRGBA32ToBGRA32' width height + (castPtr bufSrc) (castPtr bufDest) + bs <- packCStringLen (bufDest, sizeDest) + return bs + +packRGBA32ToBGRA32' width height ptrSrc ptrDest + = go 0 0 0 0 + where + go posX posY oSrc oDest + + -- advance to the next line. + | posX == width + = do go 0 (posY + 1) oSrc oDest + + -- we've finished the image. + | posY == height + = return () + + -- process a pixel + | otherwise + = do red :: Word8 <- peekByteOff ptrSrc (oSrc + 0) + green :: Word8 <- peekByteOff ptrSrc (oSrc + 1) + blue :: Word8 <- peekByteOff ptrSrc (oSrc + 2) + alpha :: Word8 <- peekByteOff ptrSrc (oSrc + 3) + + pokeByteOff ptrDest (oDest + 0) blue + pokeByteOff ptrDest (oDest + 1) green + pokeByteOff ptrDest (oDest + 2) red + pokeByteOff ptrDest (oDest + 3) alpha + + go (posX + 1) posY (oSrc + 4) (oDest + 4) diff --git a/Codec/BMP/Unpack.hs b/Codec/BMP/Unpack.hs --- a/Codec/BMP/Unpack.hs +++ b/Codec/BMP/Unpack.hs @@ -1,5 +1,4 @@ {-# OPTIONS_HADDOCK hide #-} -{-# LANGUAGE ScopedTypeVariables #-} module Codec.BMP.Unpack (unpackBMPToRGBA32) where @@ -101,7 +100,6 @@ 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. @@ -124,6 +122,7 @@ 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. diff --git a/bmp.cabal b/bmp.cabal --- a/bmp.cabal +++ b/bmp.cabal @@ -1,5 +1,5 @@ Name: bmp -Version: 1.2.4.1 +Version: 1.2.5.1 License: MIT License-file: LICENSE Author: Ben Lippmeier @@ -30,6 +30,8 @@ extensions: BangPatterns + ScopedTypeVariables + PatternGuards exposed-modules: Codec.BMP