bmp-1.2.3.4/0000755000000000000000000000000012063503764010631 5ustar0000000000000000bmp-1.2.3.4/bmp.cabal0000644000000000000000000000235512063503764012400 0ustar0000000000000000Name: bmp Version: 1.2.3.4 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.ouroborus.net/bmp 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. source-repository head type: darcs location: http://code.ouroborus.net/bmp/bmp-head/ Library build-Depends: base == 4.*, bytestring == 0.10.*, binary == 0.5.* ghc-options: -Wall -fno-warn-missing-signatures extensions: BangPatterns exposed-modules: Codec.BMP other-modules: Codec.BMP.Base Codec.BMP.Compression Codec.BMP.BitmapInfo Codec.BMP.BitmapInfoV3 Codec.BMP.BitmapInfoV4 Codec.BMP.BitmapInfoV5 Codec.BMP.CIEXYZ Codec.BMP.Error Codec.BMP.FileHeader Codec.BMP.Pack Codec.BMP.Unpack bmp-1.2.3.4/LICENSE0000644000000000000000000000114112063503764011633 0ustar0000000000000000Copyright (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. bmp-1.2.3.4/Setup.hs0000644000000000000000000000005612063503764012266 0ustar0000000000000000import Distribution.Simple main = defaultMain bmp-1.2.3.4/Codec/0000755000000000000000000000000012063503764011646 5ustar0000000000000000bmp-1.2.3.4/Codec/BMP.hs0000644000000000000000000001515212063503764012624 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables, PatternGuards #-} -- | Reading and writing uncompressed BMP files. -- -- Reading works for both 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. -- -- 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 -- > ... -- -- Release Notes: -- -- > * 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 BMP (..) , FileHeader (..) , BitmapInfo (..) , BitmapInfoV3 (..) , BitmapInfoV4 (..) , BitmapInfoV5 (..) , Compression (..) , CIEXYZ (..) , Error (..) -- * Reading , readBMP, hGetBMP, parseBMP -- * Writing , writeBMP, hPutBMP, renderBMP -- * Pack and Unpack , 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 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 -------------------------------------------------------------------- -- | Read a BMP from a file. -- The file is checked for problems and unsupported features when read. -- If there is anything wrong this gives an `Error` instead. readBMP :: FilePath -> IO (Either Error BMP) readBMP fileName = do h <- openBinaryFile fileName ReadMode hGetBMP h -- | Get a BMP image from a file handle. hGetBMP :: Handle -> IO (Either Error BMP) hGetBMP h = do -- lazily load the whole file buf <- BSL.hGetContents h return $ parseBMP buf -- | Parse a BMP image from a lazy `ByteString` parseBMP :: BSL.ByteString -> Either Error BMP parseBMP buf = let -- split off the file header (bufFileHeader, bufRest) = BSL.splitAt (fromIntegral sizeOfFileHeader) buf in if (fromIntegral $ BSL.length bufFileHeader) /= sizeOfFileHeader then Left ErrorFileHeaderTruncated else parseBMP2 bufRest (decode bufFileHeader) parseBMP2 buf fileHeader -- Check the magic before doing anything else. | fileHeaderType fileHeader /= bmpMagic = Left $ ErrorBadMagic (fileHeaderType fileHeader) | otherwise = let -- Next comes the image header. -- The first word tells us how long it is. sizeHeader = runGet getWord32le buf -- split off the image header (bufImageHeader, bufRest) = BSL.splitAt (fromIntegral sizeHeader) buf -- How much non-header data is present in the file. -- For uncompressed data without a colour table, the remaining data -- should be the image, but there may also be padding bytes on the -- end. physicalBufferSize = (fromIntegral $ BSL.length bufRest) :: Word32 in if (fromIntegral $ BSL.length bufImageHeader) /= sizeHeader then Left ErrorImageHeaderTruncated else parseBMP3 fileHeader bufImageHeader bufRest physicalBufferSize parseBMP3 fileHeader bufImageHeader bufRest physicalBufferSize | BSL.length bufImageHeader == 40 = let info = decode bufImageHeader in case checkBitmapInfoV3 info physicalBufferSize of Just err -> Left err Nothing | Just imageSize <- imageSizeFromBitmapInfoV3 info -> parseBMP4 fileHeader (InfoV3 info) bufRest imageSize | otherwise -> Left $ ErrorInternalErrorPleaseReport | BSL.length bufImageHeader == 108 = let info = decode bufImageHeader in case checkBitmapInfoV4 info physicalBufferSize of Just err -> Left err Nothing | Just imageSize <- imageSizeFromBitmapInfoV4 info -> parseBMP4 fileHeader (InfoV4 info) bufRest imageSize | otherwise -> Left $ ErrorInternalErrorPleaseReport | BSL.length bufImageHeader == 124 = let info = decode bufImageHeader in case checkBitmapInfoV5 info physicalBufferSize of Just err -> Left err Nothing | Just imageSize <- imageSizeFromBitmapInfoV5 info -> parseBMP4 fileHeader (InfoV5 info) bufRest imageSize | otherwise -> Left $ ErrorInternalErrorPleaseReport | otherwise = Left $ ErrorUnhandledBitmapHeaderSize $ fromIntegral $ BSL.length bufImageHeader parseBMP4 fileHeader imageHeader bufImage (sizeImage :: Int) = let bufLen = fromIntegral $ BSL.length bufImage in if bufLen < sizeImage then Left $ ErrorImageDataTruncated sizeImage bufLen else Right $ BMP { bmpFileHeader = fileHeader , bmpBitmapInfo = imageHeader , bmpRawImageData = BS.concat $ BSL.toChunks bufImage } -- Writing -------------------------------------------------------------------- -- | Wrapper for `hPutBMP` writeBMP :: FilePath -> BMP -> IO () writeBMP fileName bmp = do h <- openBinaryFile fileName WriteMode hPutBMP h bmp hFlush h hClose h -- | Put a BMP image to a file handle. hPutBMP :: Handle -> BMP -> IO () hPutBMP h bmp = BSL.hPut h (renderBMP bmp) -- | Render a BMP image to a lazy `ByteString`. renderBMP :: BMP -> BSL.ByteString renderBMP bmp = BSL.append (encode $ bmpFileHeader bmp) $ BSL.append (encode $ bmpBitmapInfo bmp) $ BSL.fromStrict (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 = let info = getBitmapInfoV3 $ bmpBitmapInfo bmp in ( fromIntegral $ dib3Width info , fromIntegral $ dib3Height info) bmp-1.2.3.4/Codec/BMP/0000755000000000000000000000000012063503764012264 5ustar0000000000000000bmp-1.2.3.4/Codec/BMP/Base.hs0000644000000000000000000000077512063503764013503 0ustar0000000000000000{-# 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 bmp-1.2.3.4/Codec/BMP/BitmapInfo.hs0000644000000000000000000000205212063503764014647 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} module Codec.BMP.BitmapInfo ( BitmapInfo (..) , getBitmapInfoV3) where import Codec.BMP.BitmapInfoV3 import Codec.BMP.BitmapInfoV4 import Codec.BMP.BitmapInfoV5 import Data.Binary import Data.Binary.Get -- | A wrapper for the various image header types. -- data BitmapInfo = InfoV3 BitmapInfoV3 | InfoV4 BitmapInfoV4 | InfoV5 BitmapInfoV5 deriving (Show) instance Binary BitmapInfo where get = 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" put xx = case xx of InfoV3 info -> put info InfoV4 info -> put info InfoV5 info -> put info -- | 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 bmp-1.2.3.4/Codec/BMP/BitmapInfoV3.hs0000644000000000000000000001452712063503764015072 0ustar0000000000000000{-# LANGUAGE PatternGuards #-} {-# OPTIONS_HADDOCK hide #-} module Codec.BMP.BitmapInfoV3 ( BitmapInfoV3 (..) , Compression (..) , sizeOfBitmapInfoV3 , checkBitmapInfoV3 , imageSizeFromBitmapInfoV3) where import Codec.BMP.Error import Codec.BMP.Compression 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 { -- | (+0) Size of the image header, in bytes. dib3Size :: Word32 -- | (+4) Width of the image, in pixels. , dib3Width :: Word32 -- | (+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 -- | (+14) Number of bits per pixel. , dib3BitCount :: Word16 -- | (+16) Image compression mode. , dib3Compression :: Compression -- | (+20) Size of raw image data. -- Some encoders set this to zero, so we need to calculate it based -- on the overall file size. -- -- If it is non-zero then we check it matches the file size - header -- size. , dib3ImageSize :: Word32 -- | (+24) Prefered resolution in pixels per meter, along the X axis. , dib3PelsPerMeterX :: Word32 -- | (+28) Prefered resolution in pixels per meter, along the Y axis. , dib3PelsPerMeterY :: Word32 -- | (+32) Number of color entries that are used. , dib3ColorsUsed :: Word32 -- | (+36) 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 -- 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 imgsize <- getWord32le pelsX <- getWord32le pelsY <- getWord32le cused <- getWord32le cimp <- getWord32le return $ BitmapInfoV3 { dib3Size = size , dib3Width = width , dib3Height = height , dib3HeightFlipped = flipped , 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 -- | Check headers for problems and unsupported features. checkBitmapInfoV3 :: BitmapInfoV3 -> Word32 -> Maybe Error checkBitmapInfoV3 header physicalBufferSize -- We only handle a single color plane. | dib3Planes header /= 1 = Just $ ErrorUnhandledPlanesCount $ dib3Planes header -- We only handle 24 and 32 bit images. | dib3BitCount header /= 24 , dib3BitCount header /= 32 = Just $ ErrorUnhandledColorDepth $ dib3BitCount header -- If the image size field in the header is non-zero, -- then it must be less than the physical size of the image buffer. -- The buffer may be larger than the size of the image stated -- in the header, because some encoders add padding to the end. | headerImageSize <- dib3ImageSize header , headerImageSize /= 0 , physicalBufferSize < headerImageSize = Just $ ErrorImagePhysicalSizeMismatch headerImageSize physicalBufferSize -- Check that the physical buffer contains enough image data. -- The buffer may be larger than the size of the image stated -- in the header, because some encoders add padding to the end. | Just calculatedImageSize <- imageSizeFromBitmapInfoV3 header , fromIntegral physicalBufferSize < calculatedImageSize = trace (show header) $ Just $ ErrorImageDataTruncated calculatedImageSize (fromIntegral physicalBufferSize) -- We only handle uncompresssed images. | dib3Compression header /= CompressionRGB && dib3Compression header /= CompressionBitFields = Just $ ErrorUnhandledCompressionMode (dib3Compression header) | otherwise = Nothing -- | Compute the size of the image data from the header. -- -- * We can't just use the 'dib3ImageSize' field because some encoders -- 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. -- imageSizeFromBitmapInfoV3 :: BitmapInfoV3 -> Maybe Int imageSizeFromBitmapInfoV3 header | dib3BitCount header == 32 , dib3Planes header == 1 , dib3Compression header == CompressionRGB || dib3Compression header == CompressionBitFields = Just $ fromIntegral (dib3Width header * dib3Height header * 4) | dib3BitCount header == 24 , dib3Planes header == 1 , dib3Compression header == CompressionRGB || dib3Compression header == CompressionBitFields = let imageBytesPerLine = dib3Width header * 3 tailBytesPerLine = imageBytesPerLine `mod` 4 padBytesPerLine = if tailBytesPerLine > 0 then 4 - tailBytesPerLine else 0 in Just $ fromIntegral $ dib3Height header * imageBytesPerLine + padBytesPerLine | otherwise = trace (show header) $ Nothing bmp-1.2.3.4/Codec/BMP/BitmapInfoV4.hs0000644000000000000000000001453512063503764015072 0ustar0000000000000000{-# LANGUAGE PatternGuards #-} {-# OPTIONS_HADDOCK hide #-} module Codec.BMP.BitmapInfoV4 ( BitmapInfoV4 (..) , CIEXYZ (..) , sizeOfBitmapInfoV4 , checkBitmapInfoV4 , imageSizeFromBitmapInfoV4) 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 -> Word32 -> Maybe Error checkBitmapInfoV4 headerV4 physicalBufferSize -- We only handle a single color plane. | dib3Planes headerV3 /= 1 = Just $ ErrorUnhandledPlanesCount $ dib3Planes headerV3 -- We only handle 24 and 32 bit images. | dib3BitCount headerV3 /= 24 , dib3BitCount headerV3 /= 32 = Just $ ErrorUnhandledColorDepth $ dib3BitCount headerV3 -- If the image size field in the header is non-zero, -- then it must be less than the physical size of the image buffer. -- The buffer may be larger than the size of the image stated -- in the header, because some encoders add padding to the end. | headerImageSize <- dib3ImageSize headerV3 , headerImageSize /= 0 , physicalBufferSize < headerImageSize = Just $ ErrorImagePhysicalSizeMismatch headerImageSize physicalBufferSize -- Check that the physical buffer contains enough image data. -- It may contain more, as some encoders put padding bytes -- on the end. | Just calculatedImageSize <- imageSizeFromBitmapInfoV4 headerV4 , fromIntegral physicalBufferSize < calculatedImageSize = Just $ ErrorImageDataTruncated calculatedImageSize (fromIntegral physicalBufferSize) -- Check for valid compression modes ---- -- uncompressed 32bit RGBA stated as CompressionRGB. | dib3BitCount headerV3 == 32 , dib3Compression headerV3 == CompressionRGB = Nothing -- uncompressed 32bit RGBA stated as CompressionBitFields. | dib3BitCount headerV3 == 32 , dib3Compression headerV3 == CompressionBitFields , dib4AlphaMask headerV4 == 0xff000000 , dib4RedMask headerV4 == 0x00ff0000 , dib4GreenMask headerV4 == 0x0000ff00 , dib4BlueMask headerV4 == 0x000000ff = Nothing -- uncompressed 24bit RGB | dib3BitCount headerV3 == 24 , dib3Compression headerV3 == CompressionRGB = Nothing -- Some unsupported compression mode ---- | otherwise = Just $ ErrorUnhandledCompressionMode (dib3Compression headerV3) where headerV3 = dib4InfoV3 headerV4 -- | Compute the size of the image data from the header. -- -- * We can't just use the 'dib3ImageSize' field because some encoders -- 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. imageSizeFromBitmapInfoV4 :: BitmapInfoV4 -> Maybe Int imageSizeFromBitmapInfoV4 headerV4 | dib3BitCount headerV3 == 32 , dib3Planes headerV3 == 1 , dib3Compression headerV3 == CompressionRGB = Just $ fromIntegral (dib3Width headerV3 * dib3Height headerV3 * 4) | dib3BitCount headerV3 == 32 , dib3Planes headerV3 == 1 , dib3Compression headerV3 == CompressionBitFields , dib4AlphaMask headerV4 == 0xff000000 , dib4RedMask headerV4 == 0x00ff0000 , dib4GreenMask headerV4 == 0x0000ff00 , dib4BlueMask headerV4 == 0x000000ff = Just $ fromIntegral (dib3Width headerV3 * dib3Height headerV3 * 4) | dib3BitCount headerV3 == 24 , dib3Planes headerV3 == 1 , dib3Compression headerV3 == CompressionRGB = let imageBytesPerLine = dib3Width headerV3 * 3 tailBytesPerLine = imageBytesPerLine `mod` 4 padBytesPerLine = if tailBytesPerLine > 0 then 4 - tailBytesPerLine else 0 in Just $ fromIntegral $ dib3Height headerV3 * imageBytesPerLine + padBytesPerLine | otherwise = Nothing where headerV3 = dib4InfoV3 headerV4 bmp-1.2.3.4/Codec/BMP/BitmapInfoV5.hs0000644000000000000000000000352512063503764015070 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} module Codec.BMP.BitmapInfoV5 ( BitmapInfoV5 (..) , sizeOfBitmapInfoV5 , checkBitmapInfoV5 , imageSizeFromBitmapInfoV5) 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 -> Word32 -> Maybe Error checkBitmapInfoV5 header expectedImageSize = checkBitmapInfoV4 (dib5InfoV4 header) expectedImageSize -- | Compute the size of the image data from the header. imageSizeFromBitmapInfoV5 :: BitmapInfoV5 -> Maybe Int imageSizeFromBitmapInfoV5 = imageSizeFromBitmapInfoV4 . dib5InfoV4 bmp-1.2.3.4/Codec/BMP/CIEXYZ.hs0000644000000000000000000000072612063503764013640 0ustar0000000000000000 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 bmp-1.2.3.4/Codec/BMP/Compression.hs0000644000000000000000000000237612063503764015131 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} module Codec.BMP.Compression (Compression(..)) where import Data.Word import Data.Binary import Data.Binary.Get import Data.Binary.Put -- | The Compression mode says how the image data is encoded in the file. data Compression = CompressionRGB | CompressionRLE8 | CompressionRLE4 | CompressionBitFields | CompressionJPEG | CompressionPNG | CompressionUnknown Word32 deriving (Show, Eq) 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 bmp-1.2.3.4/Codec/BMP/Error.hs0000644000000000000000000000361612063503764013717 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} module Codec.BMP.Error (Error(..)) where 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 { errorMagic :: Word16 } -- | File is too short to contain a file header. | ErrorFileHeaderTruncated -- | File is too short to contain an image header. | ErrorImageHeaderTruncated -- | File is too short to contain the image data. | ErrorImageDataTruncated { errorBytesNeeded :: Int , errorBytesAvailable :: Int } -- | Reserved fields should be zero. | ErrorReservedFieldNotZero -- | The offset to the image data from the file header doesn't -- point anywhere sensible. | ErrorDodgyFileHeaderFieldOffset { errorFileHeaderOffset :: Word32 } -- | We handle V3 V4 and V5 image headers, but the size of -- the header indicates it has some other format. | ErrorUnhandledBitmapHeaderSize { errorBitmapHeaderSize :: Word32 } -- | We only handle single color planes. | ErrorUnhandledPlanesCount { errorPlanesCount :: Word16 } -- | We only handle 24 and 32 bit images. | ErrorUnhandledColorDepth { errorColorDepth :: Word16 } -- | We only handle uncompressed images. | ErrorUnhandledCompressionMode { errorCompression :: Compression} -- | Mismatch between the image size stated in the header -- and that which is calculuated from the other fields. | ErrorImagePhysicalSizeMismatch { errorImageSizeFromHeader :: Word32 , errorImageSizeOfBuffer :: Word32 } -- | Something went wrong in the library. | ErrorInternalErrorPleaseReport deriving (Eq, Show) bmp-1.2.3.4/Codec/BMP/FileHeader.hs0000644000000000000000000000437112063503764014615 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} module Codec.BMP.FileHeader ( FileHeader (..) , bmpMagic , sizeOfFileHeader , checkFileHeader) where import Codec.BMP.BitmapInfoV3 import Codec.BMP.Error import Data.Binary import Data.Binary.Get import Data.Binary.Put -- | BMP file header. data FileHeader = FileHeader { -- | (+0) Magic numbers 0x42 0x4d fileHeaderType :: Word16 -- | (+2) Size of the file, in bytes. , fileHeaderFileSize :: Word32 -- | (+6) Reserved, must be zero. , fileHeaderReserved1 :: Word16 -- | (+8) Reserved, must be zero. , fileHeaderReserved2 :: Word16 -- | (+10) 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 = Just $ ErrorFileHeaderTruncated | fileHeaderFileSize header < fromIntegral (sizeOfFileHeader + sizeOfBitmapInfoV3) = Just $ ErrorImageHeaderTruncated | fileHeaderReserved1 header /= 0 = Just $ ErrorReservedFieldNotZero | fileHeaderReserved2 header /= 0 = Just $ ErrorReservedFieldNotZero | fromIntegral (fileHeaderOffset header) /= sizeOfFileHeader + sizeOfBitmapInfoV3 = Just $ ErrorDodgyFileHeaderFieldOffset $ fromIntegral $ fileHeaderOffset header | otherwise = Nothing bmp-1.2.3.4/Codec/BMP/Pack.hs0000644000000000000000000001061512063503764013501 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE ScopedTypeVariables #-} module Codec.BMP.Pack (packRGBA32ToBMP) where import Codec.BMP.Base import Codec.BMP.BitmapInfo import Codec.BMP.BitmapInfoV3 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. -- -- * 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 (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: 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 , dib3HeightFlipped = False , dib3Planes = 1 , dib3BitCount = 24 , dib3Compression = CompressionRGB , 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 } -- 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)] in case errs of [] -> BMP { bmpFileHeader = fileHeader , bmpBitmapInfo = InfoV3 bitmapInfoV3 , bmpRawImageData = imageData } _ -> error $ "Codec.BMP: Constructed BMP file has errors, sorry." ++ show errs packRGBA32ToRGB24 :: 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: 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) bmp-1.2.3.4/Codec/BMP/Unpack.hs0000644000000000000000000001265312063503764014050 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE ScopedTypeVariables #-} module Codec.BMP.Unpack (unpackBMPToRGBA32) where import Codec.BMP.Base import Codec.BMP.BitmapInfo import Codec.BMP.BitmapInfoV3 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. unpackBMPToRGBA32 :: BMP -> ByteString unpackBMPToRGBA32 bmp = 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 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 -- RGBA component values. -- -- The alpha component is set to 255 for every pixel. packRGB24ToRGBA32 :: Int -- ^ Width of image. -> Int -- ^ Height of image. -> Bool -- ^ Image data is flipped along the X axis. -> ByteString -- ^ Input string. -> ByteString 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 * srcBytesPerLine then error "Codec.BMP: Image data is truncated." else unsafePerformIO $ allocaBytes sizeDest $ \bufDest -> BS.unsafeUseAsCString str $ \bufSrc -> 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 flipX srcBytesPerLine ptrSrc ptrDst = go 0 where 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 (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 ptrDst (oDst + 0) red pokeByteOff ptrDst (oDst + 1) green pokeByteOff ptrDst (oDst + 2) blue pokeByteOff ptrDst (oDst + 3) (255 :: Word8) 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. -- The 'unpacking' here is really just flipping the components around. packRGB32ToRGBA32 :: Int -- ^ Width of image. -> Int -- ^ Height of image. -> Bool -- ^ Image data is flipped along the X axis. -> ByteString -- ^ Input string. -> ByteString packRGB32ToRGBA32 width height flipX str = let sizeDest = height * width * 4 in if BS.length str < sizeDest 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 flipX ptrSrc ptrDst = go 0 where 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 -- 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 = 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 ptrDst (oDst + 0) red pokeByteOff ptrDst (oDst + 1) green pokeByteOff ptrDst (oDst + 2) blue pokeByteOff ptrDst (oDst + 3) alpha go_line (posX + 1) posY (oSrc + 4) (oDst + 4)