{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE TypeFamilies #-}
-- | Modules used for Bitmap file (.bmp) file loading and writing

module Codec.Picture.Bitmap( -- * Functions

                             writeBitmap
                           , encodeBitmap
                           , encodeBitmapWithMetadata
                           , decodeBitmap
                           , decodeBitmapWithMetadata
                           , decodeBitmapWithPaletteAndMetadata
                           , encodeDynamicBitmap
                           , encodeBitmapWithPaletteAndMetadata
                           , writeDynamicBitmap
                             -- * Accepted format in output

                           , 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 = BmpHeader
    { BmpHeader -> Word16
magicIdentifier :: !Word16
    , BmpHeader -> Word32
fileSize        :: !Word32 -- ^ in bytes

    , 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
            }

-- | The type of color space declared in a Windows BMP file.

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)

-- | BITMAPxHEADER with compatibility up to V5. This header was first introduced

-- with Windows 2.0 as the BITMAPCOREHEADER, and was later extended in Windows

-- 3.1, Windows 95 and Windows 98. The original BITMAPCOREHEADER includes all

-- fields up to 'bitPerPixel'. The Windows 3.1 BITMAPINFOHEADER adds all the

-- fields up to 'importantColors'.

--

-- Some Windows 3.1 bitmaps with 16 or 32 bits per pixel might also have three

-- bitmasks following the BITMAPINFOHEADER. These bitmasks were later

-- incorporated into the bitmap header structure in the unreleased

-- BITMAPV2INFOHEADER. The (also unreleased) BITMAPV3INFOHEADER added another

-- bitmask for an alpha channel.

--

-- The later Windows 95 and Windows 98 extensions to the BITMAPINFOHEADER extend

-- the BITMAPV3INFOHEADER, adding support for color correction.

--

--  * BITMAPV4HEADER (Windows 95) may include a simple color profile in a

--      proprietary format. The fields in this color profile (which includes gamma

--      values) are not to be used unless the 'colorSpaceType' field is

--      'CalibratedRGB'.

--

--  * BITMAPV5HEADER (Windows 98) adds support for an ICC color profile. The

--      presence of an ICC color profile is indicated by setting the 'colorSpaceType'

--      field to 'ProfileEmbedded' or 'ProfileLinked'. If it is 'ProfileLinked' then

--      the profile data is actually a Windows-1252 encoded string containing the

--      fully qualified path to an ICC color profile.

data BmpV5Header = BmpV5Header
    { BmpV5Header -> Word32
size              :: !Word32 -- Header size in bytes

    , BmpV5Header -> Int32
width             :: !Int32
    , BmpV5Header -> Int32
height            :: !Int32
    , BmpV5Header -> Word16
planes            :: !Word16 -- Number of colour planes

    , BmpV5Header -> Word16
bitPerPixel       :: !Word16
    , BmpV5Header -> Word32
bitmapCompression :: !Word32
    , BmpV5Header -> Word32
byteImageSize     :: !Word32
    , BmpV5Header -> Int32
xResolution       :: !Int32  -- ^ Pixels per meter

    , BmpV5Header -> Int32
yResolution       :: !Int32  -- ^ Pixels per meter

    , BmpV5Header -> Word32
colorCount        :: !Word32 -- ^ Number of colors in the palette

    , BmpV5Header -> Word32
importantColours  :: !Word32
    -- Fields added to the header in V2

    , BmpV5Header -> Word32
redMask           :: !Word32 -- ^ Red bitfield mask, set to 0 if not used

    , BmpV5Header -> Word32
greenMask         :: !Word32 -- ^ Green bitfield mask, set to 0 if not used

    , BmpV5Header -> Word32
blueMask          :: !Word32 -- ^ Blue bitfield mask, set to 0 if not used

    -- Fields added to the header in V3

    , BmpV5Header -> Word32
alphaMask         :: !Word32 -- ^ Alpha bitfield mask, set to 0 if not used

    -- Fields added to the header in V4

    , BmpV5Header -> ColorSpaceType
colorSpaceType    :: !ColorSpaceType
    , BmpV5Header -> ByteString
colorSpace        :: !B.ByteString -- ^ Windows color space, not decoded

    -- Fields added to the header in V5

    , 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

-- | Size of the Windows BITMAPV4INFOHEADER color space information.

sizeofColorProfile :: Int
sizeofColorProfile :: Int
sizeofColorProfile = Int
48

-- | Sizes of basic BMP headers.

sizeofBmpHeader, sizeofBmpCoreHeader, sizeofBmpInfoHeader :: Word32
sizeofBmpHeader :: Word32
sizeofBmpHeader = 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
sizeofBmpCoreHeader :: Word32
sizeofBmpCoreHeader = Word32
12
sizeofBmpInfoHeader :: Word32
sizeofBmpInfoHeader = Word32
40

-- | Sizes of extended BMP headers.

sizeofBmpV2Header, sizeofBmpV3Header, sizeofBmpV4Header, sizeofBmpV5Header :: Word32
sizeofBmpV2Header :: Word32
sizeofBmpV2Header = Word32
52
sizeofBmpV3Header :: Word32
sizeofBmpV3Header = Word32
56
sizeofBmpV4Header :: Word32
sizeofBmpV4Header = Word32
108
sizeofBmpV5Header :: Word32
sizeofBmpV5Header = 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 -- reserved field


    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
                -- fields added to the header in V2, but sometimes present

                -- immediately after a plain BITMAPINFOHEADER

                innerReadRedMask <- getWord32le
                innerReadGreenMask <- getWord32le
                innerReadBlueMask <- getWord32le
                return (innerReadRedMask, innerReadGreenMask, innerReadBlueMask)

          -- field added in V3 (undocumented)

          readAlphaMask <- if readSize < sizeofBmpV3Header then return 0 else getWord32le

          (readColorSpaceType, readColorSpace) <-
            if readSize < sizeofBmpV4Header
              then return (DeviceDependentRGB, B.empty)
              else do
                -- fields added in V4 (Windows 95)

                csType <- get
                cs <- getByteString sizeofColorProfile
                return (csType, cs)

          (readIccIntent, readIccProfileData, readIccProfileSize) <-
            if readSize < sizeofBmpV5Header
              then return (0, 0, 0)
              else do
                -- fields added in V5 (Windows 98)

                innerIccIntent <- getWord32le
                innerIccProfileData <- getWord32le
                innerIccProfileSize <- getWord32le
                void getWord32le -- reserved field

                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

-- | All the instance of this class can be written as a bitmap file

-- using this library.

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

-- | Information required to extract data from a bitfield.

data Bitfield t = Bitfield
    { forall t. Bitfield t -> t
bfMask :: !t            -- ^ The original bitmask.

    , forall t. Bitfield t -> Int
bfShift :: !Int         -- ^ The computed number of bits to shift right.

    , forall t. Bitfield t -> Float
bfScale :: !Float       -- ^ The scale factor to fit the data into 8 bits.

    } 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)

-- | Four bitfields (red, green, blue, alpha)

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)

