diff --git a/Codec/BMP.hs b/Codec/BMP.hs new file mode 100644 --- /dev/null +++ b/Codec/BMP.hs @@ -0,0 +1,126 @@ +{-# LANGUAGE ScopedTypeVariables, PatternGuards #-} + +-- | Reading and writing uncompressed 24 bit BMP files. +-- We only handle Windows V3 file headers, but this is the most common. +-- +-- To write a file do something like: +-- +-- > do let rgba = Data.ByteString.pack [some list of Word8s] +-- > let bmp = packRGBA32ToBMP width height rgba +-- > writeBMP fileName bmp +-- +-- To read a file do something like: +-- +-- > do Right bmp <- readBMP fileName +-- > let rgba = unpackBMPToRGBA32 bmp +-- > let (width, height) = bmpDimensions bmp +-- > ... +-- +module Codec.BMP + ( BMP (..) + , FileHeader (..) + , BitmapInfo (..) + , BitmapInfoV3 (..) + , Error (..) + , readBMP + , writeBMP + , hGetBMP + , hPutBMP + , packRGBA32ToBMP + , unpackBMPToRGBA32 + , bmpDimensions) +where +import Codec.BMP.Base +import Codec.BMP.Error +import Codec.BMP.Unpack +import Codec.BMP.Pack +import Codec.BMP.FileHeader +import Codec.BMP.BitmapInfo +import Data.Binary +import Data.Maybe +import System.IO +import Data.ByteString as BS +import Data.ByteString.Lazy as BSL + +-- Reading ---------------------------------------------------------------------------------------- +-- | Wrapper for `hGetBMP` +readBMP :: FilePath -> IO (Either Error BMP) +readBMP fileName + = do h <- openBinaryFile fileName ReadMode + hGetBMP h + +-- | Get a BMP image from a file handle. +-- The file is checked for problems and unsupported features when read. +-- If there is anything wrong this gives an `Error` instead. +hGetBMP :: Handle -> IO (Either Error BMP) +hGetBMP h + = do -- load the file header. + buf <- BSL.hGet h sizeOfFileHeader + if (fromIntegral $ BSL.length buf) /= sizeOfFileHeader + then return $ Left ErrorReadOfFileHeaderFailed + else hGetBMP2 h (decode buf) + + +hGetBMP2 h fileHeader + -- Check the magic before doing anything else. + -- If the specified file is not a BMP file then we'd prefer to get + -- this error than a `ReadOfImageHeaderFailed`. + | fileHeaderType fileHeader /= bmpMagic + = return $ Left $ ErrorBadMagic (fileHeaderType fileHeader) + + | otherwise + = do -- load the image header. + buf <- BSL.hGet h sizeOfBitmapInfoV3 + if (fromIntegral $ BSL.length buf) /= sizeOfBitmapInfoV3 + then return $ Left ErrorReadOfImageHeaderFailed + else hGetBMP3 h fileHeader (decode buf) + +hGetBMP3 h fileHeader imageHeader + | (err : _) <- catMaybes + [ checkFileHeader fileHeader + , checkBitmapInfoV3 imageHeader] + = return $ Left err + + | otherwise + = do -- load the image data. + let len = fromIntegral $ dib3ImageSize imageHeader + imageData <- BS.hGet h len + + if (fromIntegral $ BS.length imageData) /= len + then return $ Left ErrorReadOfImageDataFailed + else return + $ Right $ BMP + { bmpFileHeader = fileHeader + , bmpBitmapInfo = InfoV3 imageHeader + , bmpRawImageData = imageData } + + +-- Writing ---------------------------------------------------------------------------------------- + +-- | Wrapper for `hPutBMP` +writeBMP :: FilePath -> BMP -> IO () +writeBMP fileName bmp + = do h <- openBinaryFile fileName WriteMode + hPutBMP h bmp + hFlush h + + +-- | 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) + BSL.hPut h (encode $ bmpBitmapInfo bmp) + BS.hPut h $ bmpRawImageData bmp + + +-- | 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) + diff --git a/Codec/BMP/Base.hs b/Codec/BMP/Base.hs new file mode 100644 --- /dev/null +++ b/Codec/BMP/Base.hs @@ -0,0 +1,23 @@ +{-# OPTIONS_HADDOCK hide #-} +module Codec.BMP.Base + (BMP (..)) +where +import Codec.BMP.FileHeader +import Codec.BMP.BitmapInfo +import Data.ByteString + +-- | A BMP image. +-- For an uncompressed image, the image data contains triples of BGR component values. +-- Each line may also have zero pad values on the end, to bring them up to a multiple +-- of 4 bytes in length. +data BMP + = BMP + { bmpFileHeader :: FileHeader + , bmpBitmapInfo :: BitmapInfo + , bmpRawImageData :: ByteString } + deriving Show + + + + + diff --git a/Codec/BMP/BitmapInfo.hs b/Codec/BMP/BitmapInfo.hs new file mode 100644 --- /dev/null +++ b/Codec/BMP/BitmapInfo.hs @@ -0,0 +1,148 @@ +{-# OPTIONS_HADDOCK hide #-} +module Codec.BMP.BitmapInfo + ( BitmapInfo (..) + , BitmapInfoV3 (..) + , sizeOfBitmapInfoV3 + , checkBitmapInfoV3) + +where +import Codec.BMP.Error +import Data.Binary +import Data.Binary.Get +import Data.Binary.Put + +-- Image Headers ---------------------------------------------------------------------------------- +-- | A wrapper for the bitmap info, +-- in case we want to support other header types in the future. +data BitmapInfo + = InfoV3 BitmapInfoV3 + 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 + + -- | Height of the image, in pixels. + , dib3Height :: Word32 + + -- | 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 + + | dib3ImageSize header `mod` dib3Height header /= 0 + = Just $ ErrorLacksWholeNumberOfLines + + | otherwise + = Nothing + + + + + + + diff --git a/Codec/BMP/Error.hs b/Codec/BMP/Error.hs new file mode 100644 --- /dev/null +++ b/Codec/BMP/Error.hs @@ -0,0 +1,24 @@ +{-# OPTIONS_HADDOCK hide #-} +module Codec.BMP.Error + (Error(..)) +where +import Data.Word + +-- | Things that can go wrong when loading a BMP file. +data Error + = ErrorReadOfFileHeaderFailed + | ErrorReadOfImageHeaderFailed + | ErrorReadOfImageDataFailed + | ErrorBadMagic Word16 + | ErrorReservedFieldNotZero + | ErrorDodgyFileHeaderFieldOffset Int + | ErrorDodgyFileHeaderFieldFileSize Int + | ErrorFileIsTruncated + | ErrorUnhandledBitmapHeaderSize Int + | ErrorUnhandledPlanesCount Int + | ErrorUnhandledColorDepth Int + | ErrorUnhandledCompressionMode Int + | ErrorZeroImageSize + | ErrorLacksWholeNumberOfLines + deriving (Eq, Show) + diff --git a/Codec/BMP/FileHeader.hs b/Codec/BMP/FileHeader.hs new file mode 100644 --- /dev/null +++ b/Codec/BMP/FileHeader.hs @@ -0,0 +1,89 @@ +{-# OPTIONS_HADDOCK hide #-} +module Codec.BMP.FileHeader + ( FileHeader (..) + , bmpMagic + , sizeOfFileHeader + , checkFileHeader) +where +import Codec.BMP.BitmapInfo +import Codec.BMP.Error +import Data.Binary +import Data.Binary.Get +import Data.Binary.Put + +-- File Headers ----------------------------------------------------------------------------------- +-- | BMP file header. +data FileHeader + = FileHeader + { -- | Magic numbers 0x42 0x4d + fileHeaderType :: Word16 + + -- | Size of the file, in bytes. + , fileHeaderFileSize :: Word32 + + -- | Reserved, must be zero. + , fileHeaderReserved1 :: Word16 + + -- | Reserved, must be zero. + , fileHeaderReserved2 :: Word16 + + -- | Offset in bytes to the start of the pixel data. + , fileHeaderOffset :: Word32 + } + 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 +bmpMagic = 0x4d42 + + +instance Binary FileHeader where + get + = do t <- getWord16le + size <- getWord32le + res1 <- getWord16le + res2 <- getWord16le + offset <- getWord32le + + return $ FileHeader + { fileHeaderType = t + , fileHeaderFileSize = size + , fileHeaderReserved1 = res1 + , fileHeaderReserved2 = res2 + , fileHeaderOffset = offset } + + put header + = do putWord16le $ fileHeaderType header + putWord32le $ fileHeaderFileSize header + putWord16le $ fileHeaderReserved1 header + putWord16le $ fileHeaderReserved2 header + putWord32le $ fileHeaderOffset header + + +-- | Check a file header for problems and unsupported features. +checkFileHeader :: FileHeader -> Maybe Error +checkFileHeader header + | fileHeaderType header /= bmpMagic + = Just $ ErrorBadMagic (fileHeaderType header) + + | fileHeaderFileSize header + < fromIntegral (sizeOfFileHeader + sizeOfBitmapInfoV3) + = Just $ ErrorDodgyFileHeaderFieldFileSize + $ fromIntegral $ fileHeaderFileSize header + + | fileHeaderReserved1 header /= 0 + = Just $ ErrorReservedFieldNotZero + + | fileHeaderReserved2 header /= 0 + = Just $ ErrorReservedFieldNotZero + + | fromIntegral (fileHeaderOffset header) /= sizeOfFileHeader + sizeOfBitmapInfoV3 + = Just $ ErrorDodgyFileHeaderFieldOffset + $ fromIntegral $ fileHeaderOffset header + + | otherwise + = Nothing diff --git a/Codec/BMP/Pack.hs b/Codec/BMP/Pack.hs new file mode 100644 --- /dev/null +++ b/Codec/BMP/Pack.hs @@ -0,0 +1,132 @@ +{-# OPTIONS_HADDOCK hide #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Codec.BMP.Pack + (packRGBA32ToBMP) +where +import Codec.BMP.Base +import Codec.BMP.BitmapInfo +import Codec.BMP.FileHeader +import Foreign.Ptr +import Foreign.Marshal.Alloc +import Foreign.Storable +import System.IO.Unsafe +import Data.Word +import Data.Maybe +import Data.ByteString as BS +import Data.ByteString.Unsafe as BS +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`. +packRGBA32ToBMP + :: Int -- ^ Width of image. + -> Int -- ^ Height of image. + -> ByteString -- ^ A string of RGBA component values. Must have length (@width * height * 4@) + -> BMP + +packRGBA32ToBMP width height str + | height * width * 4 /= BS.length str + = error "Codec.BMP.packRGBAToBMP: given image dimensions don't match input data." + + | otherwise + = let (imageData, _) = packRGBA32ToRGB24 width height str + + fileHeader + = FileHeader + { fileHeaderType = bmpMagic + + , fileHeaderFileSize = fromIntegral + $ sizeOfFileHeader + sizeOfBitmapInfoV3 + BS.length imageData + + , fileHeaderReserved1 = 0 + , fileHeaderReserved2 = 0 + , fileHeaderOffset = fromIntegral (sizeOfFileHeader + sizeOfBitmapInfoV3) } + + bitmapInfoV3 + = BitmapInfoV3 + { dib3Size = fromIntegral sizeOfBitmapInfoV3 + , dib3Width = fromIntegral width + , dib3Height = fromIntegral height + , dib3Planes = 1 + , dib3BitCount = 24 + , dib3Compression = 0 + , dib3ImageSize = fromIntegral $ BS.length imageData + + -- The default resolution seems to be 72 pixels per inch. + -- This equates to 2834 pixels per meter. + -- Dunno WTF this should be in the header though... + , dib3PelsPerMeterX = 2834 + , dib3PelsPerMeterY = 2834 + + , dib3ColorsUsed = 0 + , dib3ColorsImportant = 0 } + + errs = catMaybes + [ checkFileHeader fileHeader + , checkBitmapInfoV3 bitmapInfoV3 ] + + in case errs of + [] -> BMP + { bmpFileHeader = fileHeader + , bmpBitmapInfo = InfoV3 bitmapInfoV3 + , bmpRawImageData = imageData } + + _ -> error $ "Codec.BMP: packRGBA32ToBMP constructed BMP file has errors, sorry.\n" ++ show errs + + + +packRGBA32ToRGB24 + :: Int -- ^ Width of image. + -> Int -- ^ Height of image. + -> ByteString + -> (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." + + | otherwise + = let padPerLine + = case (width * 3) `mod` 4 of + 0 -> 0 + x -> 4 - x + + sizeDest = height * (width * 3 + padPerLine) + in unsafePerformIO + $ allocaBytes sizeDest $ \bufDest -> + BS.unsafeUseAsCString str $ \bufSrc -> + do packRGBA32ToRGB24' width height padPerLine (castPtr bufSrc) (castPtr bufDest) + bs <- packCStringLen (bufDest, sizeDest) + return (bs, padPerLine) + + +packRGBA32ToRGB24' width height pad ptrSrc ptrDest + = go 0 0 0 0 + where + go posX posY oSrc oDest + + -- add padding bytes at the end of each line. + | posX == width + = do mapM_ (\n -> pokeByteOff ptrDest (oDest + n) (0 :: Word8)) + $ P.take pad [0 .. ] + go 0 (posY + 1) oSrc (oDest + pad) + + -- 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) + + pokeByteOff ptrDest (oDest + 0) blue + pokeByteOff ptrDest (oDest + 1) green + 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 new file mode 100644 --- /dev/null +++ b/Codec/BMP/Unpack.hs @@ -0,0 +1,78 @@ +{-# OPTIONS_HADDOCK hide #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Codec.BMP.Unpack + (unpackBMPToRGBA32) +where +import Codec.BMP.Base +import Codec.BMP.BitmapInfo +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. +-- 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) + + +-- | 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. + -> ByteString -- Input string. + -> ByteString + +packRGB24ToRGBA32 width height str + = let bytesPerLine = BS.length str `div` height + padPerLine = bytesPerLine - width * 3 + sizeDest = width * height * 4 + in if height * (width * 3 + padPerLine) /= 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 packRGB24ToRGBA32' width height padPerLine (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 + where + go posX posY oSrc oDest + -- skip over padding bytes at the end of each line. + | posX == width + = go 0 (posY + 1) (oSrc + pad) 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) + + 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) + + + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,13 @@ +Copyright (c) 2010 Benjamin Lippmeier + + Permission is hereby granted, free of charge, to any person + obtaining a copy of this software and associated documentation + files (the "Software"), to deal in the Software without + restriction, including without limitation the rights to use, + copy, modify, merge, publish, distribute, sublicense, and/or sell + copies of the Software, and to permit persons to whom the + Software is furnished to do so, subject to the following + condition: + + The above copyright notice and this permission notice shall be + included in all copies or substantial portions of the Software. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/bmp.cabal b/bmp.cabal new file mode 100644 --- /dev/null +++ b/bmp.cabal @@ -0,0 +1,41 @@ +Name: bmp +Version: 1.0.0.0 +License: MIT +License-file: LICENSE +Author: Ben Lippmeier +Maintainer: benl@ouroborus.net +Build-Type: Simple +Cabal-Version: >=1.6 +Stability: stable +Category: Codec +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. + +Synopsis: + Read and write uncompressed 24bit BMP image files. + +Tested-with: GHC == 6.12.1 + +Library + Build-Depends: + base >= 4 && < 5, + bytestring >= 0.9.1.5 && < 1.0.0.0, + binary >= 0.5.0.2 && < 0.6.0.0, + QuickCheck >= 2.1.0.3 && < 2.2.0.0 + + ghc-options: + -Wall -fno-warn-missing-signatures -fno-warn-missing-fields + + Exposed-modules: + Codec.BMP + + Other-modules: + Codec.BMP.Base + Codec.BMP.BitmapInfo + Codec.BMP.Error + Codec.BMP.FileHeader + Codec.BMP.Pack + Codec.BMP.Unpack +