diff --git a/Codec/BMP/BitmapInfo.hs b/Codec/BMP/BitmapInfo.hs --- a/Codec/BMP/BitmapInfo.hs +++ b/Codec/BMP/BitmapInfo.hs @@ -9,7 +9,7 @@ import Data.Binary import Data.Binary.Get --- Image Headers -------------------------------------------------------------- + -- | A wrapper for the various image header types. -- data BitmapInfo diff --git a/Codec/BMP/BitmapInfoV3.hs b/Codec/BMP/BitmapInfoV3.hs --- a/Codec/BMP/BitmapInfoV3.hs +++ b/Codec/BMP/BitmapInfoV3.hs @@ -12,8 +12,10 @@ import Data.Binary import Data.Binary.Get import Data.Binary.Put +import Data.Int import Debug.Trace + -- | Device Independent Bitmap (DIB) header for Windows V3. data BitmapInfoV3 = BitmapInfoV3 @@ -26,6 +28,10 @@ -- | (+8) Height of the image, in pixels. , dib3Height :: Word32 + -- | If the height field in the file is negative then this is interpreted + -- as an image with the rows flipped. + , dib3HeightFlipped :: Bool + -- | (+12) Number of color planes. , dib3Planes :: Word16 @@ -65,9 +71,19 @@ instance Binary BitmapInfoV3 where get - = do size <- getWord32le - width <- getWord32le - height <- getWord32le + = do size <- getWord32le + width <- getWord32le + + -- We're supposed to treat the height field as a signed integer. + -- If it's negative it means the image is flipped along the X axis. + -- (which is crazy, but we just have to eat it) + heightW32 <- getWord32le + let heightI32 = (fromIntegral heightW32 :: Int32) + let (height, flipped) + = if heightI32 < 0 + then (fromIntegral (abs heightI32), True) + else (heightW32, False) + planes <- getWord16le bitc <- getWord16le comp <- get @@ -81,6 +97,7 @@ { dib3Size = size , dib3Width = width , dib3Height = height + , dib3HeightFlipped = flipped , dib3Planes = planes , dib3BitCount = bitc , dib3Compression = comp @@ -132,7 +149,8 @@ -- in the header, because some encoders add padding to the end. | Just calculatedImageSize <- imageSizeFromBitmapInfoV3 header , fromIntegral physicalBufferSize < calculatedImageSize - = Just $ ErrorImageDataTruncated + = trace (show header) + $ Just $ ErrorImageDataTruncated calculatedImageSize (fromIntegral physicalBufferSize) diff --git a/Codec/BMP/BitmapInfoV4.hs b/Codec/BMP/BitmapInfoV4.hs --- a/Codec/BMP/BitmapInfoV4.hs +++ b/Codec/BMP/BitmapInfoV4.hs @@ -14,6 +14,7 @@ import Data.Binary.Get import Data.Binary.Put + -- | Device Independent Bitmap (DIB) header for Windows V4 (95 and newer) data BitmapInfoV4 = BitmapInfoV4 @@ -126,7 +127,6 @@ -- Check for valid compression modes ---- - -- uncompressed 32bit RGBA stated as CompressionRGB. | dib3BitCount headerV3 == 32 , dib3Compression headerV3 == CompressionRGB @@ -191,3 +191,4 @@ = Nothing where headerV3 = dib4InfoV3 headerV4 + diff --git a/Codec/BMP/CIEXYZ.hs b/Codec/BMP/CIEXYZ.hs --- a/Codec/BMP/CIEXYZ.hs +++ b/Codec/BMP/CIEXYZ.hs @@ -7,6 +7,7 @@ import Data.Binary.Get import Data.Binary.Put + -- | Contains the XYZ coordinates of a specific color in a specified color -- space. data CIEXYZ diff --git a/Codec/BMP/Compression.hs b/Codec/BMP/Compression.hs --- a/Codec/BMP/Compression.hs +++ b/Codec/BMP/Compression.hs @@ -8,6 +8,7 @@ import Data.Binary.Put +-- | The Compression mode says how the image data is encoded in the file. data Compression = CompressionRGB | CompressionRLE8 diff --git a/Codec/BMP/Error.hs b/Codec/BMP/Error.hs --- a/Codec/BMP/Error.hs +++ b/Codec/BMP/Error.hs @@ -5,9 +5,9 @@ import Codec.BMP.Compression import Data.Word + -- | Things that can go wrong when loading a BMP file. data Error - -- | Magic number was not at the start of the file, -- so this probably isn't a BMP file. = ErrorBadMagic diff --git a/Codec/BMP/FileHeader.hs b/Codec/BMP/FileHeader.hs --- a/Codec/BMP/FileHeader.hs +++ b/Codec/BMP/FileHeader.hs @@ -12,7 +12,6 @@ import Data.Binary.Put --- File Headers --------------------------------------------------------------- -- | BMP file header. data FileHeader = FileHeader @@ -33,9 +32,11 @@ } deriving (Show) + -- | Size of a file header (in bytes). sizeOfFileHeader :: Int sizeOfFileHeader = 14 + -- | Magic number that should come at the start of a BMP file. bmpMagic :: Word16 diff --git a/Codec/BMP/Pack.hs b/Codec/BMP/Pack.hs --- a/Codec/BMP/Pack.hs +++ b/Codec/BMP/Pack.hs @@ -17,20 +17,32 @@ import Data.ByteString.Unsafe as BS import Prelude as P + -- | Pack a string of RGBA component values into a BMP image. --- 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. +-- +-- * 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. +-- packRGBA32ToBMP - :: Int -- ^ Width of image. - -> Int -- ^ Height of image. + :: 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 + = error "Codec.BMP: Negative width field." + + | height < 0 + = error "Codec.BMP: Negative height field." + | height * width * 4 /= BS.length str - = error "Codec.BMP.packRGBAToBMP: given image dimensions don't match input data." + = error "Codec.BMP: Image dimensions don't match input data." | otherwise = let (imageData, _) = packRGBA32ToRGB24 width height str @@ -39,18 +51,22 @@ = FileHeader { fileHeaderType = bmpMagic - , fileHeaderFileSize = fromIntegral - $ sizeOfFileHeader + sizeOfBitmapInfoV3 + BS.length imageData + , fileHeaderFileSize + = fromIntegral + $ sizeOfFileHeader + sizeOfBitmapInfoV3 + + BS.length imageData , fileHeaderReserved1 = 0 , fileHeaderReserved2 = 0 - , fileHeaderOffset = fromIntegral (sizeOfFileHeader + sizeOfBitmapInfoV3) } + , fileHeaderOffset + = fromIntegral (sizeOfFileHeader + sizeOfBitmapInfoV3)} bitmapInfoV3 = BitmapInfoV3 { dib3Size = fromIntegral sizeOfBitmapInfoV3 , dib3Width = fromIntegral width , dib3Height = fromIntegral height + , dib3HeightFlipped = False , dib3Planes = 1 , dib3BitCount = 24 , dib3Compression = CompressionRGB @@ -65,9 +81,12 @@ , dib3ColorsUsed = 0 , dib3ColorsImportant = 0 } + -- We might as well check to see if we've made a well-formed BMP file. + -- It would be sad if we couldn't read a file we just wrote. errs = catMaybes [ checkFileHeader fileHeader - , checkBitmapInfoV3 bitmapInfoV3 (fromIntegral $ BS.length imageData)] + , checkBitmapInfoV3 bitmapInfoV3 + (fromIntegral $ BS.length imageData)] in case errs of [] -> BMP @@ -75,19 +94,21 @@ , bmpBitmapInfo = InfoV3 bitmapInfoV3 , bmpRawImageData = imageData } - _ -> error $ "Codec.BMP: packRGBA32ToBMP constructed BMP file has errors, sorry.\n" ++ show errs + _ -> error $ "Codec.BMP: Constructed BMP file has errors, sorry." + ++ show errs packRGBA32ToRGB24 - :: Int -- ^ Width of image. - -> Int -- ^ Height of image. - -> ByteString - -> (ByteString, Int) -- output bytestring, and number of pad bytes per line. + :: 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. packRGBA32ToRGB24 width height str | height * width * 4 /= BS.length str - = error "Codec.BMP.packRGBAToRGB24: given image dimensions don't match input data." + = error "Codec.BMP: Image dimensions don't match input data." | otherwise = let padPerLine @@ -122,9 +143,8 @@ -- process a pixel | otherwise - = do - red :: Word8 <- peekByteOff ptrSrc (oSrc + 0) - green :: Word8 <- peekByteOff ptrSrc (oSrc + 1) + = do red :: Word8 <- peekByteOff ptrSrc (oSrc + 0) + green :: Word8 <- peekByteOff ptrSrc (oSrc + 1) blue :: Word8 <- peekByteOff ptrSrc (oSrc + 2) pokeByteOff ptrDest (oDest + 0) blue @@ -132,5 +152,4 @@ pokeByteOff ptrDest (oDest + 2) red go (posX + 1) posY (oSrc + 4) (oDest + 3) - diff --git a/Codec/BMP/Unpack.hs b/Codec/BMP/Unpack.hs --- a/Codec/BMP/Unpack.hs +++ b/Codec/BMP/Unpack.hs @@ -22,11 +22,12 @@ = 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 (bmpRawImageData bmp) - 32 -> packRGB32ToRGBA32 width height (bmpRawImageData bmp) - _ -> error "Codec.BMP.unpackBMPToRGBA32: unhandled bitcount." + 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 @@ -34,53 +35,70 @@ -- -- The alpha component is set to 255 for every pixel. packRGB24ToRGBA32 - :: Int -- Width of image. - -> Int -- Height of image. - -> ByteString -- Input string. + :: Int -- ^ Width of image. + -> Int -- ^ Height of image. + -> Bool -- ^ Image data is flipped along the X axis. + -> ByteString -- ^ Input string. -> ByteString -packRGB24ToRGBA32 width height str - = let bytesPerLine = BS.length str `div` height - padPerLine = bytesPerLine - width * 3 +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 * (width * 3 + padPerLine) - then error "Codec.BMP.unpackRGB24ToRGBA32: image data is truncated." + 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 padPerLine + 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 pad ptrSrc ptrDest - = go 0 0 0 0 +packRGB24ToRGBA32' width height flipX srcBytesPerLine ptrSrc ptrDst + = go 0 where - go posX posY oSrc oDest - -- skip over padding bytes at the end of each line. + 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 0 (posY + 1) (oSrc + pad) oDest - - -- we've finished the image. - | posY == height - = return () - + = 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 ptrDest (oDest + 0) red - pokeByteOff ptrDest (oDest + 1) green - pokeByteOff ptrDest (oDest + 2) blue - pokeByteOff ptrDest (oDest + 3) (255 :: Word8) + pokeByteOff ptrDst (oDst + 0) red + pokeByteOff ptrDst (oDst + 1) green + pokeByteOff ptrDst (oDst + 2) blue + pokeByteOff ptrDst (oDst + 3) (255 :: Word8) - go (posX + 1) posY (oSrc + 3) (oDest + 4) + go_line (posX + 1) posY (oSrc + 3) (oDst + 4) @@ -89,35 +107,50 @@ -- 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. + :: Int -- ^ Width of image. + -> Int -- ^ Height of image. + -> Bool -- ^ Image data is flipped along the X axis. + -> ByteString -- ^ Input string. -> ByteString -packRGB32ToRGBA32 width height str +packRGB32ToRGBA32 width height flipX str = let sizeDest = height * width * 4 in if BS.length str < sizeDest - then error "Codec.BMP.packRGB24ToRGBA32: image data is truncated." + 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 ptrSrc ptrDest - = go 0 0 0 0 +packRGB32ToRGBA32' width height flipX ptrSrc ptrDst + = go 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 + 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 - -- we've finished the image. - | posY == height - = return () + -- 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 @@ -126,10 +159,10 @@ 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 + pokeByteOff ptrDst (oDst + 0) red + pokeByteOff ptrDst (oDst + 1) green + pokeByteOff ptrDst (oDst + 2) blue + pokeByteOff ptrDst (oDst + 3) alpha - go (posX + 1) posY (oSrc + 4) (oDest + 4) + go_line (posX + 1) posY (oSrc + 4) (oDst + 4) diff --git a/bmp.cabal b/bmp.cabal --- a/bmp.cabal +++ b/bmp.cabal @@ -1,5 +1,5 @@ Name: bmp -Version: 1.2.3.2 +Version: 1.2.3.3 License: MIT License-file: LICENSE Author: Ben Lippmeier @@ -12,14 +12,15 @@ Bug-reports: bmp@ouroborus.net Description: Read and write uncompressed BMP image files. 100% robust Haskell implementation. - Synopsis: Read and write uncompressed BMP image files. -Tested-with: GHC == 7.2 +source-repository head + type: darcs + location: http://code.ouroborus.net/bmp-head Library - Build-Depends: + build-Depends: base == 4.*, bytestring == 0.10.*, binary == 0.5.* @@ -27,10 +28,13 @@ ghc-options: -Wall -fno-warn-missing-signatures - Exposed-modules: + extensions: + BangPatterns + + exposed-modules: Codec.BMP - Other-modules: + other-modules: Codec.BMP.Base Codec.BMP.Compression Codec.BMP.BitmapInfo