{-# 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
packRGBA32ToBMP
:: Int
-> Int
-> ByteString
-> BMP
packRGBA32ToBMP :: Int -> Int -> ByteString -> BMP
packRGBA32ToBMP = Int -> Int -> ByteString -> BMP
packRGBA32ToBMP32
{-# INLINE packRGBA32ToBMP #-}
packRGBA32ToBMP32
:: Int
-> Int
-> ByteString
-> 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
packRGBA32ToBMP24
:: Int
-> Int
-> ByteString
-> 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
packDataToBMP
:: Int
-> Int
-> Int
-> ByteString
-> 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
, dib3PelsPerMeterX :: Word32
dib3PelsPerMeterX = Word32
2834
, dib3PelsPerMeterY :: Word32
dib3PelsPerMeterY = Word32
2834
, dib3ColorsUsed :: Word32
dib3ColorsUsed = Word32
0
, dib3ColorsImportant :: Word32
dib3ColorsImportant = Word32
0 }
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
packRGBA32ToBGR24
:: Int
-> Int
-> ByteString
-> 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 Any -> Ptr Any -> 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 Any
forall a b. Ptr a -> Ptr b
castPtr Ptr CChar
bufSrc) (Ptr CChar -> Ptr Any
forall a b. Ptr a -> Ptr b
castPtr Ptr CChar
bufDest)
ByteString
bs <- CStringLen -> IO ByteString
packCStringLen (Ptr CChar
bufDest, Int
sizeDest)
ByteString -> IO ByteString
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
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
| 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)
| 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 ()
| Bool
otherwise
= do Word8
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)
Word8
green :: 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
1)
Word8
blue :: 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
2)
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
0) Word8
blue
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
1) Word8
green
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
2) Word8
red
p -> p -> Int -> Int -> IO ()
go (p
posX p -> p -> p
forall a. Num a => a -> a -> a
+ p
1) p
posY (Int
oSrc Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
4) (Int
oDest Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
3)
packRGBA32ToBGRA32
:: Int
-> Int
-> ByteString
-> 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 Any -> Ptr Any -> 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 Any
forall a b. Ptr a -> Ptr b
castPtr Ptr CChar
bufSrc) (Ptr CChar -> Ptr Any
forall a b. Ptr a -> Ptr b
castPtr Ptr CChar
bufDest)
ByteString
bs <- CStringLen -> IO ByteString
packCStringLen (Ptr CChar
bufDest, Int
sizeDest)
ByteString -> IO ByteString
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
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
| 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
| 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 ()
| Bool
otherwise
= do Word8
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)
Word8
green :: 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
1)
Word8
blue :: 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
2)
Word8
alpha :: 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
3)
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
0) Word8
blue
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
1) Word8
green
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
2) Word8
red
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
3) Word8
alpha
p -> p -> Int -> Int -> IO ()
go (p
posX p -> p -> p
forall a. Num a => a -> a -> a
+ p
1) p
posY (Int
oSrc Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
4) (Int
oDest Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
4)