diff --git a/Codec/BMP.hs b/Codec/BMP.hs --- a/Codec/BMP.hs +++ b/Codec/BMP.hs @@ -1,8 +1,14 @@ {-# LANGUAGE ScopedTypeVariables, PatternGuards #-} --- | Reading and writing uncompressed 24 bit BMP files. --- We only handle Windows V3 file headers, but this is the most common. +-- | Reading and writing uncompressed BMP files. -- +-- Reading works for both uncompressed 24bit RGB WindowsV3 and 32bit RGBA WindowsV4 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. +-- -- To write a file do something like: -- -- > do let rgba = Data.ByteString.pack [some list of Word8s] @@ -15,13 +21,19 @@ -- > let rgba = unpackBMPToRGBA32 bmp -- > let (width, height) = bmpDimensions bmp -- > ... --- +-- +-- +-- module Codec.BMP - ( BMP (..) - , FileHeader (..) - , BitmapInfo (..) - , BitmapInfoV3 (..) - , Error (..) + ( BMP (..) + , FileHeader (..) + , BitmapInfo (..) + , BitmapInfoV3 (..) + , BitmapInfoV4 (..) + , BitmapInfoV5 (..) + , Compression (..) + , CIEXYZ (..) + , Error (..) , readBMP , writeBMP , hGetBMP @@ -36,11 +48,14 @@ import Codec.BMP.Pack import Codec.BMP.FileHeader import Codec.BMP.BitmapInfo -import Data.Binary -import Data.Maybe +import Codec.BMP.BitmapInfoV3 +import Codec.BMP.BitmapInfoV4 +import Codec.BMP.BitmapInfoV5 import System.IO import Data.ByteString as BS import Data.ByteString.Lazy as BSL +import Data.Binary +import Data.Binary.Get -- Reading ---------------------------------------------------------------------------------------- -- | Wrapper for `hGetBMP` @@ -69,34 +84,66 @@ = return $ Left $ ErrorBadMagic (fileHeaderType fileHeader) | otherwise - = do -- load the image header. - buf <- BSL.hGet h sizeOfBitmapInfoV3 - if (fromIntegral $ BSL.length buf) /= sizeOfBitmapInfoV3 + = do -- Next comes the image header. + -- The first word tells us which header format it is. + bufSize <- BSL.hGet h 4 + let sizeHeader = runGet getWord32le bufSize + + -- Load the rest of the image header + let sizeRest = fromIntegral sizeHeader - 4 + bufRest <- BSL.hGet h sizeRest + if (fromIntegral $ BSL.length bufRest) /= sizeRest then return $ Left ErrorReadOfImageHeaderFailed - else hGetBMP3 h fileHeader (decode buf) + else do + let bufHeader = BSL.append bufSize bufRest + hGetBMP3 h fileHeader sizeHeader bufHeader + -hGetBMP3 h fileHeader imageHeader - | (err : _) <- catMaybes - [ checkFileHeader fileHeader - , checkBitmapInfoV3 imageHeader] - = return $ Left err +hGetBMP3 h fileHeader sizeHeader bufHeader + | sizeHeader == 40 + = do let info = decode bufHeader + case checkBitmapInfoV3 info of + Just err -> return $ Left err + Nothing -> hGetBMP4 h fileHeader (InfoV3 info) + (fromIntegral $ dib3ImageSize info) - | otherwise + | sizeHeader == 108 + = do let info = decode bufHeader + case checkBitmapInfoV4 info of + Just err -> return $ Left err + Nothing -> hGetBMP4 h fileHeader (InfoV4 info) + (fromIntegral + $ dib3ImageSize + $ dib4InfoV3 info) + + | sizeHeader == 124 + = do let info = decode bufHeader + case checkBitmapInfoV5 info of + Just err -> return $ Left err + Nothing -> hGetBMP4 h fileHeader (InfoV5 info) + (fromIntegral + $ dib3ImageSize + $ dib4InfoV3 + $ dib5InfoV4 info) + + | otherwise + = return $ Left $ ErrorUnhandledBitmapHeaderSize (fromIntegral sizeHeader) + + +hGetBMP4 h fileHeader imageHeader sizeImage = do -- load the image data. - let len = fromIntegral $ dib3ImageSize imageHeader - imageData <- BS.hGet h len + imageData <- BS.hGet h sizeImage - if (fromIntegral $ BS.length imageData) /= len + if (fromIntegral $ BS.length imageData) /= sizeImage then return $ Left ErrorReadOfImageDataFailed else return $ Right $ BMP { bmpFileHeader = fileHeader - , bmpBitmapInfo = InfoV3 imageHeader + , bmpBitmapInfo = imageHeader , bmpRawImageData = imageData } -- Writing ---------------------------------------------------------------------------------------- - -- | Wrapper for `hPutBMP` writeBMP :: FilePath -> BMP -> IO () writeBMP fileName bmp @@ -106,8 +153,6 @@ -- | Put a BMP image to a file handle. --- The size of the provided image data is checked against the given dimensions. --- If these don't match then `error`. hPutBMP :: Handle -> BMP -> IO () hPutBMP h bmp = do BSL.hPut h (encode $ bmpFileHeader bmp) @@ -118,9 +163,9 @@ -- | Get the width and height of an image. -- It's better to use this function than to access the headers directly. bmpDimensions :: BMP -> (Int, Int) -bmpDimensions bmp - = case bmpBitmapInfo bmp of - InfoV3 info - -> ( fromIntegral $ dib3Width info - , fromIntegral $ dib3Height info) +bmpDimensions bmp + = let info = getBitmapInfoV3 $ bmpBitmapInfo bmp + in ( fromIntegral $ dib3Width info + , fromIntegral $ dib3Height info) + diff --git a/Codec/BMP/BitmapInfo.hs b/Codec/BMP/BitmapInfo.hs --- a/Codec/BMP/BitmapInfo.hs +++ b/Codec/BMP/BitmapInfo.hs @@ -1,145 +1,56 @@ {-# OPTIONS_HADDOCK hide #-} module Codec.BMP.BitmapInfo ( BitmapInfo (..) - , BitmapInfoV3 (..) - , sizeOfBitmapInfoV3 - , checkBitmapInfoV3) - + , getBitmapInfoV3) where -import Codec.BMP.Error +import Codec.BMP.BitmapInfoV3 +import Codec.BMP.BitmapInfoV4 +import Codec.BMP.BitmapInfoV5 import Data.Binary -import Data.Binary.Get -import Data.Binary.Put +import Data.Binary.Get -- Image Headers ---------------------------------------------------------------------------------- --- | A wrapper for the bitmap info, --- in case we want to support other header types in the future. +-- | A wrapper for the various image header types. +-- data BitmapInfo = InfoV3 BitmapInfoV3 + | InfoV4 BitmapInfoV4 + | InfoV5 BitmapInfoV5 deriving (Show) instance Binary BitmapInfo where get - = do info <- get - return $ InfoV3 info - - put (InfoV3 info) - = put info - --- | Device Independent Bitmap (DIB) header for Windows V3. -data BitmapInfoV3 - = BitmapInfoV3 - { -- | Size of the image header, in bytes. - dib3Size :: Word32 - - -- | Width of the image, in pixels. - , dib3Width :: Word32 + = do size <- lookAhead getWord32le + case size of + 40 -> do + info <- get + return $ InfoV3 info + + 108 -> do + info <- get + return $ InfoV4 info + + 124 -> do + info <- get + return $ InfoV5 info + + _ -> error "Codec.BMP.BitmapInfo.get: unhandled header size" - -- | Height of the image, in pixels. - , dib3Height :: Word32 + put xx + = case xx of + InfoV3 info -> put info + InfoV4 info -> put info + InfoV5 info -> put info - -- | Number of color planes. - , dib3Planes :: Word16 - -- | Number of bits per pixel. - , dib3BitCount :: Word16 - - -- | Image compression mode. 0 = uncompressed. - , dib3Compression :: Word32 - - -- | Size of raw image data. - , dib3ImageSize :: Word32 - - -- | Prefered resolution in pixels per meter, along the X axis. - , dib3PelsPerMeterX :: Word32 - - -- | Prefered resolution in pixels per meter, along the Y axis. - , dib3PelsPerMeterY :: Word32 - - -- | Number of color entries that are used. - , dib3ColorsUsed :: Word32 - - -- | Number of significant colors. - , dib3ColorsImportant :: Word32 - } - deriving (Show) - - --- | Size of `BitmapInfoV3` header (in bytes) -sizeOfBitmapInfoV3 :: Int -sizeOfBitmapInfoV3 = 40 - - -instance Binary BitmapInfoV3 where - get - = do size <- getWord32le - width <- getWord32le - height <- getWord32le - planes <- getWord16le - bitc <- getWord16le - comp <- getWord32le - imgsize <- getWord32le - pelsX <- getWord32le - pelsY <- getWord32le - cused <- getWord32le - cimp <- getWord32le - - return $ BitmapInfoV3 - { dib3Size = size - , dib3Width = width - , dib3Height = height - , dib3Planes = planes - , dib3BitCount = bitc - , dib3Compression = comp - , dib3ImageSize = imgsize - , dib3PelsPerMeterX = pelsX - , dib3PelsPerMeterY = pelsY - , dib3ColorsUsed = cused - , dib3ColorsImportant = cimp } - - put header - = do putWord32le $ dib3Size header - putWord32le $ dib3Width header - putWord32le $ dib3Height header - putWord16le $ dib3Planes header - putWord16le $ dib3BitCount header - putWord32le $ dib3Compression header - putWord32le $ dib3ImageSize header - putWord32le $ dib3PelsPerMeterX header - putWord32le $ dib3PelsPerMeterY header - putWord32le $ dib3ColorsUsed header - putWord32le $ dib3ColorsImportant header - - --- | Check headers for problems and unsupported features. -checkBitmapInfoV3 :: BitmapInfoV3 -> Maybe Error -checkBitmapInfoV3 header - - | dib3Size header /= (fromIntegral sizeOfBitmapInfoV3) - = Just $ ErrorUnhandledBitmapHeaderSize - $ fromIntegral $ dib3Size header - - | dib3Planes header /= 1 - = Just $ ErrorUnhandledPlanesCount - $ fromIntegral $ dib3Planes header - - | dib3BitCount header /= 24 - = Just $ ErrorUnhandledColorDepth - $ fromIntegral $ dib3BitCount header - - | dib3Compression header /= 0 - = Just $ ErrorUnhandledCompressionMode - $ fromIntegral $ dib3Compression header - - | dib3ImageSize header == 0 - = Just $ ErrorZeroImageSize +-- | Get the common `BitmapInfoV3` structure from a `BitmapInfo` +getBitmapInfoV3 :: BitmapInfo -> BitmapInfoV3 +getBitmapInfoV3 bi + = case bi of + InfoV3 info -> info + InfoV4 info -> dib4InfoV3 info + InfoV5 info -> dib4InfoV3 $ dib5InfoV4 info - | dib3ImageSize header `mod` dib3Height header /= 0 - = Just $ ErrorLacksWholeNumberOfLines - - | otherwise - = Nothing - diff --git a/Codec/BMP/BitmapInfoV3.hs b/Codec/BMP/BitmapInfoV3.hs new file mode 100644 --- /dev/null +++ b/Codec/BMP/BitmapInfoV3.hs @@ -0,0 +1,157 @@ +{-# LANGUAGE PatternGuards #-} +{-# OPTIONS_HADDOCK hide #-} +module Codec.BMP.BitmapInfoV3 + ( BitmapInfoV3 (..) + , Compression (..) + , sizeOfBitmapInfoV3 + , checkBitmapInfoV3) +where +import Codec.BMP.Error +import Data.Binary +import Data.Binary.Get +import Data.Binary.Put + +-- | Device Independent Bitmap (DIB) header for Windows V3. +data BitmapInfoV3 + = BitmapInfoV3 + { -- | Size of the image header, in bytes. + dib3Size :: Word32 + + -- | Width of the image, in pixels. + , dib3Width :: Word32 + + -- | Height of the image, in pixels. + , dib3Height :: Word32 + + -- | Number of color planes. + , dib3Planes :: Word16 + + -- | Number of bits per pixel. + , dib3BitCount :: Word16 + + -- | Image compression mode. + , dib3Compression :: Compression + + -- | Size of raw image data. + , dib3ImageSize :: Word32 + + -- | Prefered resolution in pixels per meter, along the X axis. + , dib3PelsPerMeterX :: Word32 + + -- | Prefered resolution in pixels per meter, along the Y axis. + , dib3PelsPerMeterY :: Word32 + + -- | Number of color entries that are used. + , dib3ColorsUsed :: Word32 + + -- | Number of significant colors. + , dib3ColorsImportant :: Word32 + } + deriving (Show) + +data Compression + = CompressionRGB + | CompressionRLE8 + | CompressionRLE4 + | CompressionBitFields + | CompressionJPEG + | CompressionPNG + | CompressionUnknown Word32 + deriving (Show, Eq) + + +-- | Size of `BitmapInfoV3` header (in bytes) +sizeOfBitmapInfoV3 :: Int +sizeOfBitmapInfoV3 = 40 + + +instance Binary BitmapInfoV3 where + get + = do size <- getWord32le + width <- getWord32le + height <- getWord32le + planes <- getWord16le + bitc <- getWord16le + comp <- get + imgsize <- getWord32le + pelsX <- getWord32le + pelsY <- getWord32le + cused <- getWord32le + cimp <- getWord32le + + return $ BitmapInfoV3 + { dib3Size = size + , dib3Width = width + , dib3Height = height + , dib3Planes = planes + , dib3BitCount = bitc + , dib3Compression = comp + , dib3ImageSize = imgsize + , dib3PelsPerMeterX = pelsX + , dib3PelsPerMeterY = pelsY + , dib3ColorsUsed = cused + , dib3ColorsImportant = cimp } + + put header + = do putWord32le $ dib3Size header + putWord32le $ dib3Width header + putWord32le $ dib3Height header + putWord16le $ dib3Planes header + putWord16le $ dib3BitCount header + put $ dib3Compression header + putWord32le $ dib3ImageSize header + putWord32le $ dib3PelsPerMeterX header + putWord32le $ dib3PelsPerMeterY header + putWord32le $ dib3ColorsUsed header + putWord32le $ dib3ColorsImportant header + + +instance Binary Compression where + get + = do c <- getWord32le + case c of + 0 -> return $ CompressionRGB + 1 -> return $ CompressionRLE8 + 2 -> return $ CompressionRLE4 + 3 -> return $ CompressionBitFields + 4 -> return $ CompressionJPEG + 5 -> return $ CompressionPNG + _ -> return $ CompressionUnknown c + + put c + = case c of + CompressionRGB -> putWord32le 0 + CompressionRLE8 -> putWord32le 1 + CompressionRLE4 -> putWord32le 2 + CompressionBitFields -> putWord32le 3 + CompressionJPEG -> putWord32le 4 + CompressionPNG -> putWord32le 5 + CompressionUnknown x -> putWord32le x + + +-- | Check headers for problems and unsupported features. +-- With a V3 header we only support the uncompressed 24bit RGB format. +checkBitmapInfoV3 :: BitmapInfoV3 -> Maybe Error +checkBitmapInfoV3 header + + | dib3Planes header /= 1 + = Just $ ErrorUnhandledPlanesCount + $ fromIntegral $ dib3Planes header + + | dib3ImageSize header == 0 + = Just $ ErrorZeroImageSize + + | dib3ImageSize header `mod` dib3Height header /= 0 + = Just $ ErrorLacksWholeNumberOfLines + + | dib3BitCount header /= 24 + = Just $ ErrorUnhandledColorDepth + $ fromIntegral $ dib3BitCount header + + | dib3Compression header /= CompressionRGB + = Just $ ErrorUnhandledCompressionMode + + | otherwise + = Nothing + + diff --git a/Codec/BMP/BitmapInfoV4.hs b/Codec/BMP/BitmapInfoV4.hs new file mode 100644 --- /dev/null +++ b/Codec/BMP/BitmapInfoV4.hs @@ -0,0 +1,130 @@ +{-# LANGUAGE PatternGuards #-} +{-# OPTIONS_HADDOCK hide #-} +module Codec.BMP.BitmapInfoV4 + ( BitmapInfoV4 (..) + , CIEXYZ (..) + , sizeOfBitmapInfoV4 + , checkBitmapInfoV4) +where +import Codec.BMP.Error +import Codec.BMP.CIEXYZ +import Codec.BMP.BitmapInfoV3 +import Data.Binary +import Data.Binary.Get +import Data.Binary.Put + +-- | Device Independent Bitmap (DIB) header for Windows V4 (95 and newer) +data BitmapInfoV4 + = BitmapInfoV4 + { -- | Size of the image header, in bytes. + dib4InfoV3 :: BitmapInfoV3 + + -- | Color masks specify components of each pixel. + -- Only used with the bitfields compression mode. + , dib4RedMask :: Word32 + , dib4GreenMask :: Word32 + , dib4BlueMask :: Word32 + , dib4AlphaMask :: Word32 + + -- | The color space used by the image. + , dib4ColorSpaceType :: Word32 + + -- | Specifies the XYZ coords of the three colors that correspond to the RGB endpoints + -- for the logical color space associated with the bitmap. + -- Only used when ColorSpaceType specifies a calibrated image. + , dib4Endpoints :: (CIEXYZ, CIEXYZ, CIEXYZ) + + -- | Toned response curves for each component. + -- Only used when the ColorSpaceType specifies a calibrated image. + , dib4GammaRed :: Word32 + , dib4GammaGreen :: Word32 + , dib4GammaBlue :: Word32 + } + deriving (Show) + + +-- | Size of `BitmapInfoV4` header (in bytes) +sizeOfBitmapInfoV4 :: Int +sizeOfBitmapInfoV4 = 108 + + +instance Binary BitmapInfoV4 where + get + = do infoV3 <- get + rmask <- getWord32le + gmask <- getWord32le + bmask <- getWord32le + amask <- getWord32le + cstype <- getWord32le + ends <- get + rgamma <- getWord32le + ggamma <- getWord32le + bgamma <- getWord32le + + return $ BitmapInfoV4 + { dib4InfoV3 = infoV3 + , dib4RedMask = rmask + , dib4GreenMask = gmask + , dib4BlueMask = bmask + , dib4AlphaMask = amask + , dib4ColorSpaceType = cstype + , dib4Endpoints = ends + , dib4GammaRed = rgamma + , dib4GammaGreen = ggamma + , dib4GammaBlue = bgamma } + + + put header + = do put $ dib4InfoV3 header + putWord32le $ dib4RedMask header + putWord32le $ dib4GreenMask header + putWord32le $ dib4BlueMask header + putWord32le $ dib4AlphaMask header + putWord32le $ dib4ColorSpaceType header + put $ dib4Endpoints header + putWord32le $ dib4GammaRed header + 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, +-- and the uncompressed 32bit RGBA format. +-- +checkBitmapInfoV4 :: BitmapInfoV4 -> Maybe Error +checkBitmapInfoV4 headerV4 + + | dib3Planes headerV3 /= 1 + = Just $ ErrorUnhandledPlanesCount + $ fromIntegral $ dib3Planes headerV3 + + | dib3ImageSize headerV3 == 0 + = Just $ ErrorZeroImageSize + + | dib3ImageSize headerV3 `mod` dib3Height headerV3 /= 0 + = Just $ ErrorLacksWholeNumberOfLines + + -- Check for valid compression modes ---- + + -- uncompressed 24bit RGB + | dib3BitCount headerV3 == 24 + , dib3Compression headerV3 == CompressionRGB + = Nothing + + -- uncompressed 32bit RGBA + | dib3BitCount headerV3 == 32 + , dib3Compression headerV3 == CompressionBitFields + , dib4AlphaMask headerV4 == 0xff000000 + , dib4RedMask headerV4 == 0x00ff0000 + , dib4GreenMask headerV4 == 0x0000ff00 + , dib4BlueMask headerV4 == 0x000000ff + = Nothing + + -- Some unsupported compression mode ---- + | otherwise + = Just $ ErrorUnhandledCompressionMode + + where headerV3 = dib4InfoV3 headerV4 + + diff --git a/Codec/BMP/BitmapInfoV5.hs b/Codec/BMP/BitmapInfoV5.hs new file mode 100644 --- /dev/null +++ b/Codec/BMP/BitmapInfoV5.hs @@ -0,0 +1,68 @@ +{-# OPTIONS_HADDOCK hide #-} +module Codec.BMP.BitmapInfoV5 + ( BitmapInfoV5 (..) + , sizeOfBitmapInfoV5 + , checkBitmapInfoV5) +where +import Codec.BMP.Error +import Codec.BMP.BitmapInfoV4 +import Data.Binary +import Data.Binary.Get +import Data.Binary.Put + + +-- | Device Independent Bitmap (DIB) header for Windows V5 (98/2000 and newer) +data BitmapInfoV5 + = BitmapInfoV5 + { dib5InfoV4 :: BitmapInfoV4 + + -- | Rendering intent for the bitmap. + , dib5Intent :: Word32 + + -- | Offset (in bytes) from the beginning of the header to the start of the profile data. + , dib5ProfileData :: Word32 + + -- | Size (in bytes) of embedded profile data. + , dib5ProfileSize :: Word32 + + -- | Reserved, should be zero. + , dib5Reserved :: Word32 + } + deriving (Show) + +-- | Size of `BitmapInfoV5` header (in bytes) +sizeOfBitmapInfoV5 :: Int +sizeOfBitmapInfoV5 = 124 + + +instance Binary BitmapInfoV5 where + get + = do infoV4 <- get + intent <- getWord32le + pdata <- getWord32le + psize <- getWord32le + res <- getWord32le + + return $ BitmapInfoV5 + { dib5InfoV4 = infoV4 + , dib5Intent = intent + , dib5ProfileData = pdata + , dib5ProfileSize = psize + , dib5Reserved = res } + + + put header + = do put $ dib5InfoV4 header + putWord32le $ dib5Intent header + putWord32le $ dib5ProfileData header + putWord32le $ dib5ProfileSize header + putWord32le $ dib5Reserved header + + +-- | Check headers for problems and unsupported features. +-- The V5 header doesn't give us any more useful info than the V4 one. +checkBitmapInfoV5 :: BitmapInfoV5 -> Maybe Error +checkBitmapInfoV5 header + = checkBitmapInfoV4 $ dib5InfoV4 header + + diff --git a/Codec/BMP/CIEXYZ.hs b/Codec/BMP/CIEXYZ.hs new file mode 100644 --- /dev/null +++ b/Codec/BMP/CIEXYZ.hs @@ -0,0 +1,27 @@ + +module Codec.BMP.CIEXYZ + (CIEXYZ(..)) +where +import Data.Word +import Data.Binary +import Data.Binary.Get +import Data.Binary.Put + +-- | Contains the XYZ coordinates of a specific color in a specified color space. +data CIEXYZ + = CIEXYZ Word32 Word32 Word32 + deriving Show + + +instance Binary CIEXYZ where + get + = do r <- getWord32le + g <- getWord32le + b <- getWord32le + return $ CIEXYZ r g b + + put (CIEXYZ r g b) + = do putWord32le r + putWord32le g + putWord32le b + diff --git a/Codec/BMP/Error.hs b/Codec/BMP/Error.hs --- a/Codec/BMP/Error.hs +++ b/Codec/BMP/Error.hs @@ -17,7 +17,7 @@ | ErrorUnhandledBitmapHeaderSize Int | ErrorUnhandledPlanesCount Int | ErrorUnhandledColorDepth Int - | ErrorUnhandledCompressionMode Int + | ErrorUnhandledCompressionMode | ErrorZeroImageSize | ErrorLacksWholeNumberOfLines deriving (Eq, Show) diff --git a/Codec/BMP/FileHeader.hs b/Codec/BMP/FileHeader.hs --- a/Codec/BMP/FileHeader.hs +++ b/Codec/BMP/FileHeader.hs @@ -5,7 +5,7 @@ , sizeOfFileHeader , checkFileHeader) where -import Codec.BMP.BitmapInfo +import Codec.BMP.BitmapInfoV3 import Codec.BMP.Error import Data.Binary import Data.Binary.Get diff --git a/Codec/BMP/Pack.hs b/Codec/BMP/Pack.hs --- a/Codec/BMP/Pack.hs +++ b/Codec/BMP/Pack.hs @@ -5,6 +5,7 @@ where import Codec.BMP.Base import Codec.BMP.BitmapInfo +import Codec.BMP.BitmapInfoV3 import Codec.BMP.FileHeader import Foreign.Ptr import Foreign.Marshal.Alloc @@ -17,8 +18,8 @@ import Prelude as P -- | Pack a string of RGBA component values into a BMP image. --- The alpha component is ignored. -- If the given dimensions don't match the input string then `error`. +-- This currently ignores the alpha component of the input string and produces a 24bit RGB image. packRGBA32ToBMP :: Int -- ^ Width of image. -> Int -- ^ Height of image. @@ -50,7 +51,7 @@ , dib3Height = fromIntegral height , dib3Planes = 1 , dib3BitCount = 24 - , dib3Compression = 0 + , dib3Compression = CompressionRGB , dib3ImageSize = fromIntegral $ BS.length imageData -- The default resolution seems to be 72 pixels per inch. diff --git a/Codec/BMP/Unpack.hs b/Codec/BMP/Unpack.hs --- a/Codec/BMP/Unpack.hs +++ b/Codec/BMP/Unpack.hs @@ -5,6 +5,7 @@ where import Codec.BMP.Base import Codec.BMP.BitmapInfo +import Codec.BMP.BitmapInfoV3 import Foreign.Ptr import Foreign.Marshal.Alloc import Foreign.Storable @@ -16,15 +17,16 @@ -- | Unpack a BMP image to a string of RGBA component values. --- The alpha component is set to 255 for every pixel. unpackBMPToRGBA32 :: BMP -> ByteString unpackBMPToRGBA32 bmp - = case bmpBitmapInfo bmp of - InfoV3 info - -> packRGB24ToRGBA32 - (fromIntegral $ dib3Width info) - (fromIntegral $ dib3Height info) - (bmpRawImageData 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" -- | Unpack raw, uncompressed 24 bit BMP image data to a string of RGBA component values. @@ -73,6 +75,55 @@ pokeByteOff ptrDest (oDest + 3) (255 :: Word8) go (posX + 1) posY (oSrc + 3) (oDest + 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. + -> ByteString -- Input string. + -> ByteString + +packRGB32ToRGBA32 width height str + = let sizeDest = height * width * 4 + in if sizeDest /= BS.length str + then error "Codec.BMP.unpackRGB24ToRGBA32: given image dimensions don't match input data." + else unsafePerformIO + $ allocaBytes sizeDest $ \bufDest -> + BS.unsafeUseAsCString str $ \bufSrc -> + do packRGB32ToRGBA32' width height (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 ptrSrc ptrDest + = go 0 0 0 0 + where + go posX posY oSrc oDest + -- skip over padding bytes at the end of each line. + | posX == width + = go 0 (posY + 1) oSrc oDest + + -- we've finished the image. + | posY == height + = return () + + -- 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 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) diff --git a/bmp.cabal b/bmp.cabal --- a/bmp.cabal +++ b/bmp.cabal @@ -1,5 +1,5 @@ Name: bmp -Version: 1.0.0.1 +Version: 1.1.0.0 License: MIT License-file: LICENSE Author: Ben Lippmeier @@ -11,10 +11,10 @@ Homepage: http://code.haskell.org/~benl/code/bmp-head Bug-reports: bmp@ouroborus.net Description: - Read and write uncompressed 24bit BMP image files. 100% robust Haskell implementation. + Read and write uncompressed BMP image files. 100% robust Haskell implementation. Synopsis: - Read and write uncompressed 24bit BMP image files. + Read and write uncompressed BMP image files. Tested-with: GHC == 6.12.1 @@ -33,6 +33,10 @@ Other-modules: Codec.BMP.Base Codec.BMP.BitmapInfo + Codec.BMP.BitmapInfoV3 + Codec.BMP.BitmapInfoV4 + Codec.BMP.BitmapInfoV5 + Codec.BMP.CIEXYZ Codec.BMP.Error Codec.BMP.FileHeader Codec.BMP.Pack