bmp (empty) → 1.0.0.0
raw patch · 10 files changed
+676/−0 lines, 10 filesdep +QuickCheckdep +basedep +binarysetup-changed
Dependencies added: QuickCheck, base, binary, bytestring
Files
- Codec/BMP.hs +126/−0
- Codec/BMP/Base.hs +23/−0
- Codec/BMP/BitmapInfo.hs +148/−0
- Codec/BMP/Error.hs +24/−0
- Codec/BMP/FileHeader.hs +89/−0
- Codec/BMP/Pack.hs +132/−0
- Codec/BMP/Unpack.hs +78/−0
- LICENSE +13/−0
- Setup.hs +2/−0
- bmp.cabal +41/−0
+ Codec/BMP.hs view
@@ -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)+
+ Codec/BMP/Base.hs view
@@ -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+++++
+ Codec/BMP/BitmapInfo.hs view
@@ -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+++ + + + +
+ Codec/BMP/Error.hs view
@@ -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)+
+ Codec/BMP/FileHeader.hs view
@@ -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
+ Codec/BMP/Pack.hs view
@@ -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)++
+ Codec/BMP/Unpack.hs view
@@ -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)+++
+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ bmp.cabal view
@@ -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+