{-# 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