-- | Default bitfields 32 bit bitmaps.

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)

-- | Default bitfields for 16 bit bitmaps.

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)

-- | Three bitfields (red, gree, blue).

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)

-- | Pixel formats used to encode RGBA image data.

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)

-- | Pixel formats used to encode RGB image data.

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)

-- | Pixel formats used to encode indexed or grayscale images.

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

-- | Extract pixel data from a bitfield.

extractBitfield :: (FiniteBits t, Integral t) => Bitfield t -> t -> Word8
extractBitfield :: forall t. (FiniteBits t, Integral t) => Bitfield t -> t -> Word8
extractBitfield 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

-- | Convert a bit mask into a 'BitField'.

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)

-- | Helper method to cast a 'B.ByteString' to a 'VS.Vector' of some type.

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 ()

      -- | Write n copies of a byte to the output array.

      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

      -- | Copy the next byte to the output array, possibly ignoring a padding byte at the end.

      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

      -- | Write the next byte to the output array.

      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
metadataOfHeader :: BmpV5Header -> Maybe ByteString -> Metadatas
metadataOfHeader 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

-- | Try to decode a bitmap image.

-- Right now this function can output the following image:

--

--   - 'ImageY8'

--

--   - 'ImageRGB8'

--

--   - 'ImageRGBA8'

--

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

-- | Same as 'decodeBitmap' but also extracts metadata.

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

-- | Same as 'decodeBitmap' but also extracts metadata and provide separated palette.

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

-- | Decode the rest of a bitmap, after the headers have been decoded.

decodeBitmapWithHeaders :: BmpHeader -> BmpV5Header -> Get (PalettedImage, Metadatas)
decodeBitmapWithHeaders :: BmpHeader -> BmpV5Header -> Get (PalettedImage, Metadatas)
decodeBitmapWithHeaders 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
        -- (2, 1, 0, 3) means BGRA pixel order

      (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

-- | Decode a bitfield. Will fail if the bitfield is empty.

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

-- | Compute the size of the pixel data

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

-- | Write an image in a file use the bitmap format.

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

-- | Encode an image into a bytestring in .bmp format ready to be written

-- on disk.

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))

-- | Equivalent to 'encodeBitmap' but also store

-- the following metadatas:

--

--  * 'Codec.Picture.Metadata.DpiX'

--  * 'Codec.Picture.Metadata.DpiY'

--

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))

-- | Write a dynamic image in a .bmp image file if possible.

-- The same restriction as 'encodeDynamicBitmap' apply.

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)

-- | Encode a dynamic image in BMP if possible, supported images are:

--

--   - 'ImageY8'

--

--   - 'ImageRGB8'

--

--   - 'ImageRGBA8'

--

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)
extractDpiOfMetadata :: Metadatas -> (Word32, Word32)
extractDpiOfMetadata 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

-- | Convert an image to a bytestring ready to be serialized.

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

-- | Equivalent to 'encodeBitmapWithPalette' but also store

-- the following metadatas:

--

--  * 'Codec.Picture.Metadata.DpiX'

--  * 'Codec.Picture.Metadata.DpiY'

--

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" #-}