{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE TypeFamilies #-}
module Codec.Picture.Bitmap(
writeBitmap
, encodeBitmap
, encodeBitmapWithMetadata
, decodeBitmap
, decodeBitmapWithMetadata
, decodeBitmapWithPaletteAndMetadata
, encodeDynamicBitmap
, encodeBitmapWithPaletteAndMetadata
, writeDynamicBitmap
, BmpEncodable( )
) where
#if !MIN_VERSION_base(4,8,0)
import Data.Monoid( mempty )
import Control.Applicative( (<$>) )
#endif
import Control.Arrow( first )
import Control.Monad( replicateM, when, foldM_, forM_, void )
import Control.Monad.ST ( ST, runST )
import Data.Maybe( fromMaybe )
import qualified Data.Vector.Storable as VS
import qualified Data.Vector.Storable.Mutable as M
import Data.Binary( Binary( .. ) )
import Data.Binary.Put( Put
, runPut
, putInt32le
, putWord16le
, putWord32le
, putByteString
)
import Data.Binary.Get( Get
, getWord8
, getWord16le
, getWord32le
, getInt32le
, getByteString
, bytesRead
, skip
, label
)
import Data.Bits
import Data.Int( Int32 )
import Data.Word( Word32, Word16, Word8 )
import qualified Data.ByteString as B
import qualified Data.ByteString.Internal as BI
import qualified Data.ByteString.Lazy as L
import Codec.Picture.InternalHelper
import Codec.Picture.Types
import Codec.Picture.VectorByteConversion
import qualified Codec.Picture.Metadata as Met
import Codec.Picture.Metadata ( Metadatas )
data =
{ BmpHeader -> Word16
magicIdentifier :: !Word16
, BmpHeader -> Word32
fileSize :: !Word32
, BmpHeader -> Word16
reserved1 :: !Word16
, BmpHeader -> Word16
reserved2 :: !Word16
, BmpHeader -> Word32
dataOffset :: !Word32
}
bitmapMagicIdentifier :: Word16
bitmapMagicIdentifier :: Word16
bitmapMagicIdentifier = Word16
0x4D42
instance Binary BmpHeader where
put :: BmpHeader -> Put
put BmpHeader
hdr = do
Word16 -> Put
putWord16le forall a b. (a -> b) -> a -> b
$ BmpHeader -> Word16
magicIdentifier BmpHeader
hdr
Word32 -> Put
putWord32le forall a b. (a -> b) -> a -> b
$ BmpHeader -> Word32
fileSize BmpHeader
hdr
Word16 -> Put
putWord16le forall a b. (a -> b) -> a -> b
$ BmpHeader -> Word16
reserved1 BmpHeader
hdr
Word16 -> Put
putWord16le forall a b. (a -> b) -> a -> b
$ BmpHeader -> Word16
reserved2 BmpHeader
hdr
Word32 -> Put
putWord32le forall a b. (a -> b) -> a -> b
$ BmpHeader -> Word32
dataOffset BmpHeader
hdr
get :: Get BmpHeader
get = do
Word16
ident <- Get Word16
getWord16le
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word16
ident forall a. Eq a => a -> a -> Bool
/= Word16
bitmapMagicIdentifier)
(forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Invalid Bitmap magic identifier")
Word32
fsize <- Get Word32
getWord32le
Word16
r1 <- Get Word16
getWord16le
Word16
r2 <- Get Word16
getWord16le
Word32
offset <- Get Word32
getWord32le
forall (m :: * -> *) a. Monad m => a -> m a
return BmpHeader
{ magicIdentifier :: Word16
magicIdentifier = Word16
ident
, fileSize :: Word32
fileSize = Word32
fsize
, reserved1 :: Word16
reserved1 = Word16
r1
, reserved2 :: Word16
reserved2 = Word16
r2
, dataOffset :: Word32
dataOffset = Word32
offset
}
data ColorSpaceType = CalibratedRGB
| DeviceDependentRGB
| DeviceDependentCMYK
| SRGB
| WindowsColorSpace
| ProfileEmbedded
| ProfileLinked
| UnknownColorSpace Word32
deriving (ColorSpaceType -> ColorSpaceType -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ColorSpaceType -> ColorSpaceType -> Bool
$c/= :: ColorSpaceType -> ColorSpaceType -> Bool
== :: ColorSpaceType -> ColorSpaceType -> Bool
$c== :: ColorSpaceType -> ColorSpaceType -> Bool
Eq, Int -> ColorSpaceType -> ShowS
[ColorSpaceType] -> ShowS
ColorSpaceType -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ColorSpaceType] -> ShowS
$cshowList :: [ColorSpaceType] -> ShowS
show :: ColorSpaceType -> String
$cshow :: ColorSpaceType -> String
showsPrec :: Int -> ColorSpaceType -> ShowS
$cshowsPrec :: Int -> ColorSpaceType -> ShowS
Show)
data =
{ BmpV5Header -> Word32
size :: !Word32
, BmpV5Header -> Int32
width :: !Int32
, BmpV5Header -> Int32
height :: !Int32
, BmpV5Header -> Word16
planes :: !Word16
, BmpV5Header -> Word16
bitPerPixel :: !Word16
, BmpV5Header -> Word32
bitmapCompression :: !Word32
, BmpV5Header -> Word32
byteImageSize :: !Word32
, BmpV5Header -> Int32
xResolution :: !Int32
, BmpV5Header -> Int32
yResolution :: !Int32
, BmpV5Header -> Word32
colorCount :: !Word32
, BmpV5Header -> Word32
importantColours :: !Word32
, BmpV5Header -> Word32
redMask :: !Word32
, BmpV5Header -> Word32
greenMask :: !Word32
, BmpV5Header -> Word32
blueMask :: !Word32
, BmpV5Header -> Word32
alphaMask :: !Word32
, BmpV5Header -> ColorSpaceType
colorSpaceType :: !ColorSpaceType
, BmpV5Header -> ByteString
colorSpace :: !B.ByteString
, BmpV5Header -> Word32
iccIntent :: !Word32
, BmpV5Header -> Word32
iccProfileData :: !Word32
, BmpV5Header -> Word32
iccProfileSize :: !Word32
}
deriving Int -> BmpV5Header -> ShowS
[BmpV5Header] -> ShowS
BmpV5Header -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BmpV5Header] -> ShowS
$cshowList :: [BmpV5Header] -> ShowS
show :: BmpV5Header -> String
$cshow :: BmpV5Header -> String
showsPrec :: Int -> BmpV5Header -> ShowS
$cshowsPrec :: Int -> BmpV5Header -> ShowS
Show
sizeofColorProfile :: Int
sizeofColorProfile :: Int
sizeofColorProfile = Int
48
sizeofBmpHeader, sizeofBmpCoreHeader, sizeofBmpInfoHeader :: Word32
= Word32
2 forall a. Num a => a -> a -> a
+ Word32
4 forall a. Num a => a -> a -> a
+ Word32
2 forall a. Num a => a -> a -> a
+ Word32
2 forall a. Num a => a -> a -> a
+ Word32
4
= Word32
12
= Word32
40
sizeofBmpV2Header, sizeofBmpV3Header, sizeofBmpV4Header, sizeofBmpV5Header :: Word32
= Word32
52
= Word32
56
= Word32
108
= Word32
124
instance Binary ColorSpaceType where
put :: ColorSpaceType -> Put
put ColorSpaceType
CalibratedRGB = Word32 -> Put
putWord32le Word32
0
put ColorSpaceType
DeviceDependentRGB = Word32 -> Put
putWord32le Word32
1
put ColorSpaceType
DeviceDependentCMYK = Word32 -> Put
putWord32le Word32
2
put ColorSpaceType
ProfileEmbedded = Word32 -> Put
putWord32le Word32
0x4D424544
put ColorSpaceType
ProfileLinked = Word32 -> Put
putWord32le Word32
0x4C494E4B
put ColorSpaceType
SRGB = Word32 -> Put
putWord32le Word32
0x73524742
put ColorSpaceType
WindowsColorSpace = Word32 -> Put
putWord32le Word32
0x57696E20
put (UnknownColorSpace Word32
x) = Word32 -> Put
putWord32le Word32
x
get :: Get ColorSpaceType
get = do
Word32
w <- Get Word32
getWord32le
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case Word32
w of
Word32
0 -> ColorSpaceType
CalibratedRGB
Word32
1 -> ColorSpaceType
DeviceDependentRGB
Word32
2 -> ColorSpaceType
DeviceDependentCMYK
Word32
0x4D424544 -> ColorSpaceType
ProfileEmbedded
Word32
0x4C494E4B -> ColorSpaceType
ProfileLinked
Word32
0x73524742 -> ColorSpaceType
SRGB
Word32
0x57696E20 -> ColorSpaceType
WindowsColorSpace
Word32
_ -> Word32 -> ColorSpaceType
UnknownColorSpace Word32
w
instance Binary BmpV5Header where
put :: BmpV5Header -> Put
put BmpV5Header
hdr = do
Word32 -> Put
putWord32le forall a b. (a -> b) -> a -> b
$ BmpV5Header -> Word32
size BmpV5Header
hdr
if (BmpV5Header -> Word32
size BmpV5Header
hdr forall a. Eq a => a -> a -> Bool
== Word32
sizeofBmpCoreHeader) then do
Word16 -> Put
putWord16le forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ BmpV5Header -> Int32
width BmpV5Header
hdr
Word16 -> Put
putWord16le forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ BmpV5Header -> Int32
height BmpV5Header
hdr
Word16 -> Put
putWord16le forall a b. (a -> b) -> a -> b
$ BmpV5Header -> Word16
planes BmpV5Header
hdr
Word16 -> Put
putWord16le forall a b. (a -> b) -> a -> b
$ BmpV5Header -> Word16
bitPerPixel BmpV5Header
hdr
else do
Int32 -> Put
putInt32le forall a b. (a -> b) -> a -> b
$ BmpV5Header -> Int32
width BmpV5Header
hdr
Int32 -> Put
putInt32le forall a b. (a -> b) -> a -> b
$ BmpV5Header -> Int32
height BmpV5Header
hdr
Word16 -> Put
putWord16le forall a b. (a -> b) -> a -> b
$ BmpV5Header -> Word16
planes BmpV5Header
hdr
Word16 -> Put
putWord16le forall a b. (a -> b) -> a -> b
$ BmpV5Header -> Word16
bitPerPixel BmpV5Header
hdr
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (BmpV5Header -> Word32
size BmpV5Header
hdr forall a. Ord a => a -> a -> Bool
> Word32
sizeofBmpCoreHeader) forall a b. (a -> b) -> a -> b
$ do
Word32 -> Put
putWord32le forall a b. (a -> b) -> a -> b
$ BmpV5Header -> Word32
bitmapCompression BmpV5Header
hdr
Word32 -> Put
putWord32le forall a b. (a -> b) -> a -> b
$ BmpV5Header -> Word32
byteImageSize BmpV5Header
hdr
Int32 -> Put
putInt32le forall a b. (a -> b) -> a -> b
$ BmpV5Header -> Int32
xResolution BmpV5Header
hdr
Int32 -> Put
putInt32le forall a b. (a -> b) -> a -> b
$ BmpV5Header -> Int32
yResolution BmpV5Header
hdr
Word32 -> Put
putWord32le forall a b. (a -> b) -> a -> b
$ BmpV5Header -> Word32
colorCount BmpV5Header
hdr
Word32 -> Put
putWord32le forall a b. (a -> b) -> a -> b
$ BmpV5Header -> Word32
importantColours BmpV5Header
hdr
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (BmpV5Header -> Word32
size BmpV5Header
hdr forall a. Ord a => a -> a -> Bool
> Word32
sizeofBmpInfoHeader Bool -> Bool -> Bool
|| BmpV5Header -> Word32
bitmapCompression BmpV5Header
hdr forall a. Eq a => a -> a -> Bool
== Word32
3) forall a b. (a -> b) -> a -> b
$ do
Word32 -> Put
putWord32le forall a b. (a -> b) -> a -> b
$ BmpV5Header -> Word32
redMask BmpV5Header
hdr
Word32 -> Put
putWord32le forall a b. (a -> b) -> a -> b
$ BmpV5Header -> Word32
greenMask BmpV5Header
hdr
Word32 -> Put
putWord32le forall a b. (a -> b) -> a -> b
$ BmpV5Header -> Word32
blueMask BmpV5Header
hdr
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (BmpV5Header -> Word32
size BmpV5Header
hdr forall a. Ord a => a -> a -> Bool
> Word32
sizeofBmpV2Header) forall a b. (a -> b) -> a -> b
$
Word32 -> Put
putWord32le forall a b. (a -> b) -> a -> b
$ BmpV5Header -> Word32
alphaMask BmpV5Header
hdr
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (BmpV5Header -> Word32
size BmpV5Header
hdr forall a. Ord a => a -> a -> Bool
> Word32
sizeofBmpV3Header) forall a b. (a -> b) -> a -> b
$ do
forall t. Binary t => t -> Put
put forall a b. (a -> b) -> a -> b
$ BmpV5Header -> ColorSpaceType
colorSpaceType BmpV5Header
hdr
ByteString -> Put
putByteString forall a b. (a -> b) -> a -> b
$ BmpV5Header -> ByteString
colorSpace BmpV5Header
hdr
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (BmpV5Header -> Word32
size BmpV5Header
hdr forall a. Ord a => a -> a -> Bool
> Word32
sizeofBmpV4Header) forall a b. (a -> b) -> a -> b
$ do
forall t. Binary t => t -> Put
put forall a b. (a -> b) -> a -> b
$ BmpV5Header -> Word32
iccIntent BmpV5Header
hdr
Word32 -> Put
putWord32le forall a b. (a -> b) -> a -> b
$ BmpV5Header -> Word32
iccProfileData BmpV5Header
hdr
Word32 -> Put
putWord32le forall a b. (a -> b) -> a -> b
$ BmpV5Header -> Word32
iccProfileSize BmpV5Header
hdr
Word32 -> Put
putWord32le Word32
0
get :: Get BmpV5Header
get = do
Word32
readSize <- Get Word32
getWord32le
if Word32
readSize forall a. Eq a => a -> a -> Bool
== Word32
sizeofBmpCoreHeader
then Word32 -> Get BmpV5Header
getBitmapCoreHeader Word32
readSize
else Word32 -> Get BmpV5Header
getBitmapInfoHeader Word32
readSize
where
getBitmapCoreHeader :: Word32 -> Get BmpV5Header
getBitmapCoreHeader Word32
readSize = do
Word16
readWidth <- Get Word16
getWord16le
Word16
readHeight <- Get Word16
getWord16le
Word16
readPlanes <- Get Word16
getWord16le
Word16
readBitPerPixel <- Get Word16
getWord16le
forall (m :: * -> *) a. Monad m => a -> m a
return BmpV5Header {
size :: Word32
size = Word32
readSize,
width :: Int32
width = forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
readWidth,
height :: Int32
height = forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
readHeight,
planes :: Word16
planes = Word16
readPlanes,
bitPerPixel :: Word16
bitPerPixel = Word16
readBitPerPixel,
bitmapCompression :: Word32
bitmapCompression = Word32
0,
byteImageSize :: Word32
byteImageSize = Word32
0,
xResolution :: Int32
xResolution = Int32
2835,
yResolution :: Int32
yResolution = Int32
2835,
colorCount :: Word32
colorCount = Word32
2 forall a b. (Num a, Integral b) => a -> b -> a
^ Word16
readBitPerPixel,
importantColours :: Word32
importantColours = Word32
0,
redMask :: Word32
redMask = Word32
0,
greenMask :: Word32
greenMask = Word32
0,
blueMask :: Word32
blueMask = Word32
0,
alphaMask :: Word32
alphaMask = Word32
0,
colorSpaceType :: ColorSpaceType
colorSpaceType = ColorSpaceType
DeviceDependentRGB,
colorSpace :: ByteString
colorSpace = ByteString
B.empty,
iccIntent :: Word32
iccIntent = Word32
0,
iccProfileData :: Word32
iccProfileData = Word32
0,
iccProfileSize :: Word32
iccProfileSize = Word32
0
}
getBitmapInfoHeader :: Word32 -> Get BmpV5Header
getBitmapInfoHeader Word32
readSize = do
Int32
readWidth <- Get Int32
getInt32le
Int32
readHeight <- Get Int32
getInt32le
Word16
readPlanes <- Get Word16
getWord16le
Word16
readBitPerPixel <- Get Word16
getWord16le
Word32
readBitmapCompression <- Get Word32
getWord32le
Word32
readByteImageSize <- Get Word32
getWord32le
Int32
readXResolution <- Get Int32
getInt32le
Int32
readYResolution <- Get Int32
getInt32le
Word32
readColorCount <- Get Word32
getWord32le
Word32
readImportantColours <- Get Word32
getWord32le
(Word32
readRedMask, Word32
readGreenMask, Word32
readBlueMask) <-
if Word32
readSize forall a. Eq a => a -> a -> Bool
== Word32
sizeofBmpInfoHeader Bool -> Bool -> Bool
&& Word32
readBitmapCompression forall a. Eq a => a -> a -> Bool
/= Word32
3
then forall (m :: * -> *) a. Monad m => a -> m a
return (Word32
0, Word32
0, Word32
0)
else do
Word32
innerReadRedMask <- Get Word32
getWord32le
Word32
innerReadGreenMask <- Get Word32
getWord32le
Word32
innerReadBlueMask <- Get Word32
getWord32le
forall (m :: * -> *) a. Monad m => a -> m a
return (Word32
innerReadRedMask, Word32
innerReadGreenMask, Word32
innerReadBlueMask)
Word32
readAlphaMask <- if Word32
readSize forall a. Ord a => a -> a -> Bool
< Word32
sizeofBmpV3Header then forall (m :: * -> *) a. Monad m => a -> m a
return Word32
0 else Get Word32
getWord32le
(ColorSpaceType
readColorSpaceType, ByteString
readColorSpace) <-
if Word32
readSize forall a. Ord a => a -> a -> Bool
< Word32
sizeofBmpV4Header
then forall (m :: * -> *) a. Monad m => a -> m a
return (ColorSpaceType
DeviceDependentRGB, ByteString
B.empty)
else do
ColorSpaceType
csType <- forall t. Binary t => Get t
get
ByteString
cs <- Int -> Get ByteString
getByteString Int
sizeofColorProfile
forall (m :: * -> *) a. Monad m => a -> m a
return (ColorSpaceType
csType, ByteString
cs)
(Word32
readIccIntent, Word32
readIccProfileData, Word32
readIccProfileSize) <-
if Word32
readSize forall a. Ord a => a -> a -> Bool
< Word32
sizeofBmpV5Header
then forall (m :: * -> *) a. Monad m => a -> m a
return (Word32
0, Word32
0, Word32
0)
else do
Word32
innerIccIntent <- Get Word32
getWord32le
Word32
innerIccProfileData <- Get Word32
getWord32le
Word32
innerIccProfileSize <- Get Word32
getWord32le
forall (f :: * -> *) a. Functor f => f a -> f ()
void Get Word32
getWord32le
forall (m :: * -> *) a. Monad m => a -> m a
return (Word32
innerIccIntent, Word32
innerIccProfileData, Word32
innerIccProfileSize)
forall (m :: * -> *) a. Monad m => a -> m a
return BmpV5Header {
size :: Word32
size = Word32
readSize,
width :: Int32
width = Int32
readWidth,
height :: Int32
height = Int32
readHeight,
planes :: Word16
planes = Word16
readPlanes,
bitPerPixel :: Word16
bitPerPixel = Word16
readBitPerPixel,
bitmapCompression :: Word32
bitmapCompression = Word32
readBitmapCompression,
byteImageSize :: Word32
byteImageSize = Word32
readByteImageSize,
xResolution :: Int32
xResolution = Int32
readXResolution,
yResolution :: Int32
yResolution = Int32
readYResolution,
colorCount :: Word32
colorCount = Word32
readColorCount,
importantColours :: Word32
importantColours = Word32
readImportantColours,
redMask :: Word32
redMask = Word32
readRedMask,
greenMask :: Word32
greenMask = Word32
readGreenMask,
blueMask :: Word32
blueMask = Word32
readBlueMask,
alphaMask :: Word32
alphaMask = Word32
readAlphaMask,
colorSpaceType :: ColorSpaceType
colorSpaceType = ColorSpaceType
readColorSpaceType,
colorSpace :: ByteString
colorSpace = ByteString
readColorSpace,
iccIntent :: Word32
iccIntent = Word32
readIccIntent,
iccProfileData :: Word32
iccProfileData = Word32
readIccProfileData,
iccProfileSize :: Word32
iccProfileSize = Word32
readIccProfileSize
}
newtype BmpPalette = BmpPalette [(Word8, Word8, Word8, Word8)]
putPalette :: BmpPalette -> Put
putPalette :: BmpPalette -> Put
putPalette (BmpPalette [(Word8, Word8, Word8, Word8)]
p) = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\(Word8
r, Word8
g, Word8
b, Word8
a) -> forall t. Binary t => t -> Put
put Word8
r forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall t. Binary t => t -> Put
put Word8
g forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall t. Binary t => t -> Put
put Word8
b forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall t. Binary t => t -> Put
put Word8
a) [(Word8, Word8, Word8, Word8)]
p
putICCProfile :: Maybe B.ByteString -> Put
putICCProfile :: Maybe ByteString -> Put
putICCProfile Maybe ByteString
Nothing = forall (m :: * -> *) a. Monad m => a -> m a
return ()
putICCProfile (Just ByteString
bytes) = forall t. Binary t => t -> Put
put ByteString
bytes
class BmpEncodable pixel where
bitsPerPixel :: pixel -> Int
bmpEncode :: Image pixel -> Put
hasAlpha :: Image pixel -> Bool
defaultPalette :: pixel -> BmpPalette
defaultPalette pixel
_ = [(Word8, Word8, Word8, Word8)] -> BmpPalette
BmpPalette []
stridePut :: M.STVector s Word8 -> Int -> Int -> ST s ()
{-# INLINE stridePut #-}
stridePut :: forall s. STVector s Word8 -> Int -> Int -> ST s ()
stridePut STVector s Word8
vec = Int -> Int -> ST s ()
inner
where inner :: Int -> Int -> ST s ()
inner Int
_ Int
0 = forall (m :: * -> *) a. Monad m => a -> m a
return ()
inner Int
ix Int
n = do
(STVector s Word8
vec forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` Int
ix) Word8
0
Int -> Int -> ST s ()
inner (Int
ix forall a. Num a => a -> a -> a
+ Int
1) (Int
n forall a. Num a => a -> a -> a
- Int
1)
instance BmpEncodable Pixel8 where
hasAlpha :: Image Word8 -> Bool
hasAlpha Image Word8
_ = Bool
False
defaultPalette :: Word8 -> BmpPalette
defaultPalette Word8
_ = [(Word8, Word8, Word8, Word8)] -> BmpPalette
BmpPalette [(Word8
x,Word8
x,Word8
x, Word8
255) | Word8
x <- [Word8
0 .. Word8
255]]
bitsPerPixel :: Word8 -> Int
bitsPerPixel Word8
_ = Int
8
bmpEncode :: Image Word8 -> Put
bmpEncode (Image {imageWidth :: forall a. Image a -> Int
imageWidth = Int
w, imageHeight :: forall a. Image a -> Int
imageHeight = Int
h, imageData :: forall a. Image a -> Vector (PixelBaseComponent a)
imageData = Vector (PixelBaseComponent Word8)
arr}) =
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
h forall a. Num a => a -> a -> a
- Int
1, Int
h forall a. Num a => a -> a -> a
- Int
2 .. Int
0] forall a b. (a -> b) -> a -> b
$ \Int
l -> Vector Word8 -> Put
putVector forall a b. (a -> b) -> a -> b
$ forall a. (forall s. ST s a) -> a
runST forall a b. (a -> b) -> a -> b
$ forall s. Int -> ST s (Vector Word8)
encodeLine Int
l
where stride :: Int
stride = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int
linePadding Int
8 Int
w
putVector :: Vector Word8 -> Put
putVector Vector Word8
vec = ByteString -> Put
putByteString forall a b. (a -> b) -> a -> b
$ Vector Word8 -> Int -> Int -> ByteString
blitVector Vector Word8
vec Int
0 Int
lineWidth
lineWidth :: Int
lineWidth = Int
w forall a. Num a => a -> a -> a
+ Int
stride
encodeLine :: forall s. Int -> ST s (VS.Vector Word8)
encodeLine :: forall s. Int -> ST s (Vector Word8)
encodeLine Int
line = do
STVector s Word8
buff <- forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
Int -> m (MVector (PrimState m) a)
M.new Int
lineWidth
let lineIdx :: Int
lineIdx = Int
line forall a. Num a => a -> a -> a
* Int
w
inner :: Int -> ST s ()
inner Int
col | Int
col forall a. Ord a => a -> a -> Bool
>= Int
w = forall (m :: * -> *) a. Monad m => a -> m a
return ()
inner Int
col = do
let v :: Word8
v = Vector (PixelBaseComponent Word8)
arr forall a. Storable a => Vector a -> Int -> a
`VS.unsafeIndex` (Int
lineIdx forall a. Num a => a -> a -> a
+ Int
col)
(STVector s Word8
buff forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` Int
col) Word8
v
Int -> ST s ()
inner (Int
col forall a. Num a => a -> a -> a
+ Int
1)
Int -> ST s ()
inner Int
0
forall s. STVector s Word8 -> Int -> Int -> ST s ()
stridePut STVector s Word8
buff Int
w Int
stride
forall a (m :: * -> *).
(Storable a, PrimMonad m) =>
MVector (PrimState m) a -> m (Vector a)
VS.unsafeFreeze STVector s Word8
buff
instance BmpEncodable PixelRGBA8 where
hasAlpha :: Image PixelRGBA8 -> Bool
hasAlpha Image PixelRGBA8
_ = Bool
True
bitsPerPixel :: PixelRGBA8 -> Int
bitsPerPixel PixelRGBA8
_ = Int
32
bmpEncode :: Image PixelRGBA8 -> Put
bmpEncode (Image {imageWidth :: forall a. Image a -> Int
imageWidth = Int
w, imageHeight :: forall a. Image a -> Int
imageHeight = Int
h, imageData :: forall a. Image a -> Vector (PixelBaseComponent a)
imageData = Vector (PixelBaseComponent PixelRGBA8)
arr}) =
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
h forall a. Num a => a -> a -> a
- Int
1, Int
h forall a. Num a => a -> a -> a
- Int
2 .. Int
0] forall a b. (a -> b) -> a -> b
$ \Int
l -> Vector Word8 -> Put
putVector forall a b. (a -> b) -> a -> b
$ forall a. (forall s. ST s a) -> a
runST forall a b. (a -> b) -> a -> b
$ forall s. Int -> ST s (Vector Word8)
putLine Int
l
where
putVector :: Vector Word8 -> Put
putVector Vector Word8
vec = ByteString -> Put
putByteString forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector Word8 -> Int -> Int -> ByteString
blitVector Vector Word8
vec Int
0 forall a b. (a -> b) -> a -> b
$ Int
w forall a. Num a => a -> a -> a
* Int
4
putLine :: forall s. Int -> ST s (VS.Vector Word8)
putLine :: forall s. Int -> ST s (Vector Word8)
putLine Int
line = do
MVector s Word8
buff <- forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
Int -> m (MVector (PrimState m) a)
M.new forall a b. (a -> b) -> a -> b
$ Int
4 forall a. Num a => a -> a -> a
* Int
w
let initialIndex :: Int
initialIndex = Int
line forall a. Num a => a -> a -> a
* Int
w forall a. Num a => a -> a -> a
* Int
4
inner :: Int -> Int -> Int -> ST s ()
inner Int
col Int
_ Int
_ | Int
col forall a. Ord a => a -> a -> Bool
>= Int
w = forall (m :: * -> *) a. Monad m => a -> m a
return ()
inner Int
col Int
writeIdx Int
readIdx = do
let r :: Word8
r = Vector (PixelBaseComponent PixelRGBA8)
arr forall a. Storable a => Vector a -> Int -> a
`VS.unsafeIndex` Int
readIdx
g :: Word8
g = Vector (PixelBaseComponent PixelRGBA8)
arr forall a. Storable a => Vector a -> Int -> a
`VS.unsafeIndex` (Int
readIdx forall a. Num a => a -> a -> a
+ Int
1)
b :: Word8
b = Vector (PixelBaseComponent PixelRGBA8)
arr forall a. Storable a => Vector a -> Int -> a
`VS.unsafeIndex` (Int
readIdx forall a. Num a => a -> a -> a
+ Int
2)
a :: Word8
a = Vector (PixelBaseComponent PixelRGBA8)
arr forall a. Storable a => Vector a -> Int -> a
`VS.unsafeIndex` (Int
readIdx forall a. Num a => a -> a -> a
+ Int
3)
(MVector s Word8
buff forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` Int
writeIdx) Word8
b
(MVector s Word8
buff forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` (Int
writeIdx forall a. Num a => a -> a -> a
+ Int
1)) Word8
g
(MVector s Word8
buff forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` (Int
writeIdx forall a. Num a => a -> a -> a
+ Int
2)) Word8
r
(MVector s Word8
buff forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` (Int
writeIdx forall a. Num a => a -> a -> a
+ Int
3)) Word8
a
Int -> Int -> Int -> ST s ()
inner (Int
col forall a. Num a => a -> a -> a
+ Int
1) (Int
writeIdx forall a. Num a => a -> a -> a
+ Int
4) (Int
readIdx forall a. Num a => a -> a -> a
+ Int
4)
Int -> Int -> Int -> ST s ()
inner Int
0 Int
0 Int
initialIndex
forall a (m :: * -> *).
(Storable a, PrimMonad m) =>
MVector (PrimState m) a -> m (Vector a)
VS.unsafeFreeze MVector s Word8
buff
instance BmpEncodable PixelRGB8 where
hasAlpha :: Image PixelRGB8 -> Bool
hasAlpha Image PixelRGB8
_ = Bool
False
bitsPerPixel :: PixelRGB8 -> Int
bitsPerPixel PixelRGB8
_ = Int
24
bmpEncode :: Image PixelRGB8 -> Put
bmpEncode (Image {imageWidth :: forall a. Image a -> Int
imageWidth = Int
w, imageHeight :: forall a. Image a -> Int
imageHeight = Int
h, imageData :: forall a. Image a -> Vector (PixelBaseComponent a)
imageData = Vector (PixelBaseComponent PixelRGB8)
arr}) =
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
h forall a. Num a => a -> a -> a
- Int
1, Int
h forall a. Num a => a -> a -> a
- Int
2 .. Int
0] forall a b. (a -> b) -> a -> b
$ \Int
l -> Vector Word8 -> Put
putVector forall a b. (a -> b) -> a -> b
$ forall a. (forall s. ST s a) -> a
runST forall a b. (a -> b) -> a -> b
$ forall s. Int -> ST s (Vector Word8)
putLine Int
l
where
stride :: Int
stride = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int -> Int
linePadding Int
24 forall a b. (a -> b) -> a -> b
$ Int
w
putVector :: Vector Word8 -> Put
putVector Vector Word8
vec = ByteString -> Put
putByteString forall a b. (a -> b) -> a -> b
$ Vector Word8 -> Int -> Int -> ByteString
blitVector Vector Word8
vec Int
0 (Int
w forall a. Num a => a -> a -> a
* Int
3 forall a. Num a => a -> a -> a
+ Int
stride)
putLine :: forall s. Int -> ST s (VS.Vector Word8)
putLine :: forall s. Int -> ST s (Vector Word8)
putLine Int
line = do
MVector s Word8
buff <- forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
Int -> m (MVector (PrimState m) a)
M.new forall a b. (a -> b) -> a -> b
$ Int
w forall a. Num a => a -> a -> a
* Int
3 forall a. Num a => a -> a -> a
+ Int
stride
let initialIndex :: Int
initialIndex = Int
line forall a. Num a => a -> a -> a
* Int
w forall a. Num a => a -> a -> a
* Int
3
inner :: Int -> Int -> Int -> ST s ()
inner Int
col Int
_ Int
_ | Int
col forall a. Ord a => a -> a -> Bool
>= Int
w = forall (m :: * -> *) a. Monad m => a -> m a
return ()
inner Int
col Int
writeIdx Int
readIdx = do
let r :: Word8
r = Vector (PixelBaseComponent PixelRGB8)
arr forall a. Storable a => Vector a -> Int -> a
`VS.unsafeIndex` Int
readIdx
g :: Word8
g = Vector (PixelBaseComponent PixelRGB8)
arr forall a. Storable a => Vector a -> Int -> a
`VS.unsafeIndex` (Int
readIdx forall a. Num a => a -> a -> a
+ Int
1)
b :: Word8
b = Vector (PixelBaseComponent PixelRGB8)
arr forall a. Storable a => Vector a -> Int -> a
`VS.unsafeIndex` (Int
readIdx forall a. Num a => a -> a -> a
+ Int
2)
(MVector s Word8
buff forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` Int
writeIdx) Word8
b
(MVector s Word8
buff forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` (Int
writeIdx forall a. Num a => a -> a -> a
+ Int
1)) Word8
g
(MVector s Word8
buff forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` (Int
writeIdx forall a. Num a => a -> a -> a
+ Int
2)) Word8
r
Int -> Int -> Int -> ST s ()
inner (Int
col forall a. Num a => a -> a -> a
+ Int
1) (Int
writeIdx forall a. Num a => a -> a -> a
+ Int
3) (Int
readIdx forall a. Num a => a -> a -> a
+ Int
3)
Int -> Int -> Int -> ST s ()
inner Int
0 Int
0 Int
initialIndex
forall a (m :: * -> *).
(Storable a, PrimMonad m) =>
MVector (PrimState m) a -> m (Vector a)
VS.unsafeFreeze MVector s Word8
buff
data Bitfield t = Bitfield
{ forall t. Bitfield t -> t
bfMask :: !t
, forall t. Bitfield t -> Int
bfShift :: !Int
, forall t. Bitfield t -> Float
bfScale :: !Float
} deriving (Bitfield t -> Bitfield t -> Bool
forall t. Eq t => Bitfield t -> Bitfield t -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Bitfield t -> Bitfield t -> Bool
$c/= :: forall t. Eq t => Bitfield t -> Bitfield t -> Bool
== :: Bitfield t -> Bitfield t -> Bool
$c== :: forall t. Eq t => Bitfield t -> Bitfield t -> Bool
Eq, Int -> Bitfield t -> ShowS
forall t. Show t => Int -> Bitfield t -> ShowS
forall t. Show t => [Bitfield t] -> ShowS
forall t. Show t => Bitfield t -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Bitfield t] -> ShowS
$cshowList :: forall t. Show t => [Bitfield t] -> ShowS
show :: Bitfield t -> String
$cshow :: forall t. Show t => Bitfield t -> String
showsPrec :: Int -> Bitfield t -> ShowS
$cshowsPrec :: forall t. Show t => Int -> Bitfield t -> ShowS
Show)
data Bitfields4 t = Bitfields4 !(Bitfield t)
!(Bitfield t)
!(Bitfield t)
!(Bitfield t)
deriving (Bitfields4 t -> Bitfields4 t -> Bool
forall t. Eq t => Bitfields4 t -> Bitfields4 t -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Bitfields4 t -> Bitfields4 t -> Bool
$c/= :: forall t. Eq t => Bitfields4 t -> Bitfields4 t -> Bool
== :: Bitfields4 t -> Bitfields4 t -> Bool
$c== :: forall t. Eq t => Bitfields4 t -> Bitfields4 t -> Bool
Eq, Int -> Bitfields4 t -> ShowS
forall t. Show t => Int -> Bitfields4 t -> ShowS
forall t. Show t => [Bitfields4 t] -> ShowS
forall t. Show t => Bitfields4 t -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Bitfields4 t] -> ShowS
$cshowList :: forall t. Show t => [Bitfields4 t] -> ShowS
show :: Bitfields4 t -> String
$cshow :: forall t. Show t => Bitfields4 t -> String
showsPrec :: Int -> Bitfields4 t -> ShowS
$cshowsPrec :: forall t. Show t => Int -> Bitfields4 t -> ShowS
Show)
defaultBitfieldsRGB32 :: Bitfields3 Word32
defaultBitfieldsRGB32 :: Bitfields3 Word32
defaultBitfieldsRGB32 = forall t. Bitfield t -> Bitfield t -> Bitfield t -> Bitfields3 t
Bitfields3 (forall t. (FiniteBits t, Integral t) => t -> Bitfield t
makeBitfield Word32
0x00FF0000)
(forall t. (FiniteBits t, Integral t) => t -> Bitfield t
makeBitfield Word32
0x0000FF00)
(forall t. (FiniteBits t, Integral t) => t -> Bitfield t
makeBitfield Word32
0x000000FF)
defaultBitfieldsRGB16 :: Bitfields3 Word16
defaultBitfieldsRGB16 :: Bitfields3 Word16
defaultBitfieldsRGB16 = forall t. Bitfield t -> Bitfield t -> Bitfield t -> Bitfields3 t
Bitfields3 (forall t. (FiniteBits t, Integral t) => t -> Bitfield t
makeBitfield Word16
0x7C00)
(forall t. (FiniteBits t, Integral t) => t -> Bitfield t
makeBitfield Word16
0x03E0)
(forall t. (FiniteBits t, Integral t) => t -> Bitfield t
makeBitfield Word16
0x001F)
data Bitfields3 t = Bitfields3 !(Bitfield t)
!(Bitfield t)
!(Bitfield t)
deriving (Bitfields3 t -> Bitfields3 t -> Bool
forall t. Eq t => Bitfields3 t -> Bitfields3 t -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Bitfields3 t -> Bitfields3 t -> Bool
$c/= :: forall t. Eq t => Bitfields3 t -> Bitfields3 t -> Bool
== :: Bitfields3 t -> Bitfields3 t -> Bool
$c== :: forall t. Eq t => Bitfields3 t -> Bitfields3 t -> Bool
Eq, Int -> Bitfields3 t -> ShowS
forall t. Show t => Int -> Bitfields3 t -> ShowS
forall t. Show t => [Bitfields3 t] -> ShowS
forall t. Show t => Bitfields3 t -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Bitfields3 t] -> ShowS
$cshowList :: forall t. Show t => [Bitfields3 t] -> ShowS
show :: Bitfields3 t -> String
$cshow :: forall t. Show t => Bitfields3 t -> String
showsPrec :: Int -> Bitfields3 t -> ShowS
$cshowsPrec :: forall t. Show t => Int -> Bitfields3 t -> ShowS
Show)
data RGBABmpFormat = RGBA32 !(Bitfields4 Word32)
| RGBA16 !(Bitfields4 Word16)
deriving (RGBABmpFormat -> RGBABmpFormat -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RGBABmpFormat -> RGBABmpFormat -> Bool
$c/= :: RGBABmpFormat -> RGBABmpFormat -> Bool
== :: RGBABmpFormat -> RGBABmpFormat -> Bool
$c== :: RGBABmpFormat -> RGBABmpFormat -> Bool
Eq, Int -> RGBABmpFormat -> ShowS
[RGBABmpFormat] -> ShowS
RGBABmpFormat -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RGBABmpFormat] -> ShowS
$cshowList :: [RGBABmpFormat] -> ShowS
show :: RGBABmpFormat -> String
$cshow :: RGBABmpFormat -> String
showsPrec :: Int -> RGBABmpFormat -> ShowS
$cshowsPrec :: Int -> RGBABmpFormat -> ShowS
Show)
data RGBBmpFormat = RGB32 !(Bitfields3 Word32)
| RGB24
| RGB16 !(Bitfields3 Word16)
deriving (RGBBmpFormat -> RGBBmpFormat -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RGBBmpFormat -> RGBBmpFormat -> Bool
$c/= :: RGBBmpFormat -> RGBBmpFormat -> Bool
== :: RGBBmpFormat -> RGBBmpFormat -> Bool
$c== :: RGBBmpFormat -> RGBBmpFormat -> Bool
Eq, Int -> RGBBmpFormat -> ShowS
[RGBBmpFormat] -> ShowS
RGBBmpFormat -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RGBBmpFormat] -> ShowS
$cshowList :: [RGBBmpFormat] -> ShowS
show :: RGBBmpFormat -> String
$cshow :: RGBBmpFormat -> String
showsPrec :: Int -> RGBBmpFormat -> ShowS
$cshowsPrec :: Int -> RGBBmpFormat -> ShowS
Show)
data IndexedBmpFormat = OneBPP | FourBPP | EightBPP deriving Int -> IndexedBmpFormat -> ShowS
[IndexedBmpFormat] -> ShowS
IndexedBmpFormat -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [IndexedBmpFormat] -> ShowS
$cshowList :: [IndexedBmpFormat] -> ShowS
show :: IndexedBmpFormat -> String
$cshow :: IndexedBmpFormat -> String
showsPrec :: Int -> IndexedBmpFormat -> ShowS
$cshowsPrec :: Int -> IndexedBmpFormat -> ShowS
Show
extractBitfield :: (FiniteBits t, Integral t) => Bitfield t -> t -> Word8
Bitfield t
bf t
t = if forall t. Bitfield t -> Float
bfScale Bitfield t
bf forall a. Eq a => a -> a -> Bool
== Float
1
then forall a b. (Integral a, Num b) => a -> b
fromIntegral t
field
else forall a b. (RealFrac a, Integral b) => a -> b
round forall a b. (a -> b) -> a -> b
$ forall t. Bitfield t -> Float
bfScale Bitfield t
bf forall a. Num a => a -> a -> a
* forall a b. (Integral a, Num b) => a -> b
fromIntegral t
field
where field :: t
field = (t
t forall a. Bits a => a -> a -> a
.&. forall t. Bitfield t -> t
bfMask Bitfield t
bf) forall a. Bits a => a -> Int -> a
`unsafeShiftR` forall t. Bitfield t -> Int
bfShift Bitfield t
bf
makeBitfield :: (FiniteBits t, Integral t) => t -> Bitfield t
makeBitfield :: forall t. (FiniteBits t, Integral t) => t -> Bitfield t
makeBitfield t
mask = forall t. t -> Int -> Float -> Bitfield t
Bitfield t
mask Int
shiftBits Float
scale
where
shiftBits :: Int
shiftBits = forall b. FiniteBits b => b -> Int
countTrailingZeros t
mask
scale :: Float
scale = Float
255 forall a. Fractional a => a -> a -> a
/ forall a b. (Integral a, Num b) => a -> b
fromIntegral (t
mask forall a. Bits a => a -> Int -> a
`unsafeShiftR` Int
shiftBits)
castByteString :: VS.Storable a => B.ByteString -> VS.Vector a
#if MIN_VERSION_bytestring(0,11,0)
castByteString :: forall a. Storable a => ByteString -> Vector a
castByteString (BI.BS ForeignPtr Word8
fp Int
len) = forall a b. (Storable a, Storable b) => Vector a -> Vector b
VS.unsafeCast forall a b. (a -> b) -> a -> b
$ forall a. Storable a => ForeignPtr a -> Int -> Int -> Vector a
VS.unsafeFromForeignPtr ForeignPtr Word8
fp Int
0 Int
len
#else
castByteString (BI.PS fp offset len) = VS.unsafeCast $ VS.unsafeFromForeignPtr fp offset len
#endif
decodeImageRGBA8 :: RGBABmpFormat -> BmpV5Header -> B.ByteString -> Image PixelRGBA8
decodeImageRGBA8 :: RGBABmpFormat -> BmpV5Header -> ByteString -> Image PixelRGBA8
decodeImageRGBA8 RGBABmpFormat
pixelFormat (BmpV5Header { width :: BmpV5Header -> Int32
width = Int32
w, height :: BmpV5Header -> Int32
height = Int32
h, bitPerPixel :: BmpV5Header -> Word16
bitPerPixel = Word16
bpp }) ByteString
str = forall a. Int -> Int -> Vector (PixelBaseComponent a) -> Image a
Image Int
wi Int
hi Vector Word8
stArray where
wi :: Int
wi = forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
w
hi :: Int
hi = forall a. Num a => a -> a
abs forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
h
stArray :: Vector Word8
stArray = forall a. (forall s. ST s a) -> a
runST forall a b. (a -> b) -> a -> b
$ do
MVector s Word8
arr <- forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
Int -> m (MVector (PrimState m) a)
M.new (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Int32
w forall a. Num a => a -> a -> a
* forall a. Num a => a -> a
abs Int32
h forall a. Num a => a -> a -> a
* Int32
4)
if Int32
h forall a. Ord a => a -> a -> Bool
> Int32
0 then
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m ()
foldM_ (forall s. MVector s Word8 -> Int -> Int -> ST s Int
readLine MVector s Word8
arr) Int
0 [Int
0 .. Int
hi forall a. Num a => a -> a -> a
- Int
1]
else
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m ()
foldM_ (forall s. MVector s Word8 -> Int -> Int -> ST s Int
readLine MVector s Word8
arr) Int
0 [Int
hi forall a. Num a => a -> a -> a
- Int
1, Int
hi forall a. Num a => a -> a -> a
- Int
2 .. Int
0]
forall a (m :: * -> *).
(Storable a, PrimMonad m) =>
MVector (PrimState m) a -> m (Vector a)
VS.unsafeFreeze MVector s Word8
arr
paddingWords :: Int
paddingWords = (Int
8 forall a. Num a => a -> a -> a
* Int -> Int -> Int
linePadding Int
intBPP Int
wi) forall a. Integral a => a -> a -> a
`div` Int
intBPP
intBPP :: Int
intBPP = forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
bpp
readLine :: forall s. M.MVector s Word8 -> Int -> Int -> ST s Int
readLine :: forall s. MVector s Word8 -> Int -> Int -> ST s Int
readLine MVector s Word8
arr Int
readIndex Int
line = case RGBABmpFormat
pixelFormat of
RGBA32 Bitfields4 Word32
bitfields -> forall t.
(FiniteBits t, Integral t, Storable t, Show t) =>
Bitfields4 t -> Vector t -> Int -> Int -> ST s Int
inner Bitfields4 Word32
bitfields (forall a. Storable a => ByteString -> Vector a
castByteString ByteString
str) Int
readIndex Int
writeIndex
RGBA16 Bitfields4 Word16
bitfields -> forall t.
(FiniteBits t, Integral t, Storable t, Show t) =>
Bitfields4 t -> Vector t -> Int -> Int -> ST s Int
inner Bitfields4 Word16
bitfields (forall a. Storable a => ByteString -> Vector a
castByteString ByteString
str) Int
readIndex Int
writeIndex
where
lastIndex :: Int
lastIndex = Int
wi forall a. Num a => a -> a -> a
* (Int
hi forall a. Num a => a -> a -> a
- Int
1 forall a. Num a => a -> a -> a
- Int
line forall a. Num a => a -> a -> a
+ Int
1) forall a. Num a => a -> a -> a
* Int
4
writeIndex :: Int
writeIndex = Int
wi forall a. Num a => a -> a -> a
* (Int
hi forall a. Num a => a -> a -> a
- Int
1 forall a. Num a => a -> a -> a
- Int
line) forall a. Num a => a -> a -> a
* Int
4
inner
:: (FiniteBits t, Integral t, M.Storable t, Show t)
=> Bitfields4 t
-> VS.Vector t
-> Int
-> Int
-> ST s Int
inner :: forall t.
(FiniteBits t, Integral t, Storable t, Show t) =>
Bitfields4 t -> Vector t -> Int -> Int -> ST s Int
inner (Bitfields4 Bitfield t
r Bitfield t
g Bitfield t
b Bitfield t
a) Vector t
inStr = Int -> Int -> ST s Int
inner0
where
inner0 :: Int -> Int -> ST s Int
inner0 :: Int -> Int -> ST s Int
inner0 Int
readIdx Int
writeIdx | Int
writeIdx forall a. Ord a => a -> a -> Bool
>= Int
lastIndex = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Int
readIdx forall a. Num a => a -> a -> a
+ Int
paddingWords
inner0 Int
readIdx Int
writeIdx = do
let word :: t
word = Vector t
inStr forall a. Storable a => Vector a -> Int -> a
VS.! Int
readIdx
(MVector s Word8
arr forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` Int
writeIdx ) (forall t. (FiniteBits t, Integral t) => Bitfield t -> t -> Word8
extractBitfield Bitfield t
r t
word)
(MVector s Word8
arr forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` (Int
writeIdx forall a. Num a => a -> a -> a
+ Int
1)) (forall t. (FiniteBits t, Integral t) => Bitfield t -> t -> Word8
extractBitfield Bitfield t
g t
word)
(MVector s Word8
arr forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` (Int
writeIdx forall a. Num a => a -> a -> a
+ Int
2)) (forall t. (FiniteBits t, Integral t) => Bitfield t -> t -> Word8
extractBitfield Bitfield t
b t
word)
(MVector s Word8
arr forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` (Int
writeIdx forall a. Num a => a -> a -> a
+ Int
3)) (forall t. (FiniteBits t, Integral t) => Bitfield t -> t -> Word8
extractBitfield Bitfield t
a t
word)
Int -> Int -> ST s Int
inner0 (Int
readIdx forall a. Num a => a -> a -> a
+ Int
1) (Int
writeIdx forall a. Num a => a -> a -> a
+ Int
4)
decodeImageRGB8 :: RGBBmpFormat -> BmpV5Header -> B.ByteString -> Image PixelRGB8
decodeImageRGB8 :: RGBBmpFormat -> BmpV5Header -> ByteString -> Image PixelRGB8
decodeImageRGB8 RGBBmpFormat
pixelFormat (BmpV5Header { width :: BmpV5Header -> Int32
width = Int32
w, height :: BmpV5Header -> Int32
height = Int32
h, bitPerPixel :: BmpV5Header -> Word16
bitPerPixel = Word16
bpp }) ByteString
str = forall a. Int -> Int -> Vector (PixelBaseComponent a) -> Image a
Image Int
wi Int
hi Vector Word8
stArray where
wi :: Int
wi = forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
w
hi :: Int
hi = forall a. Num a => a -> a
abs forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
h
stArray :: Vector Word8
stArray = forall a. (forall s. ST s a) -> a
runST forall a b. (a -> b) -> a -> b
$ do
MVector s Word8
arr <- forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
Int -> m (MVector (PrimState m) a)
M.new (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Int32
w forall a. Num a => a -> a -> a
* forall a. Num a => a -> a
abs Int32
h forall a. Num a => a -> a -> a
* Int32
3)
if Int32
h forall a. Ord a => a -> a -> Bool
> Int32
0 then
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m ()
foldM_ (forall s. MVector s Word8 -> Int -> Int -> ST s Int
readLine MVector s Word8
arr) Int
0 [Int
0 .. Int
hi forall a. Num a => a -> a -> a
- Int
1]
else
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m ()
foldM_ (forall s. MVector s Word8 -> Int -> Int -> ST s Int
readLine MVector s Word8
arr) Int
0 [Int
hi forall a. Num a => a -> a -> a
- Int
1, Int
hi forall a. Num a => a -> a -> a
- Int
2 .. Int
0]
forall a (m :: * -> *).
(Storable a, PrimMonad m) =>
MVector (PrimState m) a -> m (Vector a)
VS.unsafeFreeze MVector s Word8
arr
paddingBytes :: Int
paddingBytes = Int -> Int -> Int
linePadding Int
intBPP Int
wi
paddingWords :: Int
paddingWords = (Int -> Int -> Int
linePadding Int
intBPP Int
wi forall a. Num a => a -> a -> a
* Int
8) forall a. Integral a => a -> a -> a
`div` Int
intBPP
intBPP :: Int
intBPP = forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
bpp
readLine :: forall s. M.MVector s Word8 -> Int -> Int -> ST s Int
readLine :: forall s. MVector s Word8 -> Int -> Int -> ST s Int
readLine MVector s Word8
arr Int
readIndex Int
line = case RGBBmpFormat
pixelFormat of
RGB16 Bitfields3 Word16
bitfields -> forall t.
(FiniteBits t, Integral t, Storable t, Show t) =>
Bitfields3 t -> Vector t -> Int -> Int -> ST s Int
innerBF Bitfields3 Word16
bitfields (forall a. Storable a => ByteString -> Vector a
castByteString ByteString
str) Int
readIndex Int
writeIndex
RGB32 Bitfields3 Word32
bitfields -> forall t.
(FiniteBits t, Integral t, Storable t, Show t) =>
Bitfields3 t -> Vector t -> Int -> Int -> ST s Int
innerBF Bitfields3 Word32
bitfields (forall a. Storable a => ByteString -> Vector a
castByteString ByteString
str) Int
readIndex Int
writeIndex
RGBBmpFormat
RGB24 -> Int -> Int -> ST s Int
inner24 Int
readIndex Int
writeIndex
where
lastIndex :: Int
lastIndex = Int
wi forall a. Num a => a -> a -> a
* (Int
hi forall a. Num a => a -> a -> a
- Int
1 forall a. Num a => a -> a -> a
- Int
line forall a. Num a => a -> a -> a
+ Int
1) forall a. Num a => a -> a -> a
* Int
3
writeIndex :: Int
writeIndex = Int
wi forall a. Num a => a -> a -> a
* (Int
hi forall a. Num a => a -> a -> a
- Int
1 forall a. Num a => a -> a -> a
- Int
line) forall a. Num a => a -> a -> a
* Int
3
inner24 :: Int -> Int -> ST s Int
inner24 Int
readIdx Int
writeIdx | Int
writeIdx forall a. Ord a => a -> a -> Bool
>= Int
lastIndex = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Int
readIdx forall a. Num a => a -> a -> a
+ Int
paddingBytes
inner24 Int
readIdx Int
writeIdx = do
(MVector s Word8
arr forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` Int
writeIdx ) (ByteString
str HasCallStack => ByteString -> Int -> Word8
`B.index` (Int
readIdx forall a. Num a => a -> a -> a
+ Int
2))
(MVector s Word8
arr forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` (Int
writeIdx forall a. Num a => a -> a -> a
+ Int
1)) (ByteString
str HasCallStack => ByteString -> Int -> Word8
`B.index` (Int
readIdx forall a. Num a => a -> a -> a
+ Int
1))
(MVector s Word8
arr forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` (Int
writeIdx forall a. Num a => a -> a -> a
+ Int
2)) (ByteString
str HasCallStack => ByteString -> Int -> Word8
`B.index` Int
readIdx)
Int -> Int -> ST s Int
inner24 (Int
readIdx forall a. Num a => a -> a -> a
+ Int
3) (Int
writeIdx forall a. Num a => a -> a -> a
+ Int
3)
innerBF
:: (FiniteBits t, Integral t, M.Storable t, Show t)
=> Bitfields3 t
-> VS.Vector t
-> Int
-> Int
-> ST s Int
innerBF :: forall t.
(FiniteBits t, Integral t, Storable t, Show t) =>
Bitfields3 t -> Vector t -> Int -> Int -> ST s Int
innerBF (Bitfields3 Bitfield t
r Bitfield t
g Bitfield t
b) Vector t
inStr = Int -> Int -> ST s Int
innerBF0
where
innerBF0 :: Int -> Int -> ST s Int
innerBF0 :: Int -> Int -> ST s Int
innerBF0 Int
readIdx Int
writeIdx | Int
writeIdx forall a. Ord a => a -> a -> Bool
>= Int
lastIndex = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Int
readIdx forall a. Num a => a -> a -> a
+ Int
paddingWords
innerBF0 Int
readIdx Int
writeIdx = do
let word :: t
word = Vector t
inStr forall a. Storable a => Vector a -> Int -> a
VS.! Int
readIdx
(MVector s Word8
arr forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` Int
writeIdx ) (forall t. (FiniteBits t, Integral t) => Bitfield t -> t -> Word8
extractBitfield Bitfield t
r t
word)
(MVector s Word8
arr forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` (Int
writeIdx forall a. Num a => a -> a -> a
+ Int
1)) (forall t. (FiniteBits t, Integral t) => Bitfield t -> t -> Word8
extractBitfield Bitfield t
g t
word)
(MVector s Word8
arr forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` (Int
writeIdx forall a. Num a => a -> a -> a
+ Int
2)) (forall t. (FiniteBits t, Integral t) => Bitfield t -> t -> Word8
extractBitfield Bitfield t
b t
word)
Int -> Int -> ST s Int
innerBF0 (Int
readIdx forall a. Num a => a -> a -> a
+ Int
1) (Int
writeIdx forall a. Num a => a -> a -> a
+ Int
3)
decodeImageY8 :: IndexedBmpFormat -> BmpV5Header -> B.ByteString -> Image Pixel8
decodeImageY8 :: IndexedBmpFormat -> BmpV5Header -> ByteString -> Image Word8
decodeImageY8 IndexedBmpFormat
lowBPP (BmpV5Header { width :: BmpV5Header -> Int32
width = Int32
w, height :: BmpV5Header -> Int32
height = Int32
h, bitPerPixel :: BmpV5Header -> Word16
bitPerPixel = Word16
bpp }) ByteString
str = forall a. Int -> Int -> Vector (PixelBaseComponent a) -> Image a
Image Int
wi Int
hi Vector Word8
stArray where
wi :: Int
wi = forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
w
hi :: Int
hi = forall a. Num a => a -> a
abs forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
h
stArray :: Vector Word8
stArray = forall a. (forall s. ST s a) -> a
runST forall a b. (a -> b) -> a -> b
$ do
MVector s Word8
arr <- forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
Int -> m (MVector (PrimState m) a)
M.new forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Int32
w forall a. Num a => a -> a -> a
* forall a. Num a => a -> a
abs Int32
h
if Int32
h forall a. Ord a => a -> a -> Bool
> Int32
0 then
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m ()
foldM_ (forall s. MVector s Word8 -> Int -> Int -> ST s Int
readLine MVector s Word8
arr) Int
0 [Int
0 .. Int
hi forall a. Num a => a -> a -> a
- Int
1]
else
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m ()
foldM_ (forall s. MVector s Word8 -> Int -> Int -> ST s Int
readLine MVector s Word8
arr) Int
0 [Int
hi forall a. Num a => a -> a -> a
- Int
1, Int
hi forall a. Num a => a -> a -> a
- Int
2 .. Int
0]
forall a (m :: * -> *).
(Storable a, PrimMonad m) =>
MVector (PrimState m) a -> m (Vector a)
VS.unsafeFreeze MVector s Word8
arr
padding :: Int
padding = Int -> Int -> Int
linePadding (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
bpp) Int
wi
readLine :: forall s. M.MVector s Word8 -> Int -> Int -> ST s Int
readLine :: forall s. MVector s Word8 -> Int -> Int -> ST s Int
readLine MVector s Word8
arr Int
readIndex Int
line = case IndexedBmpFormat
lowBPP of
IndexedBmpFormat
OneBPP -> Int -> Int -> ST s Int
inner1 Int
readIndex Int
writeIndex
IndexedBmpFormat
FourBPP -> Int -> Int -> ST s Int
inner4 Int
readIndex Int
writeIndex
IndexedBmpFormat
EightBPP -> Int -> Int -> ST s Int
inner8 Int
readIndex Int
writeIndex
where
lastIndex :: Int
lastIndex = Int
wi forall a. Num a => a -> a -> a
* (Int
hi forall a. Num a => a -> a -> a
- Int
1 forall a. Num a => a -> a -> a
- Int
line forall a. Num a => a -> a -> a
+ Int
1)
writeIndex :: Int
writeIndex = Int
wi forall a. Num a => a -> a -> a
* (Int
hi forall a. Num a => a -> a -> a
- Int
1 forall a. Num a => a -> a -> a
- Int
line)
inner8 :: Int -> Int -> ST s Int
inner8 Int
readIdx Int
writeIdx | Int
writeIdx forall a. Ord a => a -> a -> Bool
>= Int
lastIndex = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Int
readIdx forall a. Num a => a -> a -> a
+ Int
padding
inner8 Int
readIdx Int
writeIdx = do
(MVector s Word8
arr forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` Int
writeIdx) (ByteString
str HasCallStack => ByteString -> Int -> Word8
`B.index` Int
readIdx)
Int -> Int -> ST s Int
inner8 (Int
readIdx forall a. Num a => a -> a -> a
+ Int
1) (Int
writeIdx forall a. Num a => a -> a -> a
+ Int
1)
inner4 :: Int -> Int -> ST s Int
inner4 Int
readIdx Int
writeIdx | Int
writeIdx forall a. Ord a => a -> a -> Bool
>= Int
lastIndex = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Int
readIdx forall a. Num a => a -> a -> a
+ Int
padding
inner4 Int
readIdx Int
writeIdx = do
let byte :: Word8
byte = ByteString
str HasCallStack => ByteString -> Int -> Word8
`B.index` Int
readIdx
if Int
writeIdx forall a. Ord a => a -> a -> Bool
>= Int
lastIndex forall a. Num a => a -> a -> a
- Int
1 then do
(MVector s Word8
arr forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` Int
writeIdx) (Word8
byte forall a. Bits a => a -> Int -> a
`unsafeShiftR` Int
4)
Int -> Int -> ST s Int
inner4 (Int
readIdx forall a. Num a => a -> a -> a
+ Int
1) (Int
writeIdx forall a. Num a => a -> a -> a
+ Int
1)
else do
(MVector s Word8
arr forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` Int
writeIdx) (Word8
byte forall a. Bits a => a -> Int -> a
`unsafeShiftR` Int
4)
(MVector s Word8
arr forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` (Int
writeIdx forall a. Num a => a -> a -> a
+ Int
1)) (Word8
byte forall a. Bits a => a -> a -> a
.&. Word8
0x0F)
Int -> Int -> ST s Int
inner4 (Int
readIdx forall a. Num a => a -> a -> a
+ Int
1) (Int
writeIdx forall a. Num a => a -> a -> a
+ Int
2)
inner1 :: Int -> Int -> ST s Int
inner1 Int
readIdx Int
writeIdx | Int
writeIdx forall a. Ord a => a -> a -> Bool
>= Int
lastIndex = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Int
readIdx forall a. Num a => a -> a -> a
+ Int
padding
inner1 Int
readIdx Int
writeIdx = do
let byte :: Word8
byte = ByteString
str HasCallStack => ByteString -> Int -> Word8
`B.index` Int
readIdx
let toWrite :: Int
toWrite = (Int
lastIndex forall a. Num a => a -> a -> a
- Int
writeIdx) forall a. Ord a => a -> a -> a
`min` Int
8
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
0 .. (Int
toWrite forall a. Num a => a -> a -> a
- Int
1)] forall a b. (a -> b) -> a -> b
$ \Int
i ->
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word8
byte forall a. Bits a => a -> Int -> Bool
`testBit` (Int
7 forall a. Num a => a -> a -> a
- Int
i)) forall a b. (a -> b) -> a -> b
$ (MVector s Word8
arr forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` (Int
writeIdx forall a. Num a => a -> a -> a
+ Int
i)) Word8
1
Int -> Int -> ST s Int
inner1 (Int
readIdx forall a. Num a => a -> a -> a
+ Int
1) (Int
writeIdx forall a. Num a => a -> a -> a
+ Int
toWrite)
decodeImageY8RLE :: Bool -> BmpV5Header -> B.ByteString -> Image Pixel8
decodeImageY8RLE :: Bool -> BmpV5Header -> ByteString -> Image Word8
decodeImageY8RLE Bool
is4bpp (BmpV5Header { width :: BmpV5Header -> Int32
width = Int32
w, height :: BmpV5Header -> Int32
height = Int32
h, byteImageSize :: BmpV5Header -> Word32
byteImageSize = Word32
sz }) ByteString
str = forall a. Int -> Int -> Vector (PixelBaseComponent a) -> Image a
Image Int
wi Int
hi Vector Word8
stArray where
wi :: Int
wi = forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
w
hi :: Int
hi = forall a. Num a => a -> a
abs forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
h
xOffsetMax :: Int
xOffsetMax = Int
wi forall a. Num a => a -> a -> a
- Int
1
stArray :: Vector Word8
stArray = forall a. (forall s. ST s a) -> a
runST forall a b. (a -> b) -> a -> b
$ do
MVector s Word8
arr <- forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
Int -> m (MVector (PrimState m) a)
M.new forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Int32
w forall a. Num a => a -> a -> a
* forall a. Num a => a -> a
abs Int32
h
forall s. MVector s Word8 -> [Word8] -> (Int, Int) -> ST s ()
decodeRLE MVector s Word8
arr (ByteString -> [Word8]
B.unpack (Int -> ByteString -> ByteString
B.take (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
sz) ByteString
str)) ((Int
hi forall a. Num a => a -> a -> a
- Int
1) forall a. Num a => a -> a -> a
* Int
wi, Int
0)
forall a (m :: * -> *).
(Storable a, PrimMonad m) =>
MVector (PrimState m) a -> m (Vector a)
VS.unsafeFreeze MVector s Word8
arr
decodeRLE :: forall s . M.MVector s Word8 -> [Word8] -> (Int, Int) -> ST s ()
decodeRLE :: forall s. MVector s Word8 -> [Word8] -> (Int, Int) -> ST s ()
decodeRLE MVector s Word8
arr = [Word8] -> (Int, Int) -> ST s ()
inner
where
inner :: [Word8] -> (Int, Int) -> ST s ()
inner :: [Word8] -> (Int, Int) -> ST s ()
inner [] (Int, Int)
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
inner (Word8
0 : Word8
0 : [Word8]
rest) (Int
yOffset, Int
_) = [Word8] -> (Int, Int) -> ST s ()
inner [Word8]
rest (Int
yOffset forall a. Num a => a -> a -> a
- Int
wi, Int
0)
inner (Word8
0 : Word8
1 : [Word8]
_) (Int, Int)
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
inner (Word8
0 : Word8
2 : Word8
hOffset : Word8
vOffset : [Word8]
rest) (Int
yOffset, Int
_) =
[Word8] -> (Int, Int) -> ST s ()
inner [Word8]
rest (Int
yOffset forall a. Num a => a -> a -> a
- (Int
wi forall a. Num a => a -> a -> a
* forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
vOffset), forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
hOffset)
inner (Word8
0 : Word8
n : [Word8]
rest) (Int, Int)
writePos =
let isPadded :: Bool
isPadded = if Bool
is4bpp then (Word8
n forall a. Num a => a -> a -> a
+ Word8
3) forall a. Bits a => a -> a -> a
.&. Word8
0x3 forall a. Ord a => a -> a -> Bool
< Word8
2 else forall a. Integral a => a -> Bool
odd Word8
n
in Bool -> Int -> [Word8] -> (Int, Int) -> ST s ()
copyN Bool
isPadded (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
n) [Word8]
rest (Int, Int)
writePos
inner (Word8
n : Word8
b : [Word8]
rest) (Int, Int)
writePos = Int -> Word8 -> [Word8] -> (Int, Int) -> ST s ()
writeN (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
n) Word8
b [Word8]
rest (Int, Int)
writePos
inner [Word8]
_ (Int, Int)
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
writeN :: Int -> Word8 -> [Word8] -> (Int, Int) -> ST s ()
writeN :: Int -> Word8 -> [Word8] -> (Int, Int) -> ST s ()
writeN Int
0 Word8
_ [Word8]
rest (Int, Int)
writePos = [Word8] -> (Int, Int) -> ST s ()
inner [Word8]
rest (Int, Int)
writePos
writeN Int
n Word8
b [Word8]
rest (Int, Int)
writePos =
case (Bool
is4bpp, Int
n) of
(Bool
True, Int
1) ->
Word8 -> (Int, Int) -> ST s (Int, Int)
writeByte (Word8
b forall a. Bits a => a -> Int -> a
`unsafeShiftR` Int
4) (Int, Int)
writePos forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> Word8 -> [Word8] -> (Int, Int) -> ST s ()
writeN (Int
n forall a. Num a => a -> a -> a
- Int
1) Word8
b [Word8]
rest
(Bool
True, Int
_) ->
Word8 -> (Int, Int) -> ST s (Int, Int)
writeByte (Word8
b forall a. Bits a => a -> Int -> a
`unsafeShiftR` Int
4) (Int, Int)
writePos
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Word8 -> (Int, Int) -> ST s (Int, Int)
writeByte (Word8
b forall a. Bits a => a -> a -> a
.&. Word8
0x0F) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> Word8 -> [Word8] -> (Int, Int) -> ST s ()
writeN (Int
n forall a. Num a => a -> a -> a
- Int
2) Word8
b [Word8]
rest
(Bool
False, Int
_) ->
Word8 -> (Int, Int) -> ST s (Int, Int)
writeByte Word8
b (Int, Int)
writePos forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> Word8 -> [Word8] -> (Int, Int) -> ST s ()
writeN (Int
n forall a. Num a => a -> a -> a
- Int
1) Word8
b [Word8]
rest
copyN :: Bool -> Int -> [Word8] -> (Int, Int) -> ST s ()
copyN :: Bool -> Int -> [Word8] -> (Int, Int) -> ST s ()
copyN Bool
_ Int
_ [] (Int, Int)
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
copyN Bool
False Int
0 [Word8]
rest (Int, Int)
writePos = [Word8] -> (Int, Int) -> ST s ()
inner [Word8]
rest (Int, Int)
writePos
copyN Bool
True Int
0 (Word8
_:[Word8]
rest) (Int, Int)
writePos = [Word8] -> (Int, Int) -> ST s ()
inner [Word8]
rest (Int, Int)
writePos
copyN Bool
isPadded Int
n (Word8
b : [Word8]
rest) (Int, Int)
writePos =
case (Bool
is4bpp, Int
n) of
(Bool
True, Int
1) ->
Word8 -> (Int, Int) -> ST s (Int, Int)
writeByte (Word8
b forall a. Bits a => a -> Int -> a
`unsafeShiftR` Int
4) (Int, Int)
writePos forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Bool -> Int -> [Word8] -> (Int, Int) -> ST s ()
copyN Bool
isPadded (Int
n forall a. Num a => a -> a -> a
- Int
1) [Word8]
rest
(Bool
True, Int
_) ->
Word8 -> (Int, Int) -> ST s (Int, Int)
writeByte (Word8
b forall a. Bits a => a -> Int -> a
`unsafeShiftR` Int
4) (Int, Int)
writePos
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Word8 -> (Int, Int) -> ST s (Int, Int)
writeByte (Word8
b forall a. Bits a => a -> a -> a
.&. Word8
0x0F) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Bool -> Int -> [Word8] -> (Int, Int) -> ST s ()
copyN Bool
isPadded (Int
n forall a. Num a => a -> a -> a
- Int
2) [Word8]
rest
(Bool
False, Int
_) ->
Word8 -> (Int, Int) -> ST s (Int, Int)
writeByte Word8
b (Int, Int)
writePos forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Bool -> Int -> [Word8] -> (Int, Int) -> ST s ()
copyN Bool
isPadded (Int
n forall a. Num a => a -> a -> a
- Int
1) [Word8]
rest
writeByte :: Word8 -> (Int, Int) -> ST s (Int, Int)
writeByte :: Word8 -> (Int, Int) -> ST s (Int, Int)
writeByte Word8
byte (Int
yOffset, Int
xOffset) = do
(MVector s Word8
arr forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` (Int
yOffset forall a. Num a => a -> a -> a
+ Int
xOffset)) Word8
byte
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
yOffset, (Int
xOffset forall a. Num a => a -> a -> a
+ Int
1) forall a. Ord a => a -> a -> a
`min` Int
xOffsetMax)
pixel4Get :: Get [Word8]
pixel4Get :: Get [Word8]
pixel4Get = do
Word8
b <- Get Word8
getWord8
Word8
g <- Get Word8
getWord8
Word8
r <- Get Word8
getWord8
Word8
_ <- Get Word8
getWord8
forall (m :: * -> *) a. Monad m => a -> m a
return [Word8
r, Word8
g, Word8
b]
pixel3Get :: Get [Word8]
pixel3Get :: Get [Word8]
pixel3Get = do
Word8
b <- Get Word8
getWord8
Word8
g <- Get Word8
getWord8
Word8
r <- Get Word8
getWord8
forall (m :: * -> *) a. Monad m => a -> m a
return [Word8
r, Word8
g, Word8
b]
metadataOfHeader :: BmpV5Header -> Maybe B.ByteString -> Metadatas
BmpV5Header
hdr Maybe ByteString
iccProfile =
Metadatas
cs forall a. Monoid a => a -> a -> a
`mappend` forall nSize nDpi.
(Integral nSize, Integral nDpi) =>
SourceFormat -> nSize -> nSize -> nDpi -> nDpi -> Metadatas
Met.simpleMetadata SourceFormat
Met.SourceBitmap (BmpV5Header -> Int32
width BmpV5Header
hdr) (forall a. Num a => a -> a
abs forall a b. (a -> b) -> a -> b
$ BmpV5Header -> Int32
height BmpV5Header
hdr) Word
dpiX Word
dpiY
where
dpiX :: Word
dpiX = Word -> Word
Met.dotsPerMeterToDotPerInch forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ BmpV5Header -> Int32
xResolution BmpV5Header
hdr
dpiY :: Word
dpiY = Word -> Word
Met.dotsPerMeterToDotPerInch forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ BmpV5Header -> Int32
yResolution BmpV5Header
hdr
cs :: Metadatas
cs = case BmpV5Header -> ColorSpaceType
colorSpaceType BmpV5Header
hdr of
ColorSpaceType
CalibratedRGB -> forall a. (Show a, NFData a) => Keys a -> a -> Metadatas
Met.singleton
Keys ColorSpace
Met.ColorSpace (ByteString -> ColorSpace
Met.WindowsBitmapColorSpace forall a b. (a -> b) -> a -> b
$ BmpV5Header -> ByteString
colorSpace BmpV5Header
hdr)
ColorSpaceType
SRGB -> forall a. (Show a, NFData a) => Keys a -> a -> Metadatas
Met.singleton Keys ColorSpace
Met.ColorSpace ColorSpace
Met.SRGB
ColorSpaceType
ProfileEmbedded -> case Maybe ByteString
iccProfile of
Maybe ByteString
Nothing -> Metadatas
Met.empty
Just ByteString
profile -> forall a. (Show a, NFData a) => Keys a -> a -> Metadatas
Met.singleton Keys ColorSpace
Met.ColorSpace
(ByteString -> ColorSpace
Met.ICCProfile ByteString
profile)
ColorSpaceType
_ -> Metadatas
Met.empty
decodeBitmap :: B.ByteString -> Either String DynamicImage
decodeBitmap :: ByteString -> Either String DynamicImage
decodeBitmap = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either String (DynamicImage, Metadatas)
decodeBitmapWithMetadata
decodeBitmapWithMetadata :: B.ByteString -> Either String (DynamicImage, Metadatas)
decodeBitmapWithMetadata :: ByteString -> Either String (DynamicImage, Metadatas)
decodeBitmapWithMetadata ByteString
byte =
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first PalettedImage -> DynamicImage
palettedToTrueColor forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> Either String (PalettedImage, Metadatas)
decodeBitmapWithPaletteAndMetadata ByteString
byte
decodeBitmapWithPaletteAndMetadata :: B.ByteString -> Either String (PalettedImage, Metadatas)
decodeBitmapWithPaletteAndMetadata :: ByteString -> Either String (PalettedImage, Metadatas)
decodeBitmapWithPaletteAndMetadata ByteString
str = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. Get a -> ByteString -> Either String a
runGetStrict ByteString
str forall a b. (a -> b) -> a -> b
$ do
BmpHeader
fileHeader <- forall t. Binary t => Get t
get :: Get BmpHeader
BmpV5Header
bmpHeader <- forall t. Binary t => Get t
get :: Get BmpV5Header
Int64
readed <- Get Int64
bytesRead
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int64
readed forall a. Ord a => a -> a -> Bool
> forall a b. (Integral a, Num b) => a -> b
fromIntegral (BmpHeader -> Word32
dataOffset BmpHeader
fileHeader))
(forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Invalid bmp image, data in header")
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (BmpV5Header -> Int32
width BmpV5Header
bmpHeader forall a. Ord a => a -> a -> Bool
<= Int32
0)
(forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Invalid bmp width, " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (BmpV5Header -> Int32
width BmpV5Header
bmpHeader))
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (BmpV5Header -> Int32
height BmpV5Header
bmpHeader forall a. Eq a => a -> a -> Bool
== Int32
0)
(forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Invalid bmp height (0) ")
BmpHeader -> BmpV5Header -> Get (PalettedImage, Metadatas)
decodeBitmapWithHeaders BmpHeader
fileHeader BmpV5Header
bmpHeader
decodeBitmapWithHeaders :: BmpHeader -> BmpV5Header -> Get (PalettedImage, Metadatas)
BmpHeader
fileHdr BmpV5Header
hdr = do
PalettedImage
img <- Get PalettedImage
bitmapData
Maybe ByteString
profile <- Get (Maybe ByteString)
getICCProfile
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Maybe ByteString -> PalettedImage -> (PalettedImage, Metadatas)
addMetadata Maybe ByteString
profile PalettedImage
img
where
bpp :: Int
bpp = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ BmpV5Header -> Word16
bitPerPixel BmpV5Header
hdr :: Int
paletteColorCount :: Int
paletteColorCount
| BmpV5Header -> Word32
colorCount BmpV5Header
hdr forall a. Eq a => a -> a -> Bool
== Word32
0 = Int
2 forall a b. (Num a, Integral b) => a -> b -> a
^ Int
bpp
| Bool
otherwise = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ BmpV5Header -> Word32
colorCount BmpV5Header
hdr
addMetadata :: Maybe ByteString -> PalettedImage -> (PalettedImage, Metadatas)
addMetadata Maybe ByteString
profile PalettedImage
i = (PalettedImage
i, BmpV5Header -> Maybe ByteString -> Metadatas
metadataOfHeader BmpV5Header
hdr Maybe ByteString
profile)
getData :: Get ByteString
getData = do
Int64
readed <- Get Int64
bytesRead
forall a. String -> Get a -> Get a
label String
"Start of pixel data" forall a b. (a -> b) -> a -> b
$
Int -> Get ()
skip forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ BmpHeader -> Word32
dataOffset BmpHeader
fileHdr forall a. Num a => a -> a -> a
- forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
readed
let pixelBytes :: Int
pixelBytes = if BmpV5Header -> Word32
bitmapCompression BmpV5Header
hdr forall a. Eq a => a -> a -> Bool
== Word32
1 Bool -> Bool -> Bool
|| BmpV5Header -> Word32
bitmapCompression BmpV5Header
hdr forall a. Eq a => a -> a -> Bool
== Word32
2
then forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ BmpV5Header -> Word32
byteImageSize BmpV5Header
hdr
else Int -> Int -> Int -> Int
sizeofPixelData Int
bpp (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ BmpV5Header -> Int32
width BmpV5Header
hdr)
(forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ BmpV5Header -> Int32
height BmpV5Header
hdr)
forall a. String -> Get a -> Get a
label String
"Pixel data" forall a b. (a -> b) -> a -> b
$ Int -> Get ByteString
getByteString Int
pixelBytes
getICCProfile :: Get (Maybe ByteString)
getICCProfile =
if BmpV5Header -> Word32
size BmpV5Header
hdr forall a. Ord a => a -> a -> Bool
>= Word32
sizeofBmpV5Header
Bool -> Bool -> Bool
&& BmpV5Header -> ColorSpaceType
colorSpaceType BmpV5Header
hdr forall a. Eq a => a -> a -> Bool
== ColorSpaceType
ProfileLinked
Bool -> Bool -> Bool
&& BmpV5Header -> Word32
iccProfileData BmpV5Header
hdr forall a. Ord a => a -> a -> Bool
> Word32
0
Bool -> Bool -> Bool
&& BmpV5Header -> Word32
iccProfileSize BmpV5Header
hdr forall a. Ord a => a -> a -> Bool
> Word32
0
then do
Int64
readSoFar <- Get Int64
bytesRead
forall a. String -> Get a -> Get a
label String
"Start of embedded ICC color profile" forall a b. (a -> b) -> a -> b
$
Int -> Get ()
skip forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral (BmpV5Header -> Word32
iccProfileData BmpV5Header
hdr) forall a. Num a => a -> a -> a
- forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
readSoFar
ByteString
profile <- forall a. String -> Get a -> Get a
label String
"Embedded ICC color profile" forall a b. (a -> b) -> a -> b
$
Int -> Get ByteString
getByteString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ BmpV5Header -> Word32
iccProfileSize BmpV5Header
hdr
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just ByteString
profile)
else forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
bitmapData :: Get PalettedImage
bitmapData = case (BmpV5Header -> Word16
bitPerPixel BmpV5Header
hdr, BmpV5Header -> Word16
planes BmpV5Header
hdr, BmpV5Header -> Word32
bitmapCompression BmpV5Header
hdr) of
(Word16
32, Word16
1, Word32
0) -> do
ByteString
rest <- Get ByteString
getData
forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynamicImage -> PalettedImage
TrueColorImage forall b c a. (b -> c) -> (a -> b) -> a -> c
. Image PixelRGB8 -> DynamicImage
ImageRGB8 forall a b. (a -> b) -> a -> b
$
RGBBmpFormat -> BmpV5Header -> ByteString -> Image PixelRGB8
decodeImageRGB8 (Bitfields3 Word32 -> RGBBmpFormat
RGB32 Bitfields3 Word32
defaultBitfieldsRGB32) BmpV5Header
hdr ByteString
rest
(Word16
32, Word16
1, Word32
3) -> do
Bitfield Word32
r <- forall t (m :: * -> *).
(FiniteBits t, Integral t, Num t, MonadFail m) =>
t -> m (Bitfield t)
getBitfield forall a b. (a -> b) -> a -> b
$ BmpV5Header -> Word32
redMask BmpV5Header
hdr
Bitfield Word32
g <- forall t (m :: * -> *).
(FiniteBits t, Integral t, Num t, MonadFail m) =>
t -> m (Bitfield t)
getBitfield forall a b. (a -> b) -> a -> b
$ BmpV5Header -> Word32
greenMask BmpV5Header
hdr
Bitfield Word32
b <- forall t (m :: * -> *).
(FiniteBits t, Integral t, Num t, MonadFail m) =>
t -> m (Bitfield t)
getBitfield forall a b. (a -> b) -> a -> b
$ BmpV5Header -> Word32
blueMask BmpV5Header
hdr
ByteString
rest <- Get ByteString
getData
if BmpV5Header -> Word32
alphaMask BmpV5Header
hdr forall a. Eq a => a -> a -> Bool
== Word32
0
then forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynamicImage -> PalettedImage
TrueColorImage forall b c a. (b -> c) -> (a -> b) -> a -> c
. Image PixelRGB8 -> DynamicImage
ImageRGB8 forall a b. (a -> b) -> a -> b
$
RGBBmpFormat -> BmpV5Header -> ByteString -> Image PixelRGB8
decodeImageRGB8 (Bitfields3 Word32 -> RGBBmpFormat
RGB32 forall a b. (a -> b) -> a -> b
$ forall t. Bitfield t -> Bitfield t -> Bitfield t -> Bitfields3 t
Bitfields3 Bitfield Word32
r Bitfield Word32
g Bitfield Word32
b) BmpV5Header
hdr ByteString
rest
else do
Bitfield Word32
a <- forall t (m :: * -> *).
(FiniteBits t, Integral t, Num t, MonadFail m) =>
t -> m (Bitfield t)
getBitfield forall a b. (a -> b) -> a -> b
$ BmpV5Header -> Word32
alphaMask BmpV5Header
hdr
forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynamicImage -> PalettedImage
TrueColorImage forall b c a. (b -> c) -> (a -> b) -> a -> c
. Image PixelRGBA8 -> DynamicImage
ImageRGBA8 forall a b. (a -> b) -> a -> b
$
RGBABmpFormat -> BmpV5Header -> ByteString -> Image PixelRGBA8
decodeImageRGBA8 (Bitfields4 Word32 -> RGBABmpFormat
RGBA32 forall a b. (a -> b) -> a -> b
$ forall t.
Bitfield t
-> Bitfield t -> Bitfield t -> Bitfield t -> Bitfields4 t
Bitfields4 Bitfield Word32
r Bitfield Word32
g Bitfield Word32
b Bitfield Word32
a) BmpV5Header
hdr ByteString
rest
(Word16
24, Word16
1, Word32
0) -> do
ByteString
rest <- Get ByteString
getData
forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynamicImage -> PalettedImage
TrueColorImage forall b c a. (b -> c) -> (a -> b) -> a -> c
. Image PixelRGB8 -> DynamicImage
ImageRGB8 forall a b. (a -> b) -> a -> b
$
RGBBmpFormat -> BmpV5Header -> ByteString -> Image PixelRGB8
decodeImageRGB8 RGBBmpFormat
RGB24 BmpV5Header
hdr ByteString
rest
(Word16
16, Word16
1, Word32
0) -> do
ByteString
rest <- Get ByteString
getData
forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynamicImage -> PalettedImage
TrueColorImage forall b c a. (b -> c) -> (a -> b) -> a -> c
. Image PixelRGB8 -> DynamicImage
ImageRGB8 forall a b. (a -> b) -> a -> b
$
RGBBmpFormat -> BmpV5Header -> ByteString -> Image PixelRGB8
decodeImageRGB8 (Bitfields3 Word16 -> RGBBmpFormat
RGB16 Bitfields3 Word16
defaultBitfieldsRGB16) BmpV5Header
hdr ByteString
rest
(Word16
16, Word16
1, Word32
3) -> do
Bitfield Word16
r <- forall t (m :: * -> *).
(FiniteBits t, Integral t, Num t, MonadFail m) =>
t -> m (Bitfield t)
getBitfield forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Word32
0xFFFF forall a. Bits a => a -> a -> a
.&. BmpV5Header -> Word32
redMask BmpV5Header
hdr
Bitfield Word16
g <- forall t (m :: * -> *).
(FiniteBits t, Integral t, Num t, MonadFail m) =>
t -> m (Bitfield t)
getBitfield forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Word32
0xFFFF forall a. Bits a => a -> a -> a
.&. BmpV5Header -> Word32
greenMask BmpV5Header
hdr
Bitfield Word16
b <- forall t (m :: * -> *).
(FiniteBits t, Integral t, Num t, MonadFail m) =>
t -> m (Bitfield t)
getBitfield forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Word32
0xFFFF forall a. Bits a => a -> a -> a
.&. BmpV5Header -> Word32
blueMask BmpV5Header
hdr
ByteString
rest <- Get ByteString
getData
if BmpV5Header -> Word32
alphaMask BmpV5Header
hdr forall a. Eq a => a -> a -> Bool
== Word32
0
then forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynamicImage -> PalettedImage
TrueColorImage forall b c a. (b -> c) -> (a -> b) -> a -> c
. Image PixelRGB8 -> DynamicImage
ImageRGB8 forall a b. (a -> b) -> a -> b
$
RGBBmpFormat -> BmpV5Header -> ByteString -> Image PixelRGB8
decodeImageRGB8 (Bitfields3 Word16 -> RGBBmpFormat
RGB16 forall a b. (a -> b) -> a -> b
$ forall t. Bitfield t -> Bitfield t -> Bitfield t -> Bitfields3 t
Bitfields3 Bitfield Word16
r Bitfield Word16
g Bitfield Word16
b) BmpV5Header
hdr ByteString
rest
else do
Bitfield Word16
a <- forall t (m :: * -> *).
(FiniteBits t, Integral t, Num t, MonadFail m) =>
t -> m (Bitfield t)
getBitfield forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Word32
0xFFFF forall a. Bits a => a -> a -> a
.&. BmpV5Header -> Word32
alphaMask BmpV5Header
hdr
forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynamicImage -> PalettedImage
TrueColorImage forall b c a. (b -> c) -> (a -> b) -> a -> c
. Image PixelRGBA8 -> DynamicImage
ImageRGBA8 forall a b. (a -> b) -> a -> b
$
RGBABmpFormat -> BmpV5Header -> ByteString -> Image PixelRGBA8
decodeImageRGBA8 (Bitfields4 Word16 -> RGBABmpFormat
RGBA16 forall a b. (a -> b) -> a -> b
$ forall t.
Bitfield t
-> Bitfield t -> Bitfield t -> Bitfield t -> Bitfields4 t
Bitfields4 Bitfield Word16
r Bitfield Word16
g Bitfield Word16
b Bitfield Word16
a) BmpV5Header
hdr ByteString
rest
( Word16
_, Word16
1, Word32
compression) -> do
[[Word8]]
table <- if BmpV5Header -> Word32
size BmpV5Header
hdr forall a. Eq a => a -> a -> Bool
== Word32
sizeofBmpCoreHeader
then forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
paletteColorCount Get [Word8]
pixel3Get
else forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
paletteColorCount Get [Word8]
pixel4Get
ByteString
rest <- Get ByteString
getData
let palette :: Palette' PixelRGB8
palette = Palette'
{ _paletteSize :: Int
_paletteSize = Int
paletteColorCount
, _paletteData :: Vector (PixelBaseComponent PixelRGB8)
_paletteData = forall a. Storable a => Int -> [a] -> Vector a
VS.fromListN (Int
paletteColorCount forall a. Num a => a -> a -> a
* Int
3) forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Word8]]
table
}
Image Word8
image <-
case (Int
bpp, Word32
compression) of
(Int
8, Word32
0) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ IndexedBmpFormat -> BmpV5Header -> ByteString -> Image Word8
decodeImageY8 IndexedBmpFormat
EightBPP BmpV5Header
hdr ByteString
rest
(Int
4, Word32
0) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ IndexedBmpFormat -> BmpV5Header -> ByteString -> Image Word8
decodeImageY8 IndexedBmpFormat
FourBPP BmpV5Header
hdr ByteString
rest
(Int
1, Word32
0) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ IndexedBmpFormat -> BmpV5Header -> ByteString -> Image Word8
decodeImageY8 IndexedBmpFormat
OneBPP BmpV5Header
hdr ByteString
rest
(Int
8, Word32
1) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Bool -> BmpV5Header -> ByteString -> Image Word8
decodeImageY8RLE Bool
False BmpV5Header
hdr ByteString
rest
(Int
4, Word32
2) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Bool -> BmpV5Header -> ByteString -> Image Word8
decodeImageY8RLE Bool
True BmpV5Header
hdr ByteString
rest
(Int
a, Word32
b) -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Can't handle BMP file " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (Int
a, Int
1 :: Int, Word32
b)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Image Word8 -> Palette' PixelRGB8 -> PalettedImage
PalettedRGB8 Image Word8
image Palette' PixelRGB8
palette
(Word16, Word16, Word32)
a -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Can't handle BMP file " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (Word16, Word16, Word32)
a
#if MIN_VERSION_base(4,13,0)
getBitfield :: (FiniteBits t, Integral t, Num t, MonadFail m) => t -> m (Bitfield t)
#else
getBitfield :: (FiniteBits t, Integral t, Num t, Monad m) => t -> m (Bitfield t)
#endif
getBitfield :: forall t (m :: * -> *).
(FiniteBits t, Integral t, Num t, MonadFail m) =>
t -> m (Bitfield t)
getBitfield t
0 = forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$
String
"Codec.Picture.Bitmap.getBitfield: bitfield cannot be 0"
getBitfield t
w = forall (m :: * -> *) a. Monad m => a -> m a
return (forall t. (FiniteBits t, Integral t) => t -> Bitfield t
makeBitfield t
w)
sizeofPixelData :: Int -> Int -> Int -> Int
sizeofPixelData :: Int -> Int -> Int -> Int
sizeofPixelData Int
bpp Int
lineWidth Int
nLines = ((Int
bpp forall a. Num a => a -> a -> a
* (forall a. Num a => a -> a
abs Int
lineWidth) forall a. Num a => a -> a -> a
+ Int
31) forall a. Integral a => a -> a -> a
`div` Int
32) forall a. Num a => a -> a -> a
* Int
4 forall a. Num a => a -> a -> a
* forall a. Num a => a -> a
abs Int
nLines
writeBitmap :: (BmpEncodable pixel)
=> FilePath -> Image pixel -> IO ()
writeBitmap :: forall pixel. BmpEncodable pixel => String -> Image pixel -> IO ()
writeBitmap String
filename Image pixel
img = String -> ByteString -> IO ()
L.writeFile String
filename forall a b. (a -> b) -> a -> b
$ forall pixel. BmpEncodable pixel => Image pixel -> ByteString
encodeBitmap Image pixel
img
linePadding :: Int -> Int -> Int
linePadding :: Int -> Int -> Int
linePadding Int
bpp Int
imgWidth = (Int
4 forall a. Num a => a -> a -> a
- (Int
bytesPerLine forall a. Integral a => a -> a -> a
`mod` Int
4)) forall a. Integral a => a -> a -> a
`mod` Int
4
where bytesPerLine :: Int
bytesPerLine = (Int
bpp forall a. Num a => a -> a -> a
* Int
imgWidth forall a. Num a => a -> a -> a
+ Int
7) forall a. Integral a => a -> a -> a
`div` Int
8
encodeBitmap :: forall pixel. (BmpEncodable pixel) => Image pixel -> L.ByteString
encodeBitmap :: forall pixel. BmpEncodable pixel => Image pixel -> ByteString
encodeBitmap = forall pixel.
BmpEncodable pixel =>
BmpPalette -> Image pixel -> ByteString
encodeBitmapWithPalette (forall pixel. BmpEncodable pixel => pixel -> BmpPalette
defaultPalette (forall a. HasCallStack => a
undefined :: pixel))
encodeBitmapWithMetadata :: forall pixel. BmpEncodable pixel
=> Metadatas -> Image pixel -> L.ByteString
encodeBitmapWithMetadata :: forall pixel.
BmpEncodable pixel =>
Metadatas -> Image pixel -> ByteString
encodeBitmapWithMetadata Metadatas
metas =
forall pixel.
BmpEncodable pixel =>
Metadatas -> BmpPalette -> Image pixel -> ByteString
encodeBitmapWithPaletteAndMetadata Metadatas
metas (forall pixel. BmpEncodable pixel => pixel -> BmpPalette
defaultPalette (forall a. HasCallStack => a
undefined :: pixel))
writeDynamicBitmap :: FilePath -> DynamicImage -> IO (Either String Bool)
writeDynamicBitmap :: String -> DynamicImage -> IO (Either String Bool)
writeDynamicBitmap String
path DynamicImage
img = case DynamicImage -> Either String ByteString
encodeDynamicBitmap DynamicImage
img of
Left String
err -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left String
err
Right ByteString
b -> String -> ByteString -> IO ()
L.writeFile String
path ByteString
b forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. b -> Either a b
Right Bool
True)
encodeDynamicBitmap :: DynamicImage -> Either String L.ByteString
encodeDynamicBitmap :: DynamicImage -> Either String ByteString
encodeDynamicBitmap (ImageRGB8 Image PixelRGB8
img) = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall pixel. BmpEncodable pixel => Image pixel -> ByteString
encodeBitmap Image PixelRGB8
img
encodeDynamicBitmap (ImageRGBA8 Image PixelRGBA8
img) = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall pixel. BmpEncodable pixel => Image pixel -> ByteString
encodeBitmap Image PixelRGBA8
img
encodeDynamicBitmap (ImageY8 Image Word8
img) = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall pixel. BmpEncodable pixel => Image pixel -> ByteString
encodeBitmap Image Word8
img
encodeDynamicBitmap DynamicImage
_ = forall a b. a -> Either a b
Left String
"Unsupported image format for bitmap export"
extractDpiOfMetadata :: Metadatas -> (Word32, Word32)
Metadatas
metas = (Keys Word -> Word32
fetch Keys Word
Met.DpiX, Keys Word -> Word32
fetch Keys Word
Met.DpiY) where
fetch :: Keys Word -> Word32
fetch Keys Word
k = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Word32
0 (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word -> Word
Met.dotPerInchToDotsPerMeter) forall a b. (a -> b) -> a -> b
$ forall a. Keys a -> Metadatas -> Maybe a
Met.lookup Keys Word
k Metadatas
metas
encodeBitmapWithPalette :: forall pixel. (BmpEncodable pixel)
=> BmpPalette -> Image pixel -> L.ByteString
encodeBitmapWithPalette :: forall pixel.
BmpEncodable pixel =>
BmpPalette -> Image pixel -> ByteString
encodeBitmapWithPalette = forall pixel.
BmpEncodable pixel =>
Metadatas -> BmpPalette -> Image pixel -> ByteString
encodeBitmapWithPaletteAndMetadata forall a. Monoid a => a
mempty
encodeBitmapWithPaletteAndMetadata :: forall pixel. (BmpEncodable pixel)
=> Metadatas -> BmpPalette -> Image pixel
-> L.ByteString
encodeBitmapWithPaletteAndMetadata :: forall pixel.
BmpEncodable pixel =>
Metadatas -> BmpPalette -> Image pixel -> ByteString
encodeBitmapWithPaletteAndMetadata Metadatas
metas pal :: BmpPalette
pal@(BmpPalette [(Word8, Word8, Word8, Word8)]
palette) Image pixel
img =
Put -> ByteString
runPut forall a b. (a -> b) -> a -> b
$ forall t. Binary t => t -> Put
put BmpHeader
hdr forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall t. Binary t => t -> Put
put BmpV5Header
info forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> BmpPalette -> Put
putPalette BmpPalette
pal forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall pixel. BmpEncodable pixel => Image pixel -> Put
bmpEncode Image pixel
img
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe ByteString -> Put
putICCProfile Maybe ByteString
colorProfileData
where imgWidth :: Int
imgWidth = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall a. Image a -> Int
imageWidth Image pixel
img
imgHeight :: Int
imgHeight = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall a. Image a -> Int
imageHeight Image pixel
img
(Word32
dpiX, Word32
dpiY) = Metadatas -> (Word32, Word32)
extractDpiOfMetadata Metadatas
metas
cs :: Maybe ColorSpace
cs = forall a. Keys a -> Metadatas -> Maybe a
Met.lookup Keys ColorSpace
Met.ColorSpace Metadatas
metas
colorType :: ColorSpaceType
colorType = case Maybe ColorSpace
cs of
Just ColorSpace
Met.SRGB -> ColorSpaceType
SRGB
Just (Met.WindowsBitmapColorSpace ByteString
_) -> ColorSpaceType
CalibratedRGB
Just (Met.ICCProfile ByteString
_) -> ColorSpaceType
ProfileEmbedded
Maybe ColorSpace
Nothing -> ColorSpaceType
DeviceDependentRGB
colorSpaceInfo :: ByteString
colorSpaceInfo = case Maybe ColorSpace
cs of
Just (Met.WindowsBitmapColorSpace ByteString
bytes) -> ByteString
bytes
Maybe ColorSpace
_ -> [Word8] -> ByteString
B.pack forall a b. (a -> b) -> a -> b
$ forall a. Int -> a -> [a]
replicate Int
sizeofColorProfile Word8
0
colorProfileData :: Maybe ByteString
colorProfileData = case Maybe ColorSpace
cs of
Just (Met.ICCProfile ByteString
bytes) -> forall a. a -> Maybe a
Just ByteString
bytes
Maybe ColorSpace
_ -> forall a. Maybe a
Nothing
headerSize :: Word32
headerSize | ColorSpaceType
colorType forall a. Eq a => a -> a -> Bool
== ColorSpaceType
ProfileEmbedded = Word32
sizeofBmpV5Header
| ColorSpaceType
colorType forall a. Eq a => a -> a -> Bool
== ColorSpaceType
CalibratedRGB Bool -> Bool -> Bool
|| forall pixel. BmpEncodable pixel => Image pixel -> Bool
hasAlpha Image pixel
img = Word32
sizeofBmpV4Header
| Bool
otherwise = Word32
sizeofBmpInfoHeader
paletteSize :: Word32
paletteSize = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Word8, Word8, Word8, Word8)]
palette
bpp :: Int
bpp = forall pixel. BmpEncodable pixel => pixel -> Int
bitsPerPixel (forall a. HasCallStack => a
undefined :: pixel)
profileSize :: Word32
profileSize = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
0 ByteString -> Int
B.length Maybe ByteString
colorProfileData
imagePixelSize :: Word32
imagePixelSize = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int -> Int
sizeofPixelData Int
bpp Int
imgWidth Int
imgHeight
offsetToData :: Word32
offsetToData = Word32
sizeofBmpHeader forall a. Num a => a -> a -> a
+ Word32
headerSize forall a. Num a => a -> a -> a
+ Word32
4 forall a. Num a => a -> a -> a
* Word32
paletteSize
offsetToICCProfile :: Maybe Word32
offsetToICCProfile = Word32
offsetToData forall a. Num a => a -> a -> a
+ Word32
imagePixelSize forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Maybe ByteString
colorProfileData
sizeOfFile :: Word32
sizeOfFile = Word32
sizeofBmpHeader forall a. Num a => a -> a -> a
+ Word32
headerSize forall a. Num a => a -> a -> a
+ Word32
4 forall a. Num a => a -> a -> a
* Word32
paletteSize
forall a. Num a => a -> a -> a
+ Word32
imagePixelSize forall a. Num a => a -> a -> a
+ Word32
profileSize
hdr :: BmpHeader
hdr = BmpHeader {
magicIdentifier :: Word16
magicIdentifier = Word16
bitmapMagicIdentifier,
fileSize :: Word32
fileSize = Word32
sizeOfFile,
reserved1 :: Word16
reserved1 = Word16
0,
reserved2 :: Word16
reserved2 = Word16
0,
dataOffset :: Word32
dataOffset = Word32
offsetToData
}
info :: BmpV5Header
info = BmpV5Header {
size :: Word32
size = Word32
headerSize,
width :: Int32
width = forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
imgWidth,
height :: Int32
height = forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
imgHeight,
planes :: Word16
planes = Word16
1,
bitPerPixel :: Word16
bitPerPixel = forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
bpp,
bitmapCompression :: Word32
bitmapCompression = if forall pixel. BmpEncodable pixel => Image pixel -> Bool
hasAlpha Image pixel
img then Word32
3 else Word32
0,
byteImageSize :: Word32
byteImageSize = Word32
imagePixelSize,
xResolution :: Int32
xResolution = forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
dpiX,
yResolution :: Int32
yResolution = forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
dpiY,
colorCount :: Word32
colorCount = Word32
paletteSize,
importantColours :: Word32
importantColours = Word32
0,
redMask :: Word32
redMask = if forall pixel. BmpEncodable pixel => Image pixel -> Bool
hasAlpha Image pixel
img then Word32
0x00FF0000 else Word32
0,
greenMask :: Word32
greenMask = if forall pixel. BmpEncodable pixel => Image pixel -> Bool
hasAlpha Image pixel
img then Word32
0x0000FF00 else Word32
0,
blueMask :: Word32
blueMask = if forall pixel. BmpEncodable pixel => Image pixel -> Bool
hasAlpha Image pixel
img then Word32
0x000000FF else Word32
0,
alphaMask :: Word32
alphaMask = if forall pixel. BmpEncodable pixel => Image pixel -> Bool
hasAlpha Image pixel
img then Word32
0xFF000000 else Word32
0,
colorSpaceType :: ColorSpaceType
colorSpaceType = ColorSpaceType
colorType,
colorSpace :: ByteString
colorSpace = ByteString
colorSpaceInfo,
iccIntent :: Word32
iccIntent = Word32
0,
iccProfileData :: Word32
iccProfileData = forall a. a -> Maybe a -> a
fromMaybe Word32
0 Maybe Word32
offsetToICCProfile,
iccProfileSize :: Word32
iccProfileSize = Word32
profileSize
}
{-# ANN module "HLint: ignore Reduce duplication" #-}