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