    {-# OPTIONS_HADDOCK hide #-}
    module Codec.BMP.Pack
            ( packRGBA32ToBMP
            , packRGBA32ToBMP24
            , packRGBA32ToBMP32)
    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 32-bit BMP image.
    --
    --   Alias for `packRGBA32ToBMP32`.
    --
    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 :: Int -> Int -> ByteString -> BMP
    packRGBA32ToBMP = Int -> Int -> ByteString -> BMP
    packRGBA32ToBMP32
    {-# INLINE packRGBA32ToBMP #-}

    -- BMP 32 bit -----------------------------------------------------------------
    -- | Pack a string of RGBA component values into a 32-bit BMP image.
    --
    --  * If the given dimensions don't match the input string then `error`.
    --
    --  * If the width or height fields are negative then `error`.
    --
    packRGBA32ToBMP32
            :: 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

    packRGBA32ToBMP32 :: Int -> Int -> ByteString -> BMP
    packRGBA32ToBMP32 Int
    width Int
    height ByteString
    str
     | Int
    width Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    < Int
    0
     = [Char] -> BMP
    forall a. HasCallStack => [Char] -> a
    error [Char]
    "Codec.BMP: Negative width field."

     | Int
    height Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    < Int
    0
     = [Char] -> BMP
    forall a. HasCallStack => [Char] -> a
    error [Char]
    "Codec.BMP: Negative height field."

     | Int
    height Int -> Int -> Int
    forall a. Num a => a -> a -> a
    * Int
    width Int -> Int -> Int
    forall a. Num a => a -> a -> a
    * Int
    4 Int -> Int -> Bool
    forall a. Eq a => a -> a -> Bool
    /= ByteString -> Int
    BS.length ByteString
    str
     = [Char] -> BMP
    forall a. HasCallStack => [Char] -> a
    error [Char]
    "Codec.BMP: Image dimensions don't match input data."

     | Bool
    otherwise
     = let  imageData :: ByteString
    imageData       = Int -> Int -> ByteString -> ByteString
    packRGBA32ToBGRA32 Int
    width Int
    height ByteString
    str
       in   Int -> Int -> Int -> ByteString -> BMP
    packDataToBMP Int
    32 Int
    width Int
    height ByteString
    imageData

    -- BMP 24 bit -----------------------------------------------------------------
    -- | Pack a string of RGBA component values into a 24-bit BMP image,
    --   discarding the alpha channel of the source data.
    --
    --  * If the given dimensions don't match the input string then `error`.
    --
    --  * If the width or height fields are negative then `error`.

    packRGBA32ToBMP24
            :: 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

    packRGBA32ToBMP24 :: Int -> Int -> ByteString -> BMP
    packRGBA32ToBMP24 Int
    width Int
    height ByteString
    str
     | Int
    width Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    < Int
    0
     = [Char] -> BMP
    forall a. HasCallStack => [Char] -> a
    error [Char]
    "Codec.BMP: Negative width field."

     | Int
    height Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    < Int
    0
     = [Char] -> BMP
    forall a. HasCallStack => [Char] -> a
    error [Char]
    "Codec.BMP: Negative height field."

     | Int
    height Int -> Int -> Int
    forall a. Num a => a -> a -> a
    * Int
    width Int -> Int -> Int
    forall a. Num a => a -> a -> a
    * Int
    4 Int -> Int -> Bool
    forall a. Eq a => a -> a -> Bool
    /= ByteString -> Int
    BS.length ByteString
    str
     = [Char] -> BMP
    forall a. HasCallStack => [Char] -> a
    error [Char]
    "Codec.BMP: Image dimensions don't match input data."

     | Bool
    otherwise
     = let  imageData :: ByteString
    imageData       = Int -> Int -> ByteString -> ByteString
    packRGBA32ToBGR24 Int
    width Int
    height ByteString
    str
       in   Int -> Int -> Int -> ByteString -> BMP
    packDataToBMP Int
    24 Int
    width Int
    height ByteString
    imageData

    -- data -----------------------------------------------------------------------
    -- | Wrap pre-packed image data into BMP image.
    --
    packDataToBMP
            :: Int          -- ^ Number of bits per pixel
            -> 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

    packDataToBMP :: Int -> Int -> Int -> ByteString -> BMP
    packDataToBMP Int
    bits Int
    width Int
    height ByteString
    imageData
     = let  fileHeader :: FileHeader
    fileHeader
                    = FileHeader
                    { fileHeaderType :: Word16
    fileHeaderType        = Word16
    bmpMagic

                    , fileHeaderFileSize :: Word32
    fileHeaderFileSize
                            = Int -> Word32
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral
                            (Int -> Word32) -> Int -> Word32
    forall a b. (a -> b) -> a -> b
    $ Int
    sizeOfFileHeader Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    sizeOfBitmapInfoV3
                                               Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + ByteString -> Int
    BS.length ByteString
    imageData

                    , fileHeaderReserved1 :: Word16
    fileHeaderReserved1   = Word16
    0
                    , fileHeaderReserved2 :: Word16
    fileHeaderReserved2   = Word16
    0
                    , fileHeaderOffset :: Word32
    fileHeaderOffset
                            = Int -> Word32
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral (Int
    sizeOfFileHeader Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    sizeOfBitmapInfoV3)}

            bitmapInfoV3 :: BitmapInfoV3
    bitmapInfoV3
                    = BitmapInfoV3
                    { dib3Size :: Word32
    dib3Size              = Int -> Word32
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Int
    sizeOfBitmapInfoV3
                    , dib3Width :: Word32
    dib3Width             = Int -> Word32
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Int
    width
                    , dib3Height :: Word32
    dib3Height            = Int -> Word32
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Int
    height
                    , dib3HeightFlipped :: Bool
    dib3HeightFlipped     = Bool
    False
                    , dib3Planes :: Word16
    dib3Planes            = Word16
    1
                    , dib3BitCount :: Word16
    dib3BitCount          = Int -> Word16
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Int
    bits
                    , dib3Compression :: Compression
    dib3Compression       = Compression
    CompressionRGB
                    , dib3ImageSize :: Word32
    dib3ImageSize         = Int -> Word32
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral (Int -> Word32) -> Int -> Word32
    forall a b. (a -> b) -> a -> b
    $ ByteString -> Int
    BS.length ByteString
    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 :: Word32
    dib3PelsPerMeterX     = Word32
    2834
                    , dib3PelsPerMeterY :: Word32
    dib3PelsPerMeterY     = Word32
    2834

                    , dib3ColorsUsed :: Word32
    dib3ColorsUsed        = Word32
    0
                    , dib3ColorsImportant :: Word32
    dib3ColorsImportant   = Word32
    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 :: [Error]
    errs    = [Maybe Error] -> [Error]
    forall a. [Maybe a] -> [a]
    catMaybes
                            [ FileHeader -> Maybe Error
    checkFileHeader   FileHeader
    fileHeader
                            , BitmapInfoV3 -> Word32 -> Maybe Error
    checkBitmapInfoV3 BitmapInfoV3
    bitmapInfoV3
                                               (Int -> Word32
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral (Int -> Word32) -> Int -> Word32
    forall a b. (a -> b) -> a -> b
    $ ByteString -> Int
    BS.length ByteString
    imageData)]

       in   case [Error]
    errs of
             [] -> BMP
                    { bmpFileHeader :: FileHeader
    bmpFileHeader         = FileHeader
    fileHeader
                    , bmpBitmapInfo :: BitmapInfo
    bmpBitmapInfo         = BitmapInfoV3 -> BitmapInfo
    InfoV3 BitmapInfoV3
    bitmapInfoV3
                    , bmpRawImageData :: ByteString
    bmpRawImageData       = ByteString
    imageData }

             [Error]
    _  -> [Char] -> BMP
    forall a. HasCallStack => [Char] -> a
    error ([Char] -> BMP) -> [Char] -> BMP
    forall a b. (a -> b) -> a -> b
    $ [Char]
    "Codec.BMP: Constructed BMP file has errors, sorry."
                         [Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++ [Error] -> [Char]
    forall a. Show a => a -> [Char]
    show [Error]
    errs

    -------------------------------------------------------------------------------
    -- | Pack RGBA data into the format need by BMP image data.
    packRGBA32ToBGR24
            :: Int                 -- ^ Width of image.
            -> Int                 -- ^ Height of image.
            -> ByteString          -- ^ Source bytestring holding the image data.
            -> ByteString          --   output bytestring.

    packRGBA32ToBGR24 :: Int -> Int -> ByteString -> ByteString
    packRGBA32ToBGR24 Int
    width Int
    height ByteString
    str
     | Int
    height Int -> Int -> Int
    forall a. Num a => a -> a -> a
    * Int
    width Int -> Int -> Int
    forall a. Num a => a -> a -> a
    * Int
    4 Int -> Int -> Bool
    forall a. Eq a => a -> a -> Bool
    /= ByteString -> Int
    BS.length ByteString
    str
     = [Char] -> ByteString
    forall a. HasCallStack => [Char] -> a
    error [Char]
    "Codec.BMP: Image dimensions don't match input data."

     | Bool
    otherwise
     = let  padPerLine :: Int
    padPerLine
             = case (Int
    width Int -> Int -> Int
    forall a. Num a => a -> a -> a
    * Int
    3) Int -> Int -> Int
    forall a. Integral a => a -> a -> a
    `mod` Int
    4 of
                    Int
    0       -> Int
    0
                    Int
    x       -> Int
    4 Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    x

            sizeDest :: Int
    sizeDest        = Int
    height Int -> Int -> Int
    forall a. Num a => a -> a -> a
    * (Int
    width Int -> Int -> Int
    forall a. Num a => a -> a -> a
    * Int
    3 Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    padPerLine)
       in   IO ByteString -> ByteString
    forall a. IO a -> a
    unsafePerformIO
             (IO ByteString -> ByteString) -> IO ByteString -> ByteString
    forall a b. (a -> b) -> a -> b
    $ Int -> (Ptr CChar -> IO ByteString) -> IO ByteString
    forall a b. Int -> (Ptr a -> IO b) -> IO b
    allocaBytes Int
    sizeDest         ((Ptr CChar -> IO ByteString) -> IO ByteString)
    -> (Ptr CChar -> IO ByteString) -> IO ByteString
    forall a b. (a -> b) -> a -> b
    $ \Ptr CChar
    bufDest ->
               ByteString -> (Ptr CChar -> IO ByteString) -> IO ByteString
    forall a. ByteString -> (Ptr CChar -> IO a) -> IO a
    BS.unsafeUseAsCString ByteString
    str    ((Ptr CChar -> IO ByteString) -> IO ByteString)
    -> (Ptr CChar -> IO ByteString) -> IO ByteString
    forall a b. (a -> b) -> a -> b
    $ \Ptr CChar
    bufSrc  ->
                do  Int -> Int -> Int -> Ptr (ZonkAny 3) -> Ptr (ZonkAny 2) -> IO ()
    forall {p} {p} {b} {b}.
    (Num p, Num p, Eq p, Eq p) =>
    p -> p -> Int -> Ptr b -> Ptr b -> IO ()
    packRGBA32ToBGR24' Int
    width Int
    height Int
    padPerLine
                            (Ptr CChar -> Ptr (ZonkAny 3)
    forall a b. Ptr a -> Ptr b
    castPtr Ptr CChar
    bufSrc) (Ptr CChar -> Ptr (ZonkAny 2)
    forall a b. Ptr a -> Ptr b
    castPtr Ptr CChar
    bufDest)
                    bs      <- CStringLen -> IO ByteString
    packCStringLen (Ptr CChar
    bufDest, Int
    sizeDest)
                    return bs

    packRGBA32ToBGR24' :: p -> p -> Int -> Ptr b -> Ptr b -> IO ()
    packRGBA32ToBGR24' p
    width p
    height Int
    pad Ptr b
    ptrSrc Ptr b
    ptrDest
     = p -> p -> Int -> Int -> IO ()
    go p
    0 p
    0 Int
    0 Int
    0
     where
            go :: p -> p -> Int -> Int -> IO ()
    go p
    posX p
    posY Int
    oSrc Int
    oDest

             -- add padding bytes at the end of each line.
             | p
    posX p -> p -> Bool
    forall a. Eq a => a -> a -> Bool
    == p
    width
             = do   (Int -> IO ()) -> [Int] -> IO ()
    forall (t :: * -> *) (m :: * -> *) a b.
    (Foldable t, Monad m) =>
    (a -> m b) -> t a -> m ()
    mapM_ (\Int
    n -> Ptr b -> Int -> Word8 -> IO ()
    forall b. Ptr b -> Int -> Word8 -> IO ()
    forall a b. Storable a => Ptr b -> Int -> a -> IO ()
    pokeByteOff Ptr b
    ptrDest (Int
    oDest Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    n) (Word8
    0 :: Word8))
                            ([Int] -> IO ()) -> [Int] -> IO ()
    forall a b. (a -> b) -> a -> b
    $ Int -> [Int] -> [Int]
    forall a. Int -> [a] -> [a]
    P.take Int
    pad [Int
    0 .. ]
                    p -> p -> Int -> Int -> IO ()
    go p
    0 (p
    posY p -> p -> p
    forall a. Num a => a -> a -> a
    + p
    1) Int
    oSrc (Int
    oDest Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    pad)

             -- we've finished the image.
             | p
    posY p -> p -> Bool
    forall a. Eq a => a -> a -> Bool
    == p
    height
             = () -> IO ()
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()

             -- process a pixel
             | Bool
    otherwise
             = do   red     :: Word8  <- Ptr b -> Int -> IO Word8
    forall b. Ptr b -> Int -> IO Word8
    forall a b. Storable a => Ptr b -> Int -> IO a
    peekByteOff Ptr b
    ptrSrc (Int
    oSrc Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    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)

    -------------------------------------------------------------------------------
    -- | Pack RGBA data into the byte order needed by BMP image data.
    packRGBA32ToBGRA32
            :: Int                 -- ^ Width of image.
            -> Int                 -- ^ Height of image.
            -> ByteString          -- ^ Source bytestring holding the image data.
            -> ByteString

    packRGBA32ToBGRA32 :: Int -> Int -> ByteString -> ByteString
    packRGBA32ToBGRA32 Int
    width Int
    height ByteString
    str
     | Int
    height Int -> Int -> Int
    forall a. Num a => a -> a -> a
    * Int
    width Int -> Int -> Int
    forall a. Num a => a -> a -> a
    * Int
    4 Int -> Int -> Bool
    forall a. Eq a => a -> a -> Bool
    /= ByteString -> Int
    BS.length ByteString
    str
     = [Char] -> ByteString
    forall a. HasCallStack => [Char] -> a
    error [Char]
    "Codec.BMP: Image dimensions don't match input data."

     | Bool
    otherwise
     = let  sizeDest :: Int
    sizeDest        = Int
    height Int -> Int -> Int
    forall a. Num a => a -> a -> a
    * (Int
    width Int -> Int -> Int
    forall a. Num a => a -> a -> a
    * Int
    4)
       in   IO ByteString -> ByteString
    forall a. IO a -> a
    unsafePerformIO
             (IO ByteString -> ByteString) -> IO ByteString -> ByteString
    forall a b. (a -> b) -> a -> b
    $ Int -> (Ptr CChar -> IO ByteString) -> IO ByteString
    forall a b. Int -> (Ptr a -> IO b) -> IO b
    allocaBytes Int
    sizeDest         ((Ptr CChar -> IO ByteString) -> IO ByteString)
    -> (Ptr CChar -> IO ByteString) -> IO ByteString
    forall a b. (a -> b) -> a -> b
    $ \Ptr CChar
    bufDest ->
               ByteString -> (Ptr CChar -> IO ByteString) -> IO ByteString
    forall a. ByteString -> (Ptr CChar -> IO a) -> IO a
    BS.unsafeUseAsCString ByteString
    str    ((Ptr CChar -> IO ByteString) -> IO ByteString)
    -> (Ptr CChar -> IO ByteString) -> IO ByteString
    forall a b. (a -> b) -> a -> b
    $ \Ptr CChar
    bufSrc  ->
                do  Int -> Int -> Ptr (ZonkAny 1) -> Ptr (ZonkAny 0) -> IO ()
    forall {p} {p} {b} {b}.
    (Num p, Num p, Eq p, Eq p) =>
    p -> p -> Ptr b -> Ptr b -> IO ()
    packRGBA32ToBGRA32' Int
    width Int
    height
                            (Ptr CChar -> Ptr (ZonkAny 1)
    forall a b. Ptr a -> Ptr b
    castPtr Ptr CChar
    bufSrc) (Ptr CChar -> Ptr (ZonkAny 0)
    forall a b. Ptr a -> Ptr b
    castPtr Ptr CChar
    bufDest)
                    bs      <- CStringLen -> IO ByteString
    packCStringLen (Ptr CChar
    bufDest, Int
    sizeDest)
                    return  bs

    packRGBA32ToBGRA32' :: p -> p -> Ptr b -> Ptr b -> IO ()
    packRGBA32ToBGRA32' p
    width p
    height Ptr b
    ptrSrc Ptr b
    ptrDest
     = p -> p -> Int -> Int -> IO ()
    go p
    0 p
    0 Int
    0 Int
    0
     where
            go :: p -> p -> Int -> Int -> IO ()
    go p
    posX p
    posY Int
    oSrc Int
    oDest

             -- advance to the next line.
             | p
    posX p -> p -> Bool
    forall a. Eq a => a -> a -> Bool
    == p
    width
             = do  p -> p -> Int -> Int -> IO ()
    go p
    0 (p
    posY p -> p -> p
    forall a. Num a => a -> a -> a
    + p
    1) Int
    oSrc Int
    oDest

             -- we've finished the image.
             | p
    posY p -> p -> Bool
    forall a. Eq a => a -> a -> Bool
    == p
    height
             = () -> IO ()
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()

             -- process a pixel
             | Bool
    otherwise
             = do   red     :: Word8  <- Ptr b -> Int -> IO Word8
    forall b. Ptr b -> Int -> IO Word8
    forall a b. Storable a => Ptr b -> Int -> IO a
    peekByteOff Ptr b
    ptrSrc (Int
    oSrc Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    0)
                    green   :: Word8  <- peekByteOff ptrSrc (oSrc + 1)
                    blue    :: Word8  <- peekByteOff ptrSrc (oSrc + 2)
                    alpha   :: Word8  <- peekByteOff ptrSrc (oSrc + 3)

                    pokeByteOff ptrDest (oDest + 0) blue
                    pokeByteOff ptrDest (oDest + 1) green
                    pokeByteOff ptrDest (oDest + 2) red
                    pokeByteOff ptrDest (oDest + 3) alpha

                    go (posX + 1) posY (oSrc + 4) (oDest + 4)