module Data.Bitmap.Class
( Bitmap(..)
, convertBitmap
, CompleteEncoder(..)
, CompleteDecoder(..)
, ImageEncoder(..)
, ImageDecoder(..)
, GenericBitmapSerializer(..)
, updateIdentifiableElements
, defaultCompleteEncoders
, encodeCBF_BMPIUZ64
, encodeCBF_BMPIU64
, encodeCBF_BMPIU
, encodeCBF_BMPIUU
, defaultCompleteDecoders
, tryCBF_BMPIUZ64
, tryCBF_BMPIU64
, tryCBF_BMPIU
, tryCBF_BMPIUU
, defaultImageEncoders
, encodeIBF_IDRGB24Z64
, encodeIBF_IDBGR24R2RZ64
, encodeIBF_IDBGR24HZH
, encodeIBF_IDRGB32Z64
, encodeIBF_BGR24H
, encodeIBF_BGR24A4VR
, encodeIBF_BGRU32VR
, encodeIBF_BGRU32
, encodeIBF_RGB24A4VR
, encodeIBF_RGB24A4
, encodeIBF_RGB32
, encodeIBF_RGB32Z64
, defaultImageDecoders
, tryIBF_IDRGB24Z64
, tryIBF_IDBGR24R2RZ64
, tryIBF_IDBGR24HZH
, tryIBF_IDRGB32Z64
, tryIBF_BGR24H
, tryIBF_BGR24A4VR
, tryIBF_BGRU32VR
, tryIBF_BGRU32
, tryIBF_RGB24A4VR
, tryIBF_RGB24A4
, tryIBF_RGB32
, tryIBF_RGB32Z64
, encodeComplete
, decodeComplete
, encodeImage
, decodeImage
, encodeCompleteFmt
, decodeCompleteFmt
, encodeImageFmt
, decodeImageFmt
, decodeImageDimensions
, decodeImageDimensionsFmt
, dimensionsFit
, bitmapWidth
, bitmapHeight
) where
import Codec.Compression.Zlib
import Codec.String.Base16
import Codec.String.Base64
import Control.Applicative
import Control.Arrow
import Control.Monad
import Control.Monad.Record
import Data.Binary
import Data.Binary.Get
import Data.Binary.Put
import Data.Bitmap.Pixel
import Data.Bitmap.Types
import Data.Bitmap.Util
import qualified Data.ByteString as B
import Data.Maybe
import qualified Data.String.Class as S
import Data.Tagged
import Text.Printf
class (Integral (BIndexType bmp), Pixel (BPixelType bmp)) => Bitmap bmp where
type BIndexType bmp
type BPixelType bmp
depth :: bmp -> Depth
dimensions :: bmp -> Dimensions (BIndexType bmp)
getPixel :: bmp -> Coordinates (BIndexType bmp) -> BPixelType bmp
constructPixels :: (Coordinates (BIndexType bmp) -> BPixelType bmp) -> Dimensions (BIndexType bmp) -> bmp
convertInternalFormat :: bmp -> bmp -> bmp
completeEncoders :: [(CompleteBitmapFormat, CompleteEncoder bmp)]
completeDecoders :: [(CompleteBitmapFormat, CompleteDecoder bmp)]
imageEncoders :: [(ImageBitmapFormat, ImageEncoder bmp)]
imageDecoders :: [(ImageBitmapFormat, ImageDecoder bmp)]
convertInternalFormat = const
completeEncoders = map (second unwrapGenericBitmapSerializer) defaultCompleteEncoders
completeDecoders = map (second unwrapGenericBitmapSerializer) defaultCompleteDecoders
imageEncoders = map (second unwrapGenericBitmapSerializer) defaultImageEncoders
imageDecoders = map (second unwrapGenericBitmapSerializer) defaultImageDecoders
convertBitmap :: (Bitmap a, Bitmap b) => a -> b
convertBitmap b = constructPixels (\(row, column) -> fromPixel $ getPixel b (fromIntegral row, fromIntegral column)) (let (width, height) = dimensions b in (fromIntegral width, fromIntegral height))
newtype CompleteEncoder bmp = CompleteEncoder {unwrapCompleteEncoder :: (S.StringCells s) => bmp -> s}
newtype CompleteDecoder bmp = CompleteDecoder {unwrapCompleteDecoder :: (S.StringCells s) => s -> Either String bmp}
newtype ImageEncoder bmp = ImageEncoder {unwrapImageEncoder :: (S.StringCells s) => bmp -> s}
newtype ImageDecoder bmp = ImageDecoder {unwrapImageDecoder :: (S.StringCells s) => bmp -> s -> Either String bmp}
newtype GenericBitmapSerializer s = GenericBitmapSerializer {unwrapGenericBitmapSerializer :: (Bitmap bmp) => s bmp}
updateIdentifiableElements :: (Eq k) => [(k, v)] -> [(k, v)] -> [(k, v)]
updateIdentifiableElements orig new = map (\(k, v) -> (k, maybe v id $ lookup k new)) orig
defaultCompleteEncoders :: [(CompleteBitmapFormat, GenericBitmapSerializer CompleteEncoder)]
defaultCompleteEncoders =
[ (CBF_BMPIUZ64, GenericBitmapSerializer $ CompleteEncoder $ encodeCBF_BMPIUZ64)
, (CBF_BMPIU64, GenericBitmapSerializer $ CompleteEncoder $ encodeCBF_BMPIU64)
, (CBF_BMPIU, GenericBitmapSerializer $ CompleteEncoder $ encodeCBF_BMPIU)
, (CBF_BMPIUU, GenericBitmapSerializer $ CompleteEncoder $ encodeCBF_BMPIUU)
]
encodeCBF_BMPIU :: (S.StringCells s, Bitmap bmp) => bmp -> s
encodeCBF_BMPIU b =
let (width, height) = dimensions b
header = S.fromLazyByteString . runPut $ do
putWord8 (0x42 :: Word8)
putWord8 (0x4D :: Word8)
putWord32le (fromIntegral $ 3 * width * height + padding * height + 0x0E + 40 :: Word32)
putWord16le 0x0000
putWord16le 0x0000
putWord32le (0x0E + 40 :: Word32)
putWord32le (40 :: Word32)
putWord32le (fromIntegral width :: Word32)
putWord32le (fromIntegral height :: Word32)
putWord16le (1 :: Word16)
putWord16le (24 :: Word16)
putWord32le (0 :: Word32)
putWord32le (fromIntegral $ 3 * width * height + padding * height :: Word32)
putWord32le (3000 :: Word32)
putWord32le (3000 :: Word32)
putWord32le (0 :: Word32)
putWord32le (0 :: Word32)
image = encodeImageFmt IBF_BGR24A4VR b
padding = case 4 ((3 * width) `mod` 4) of
4 -> 0
n -> n
in header `S.append` image
encodeCBF_BMPIUU :: (S.StringCells s, Bitmap bmp) => bmp -> s
encodeCBF_BMPIUU b =
let (width, height) = dimensions b
header = S.fromLazyByteString . runPut $ do
putWord8 (0x42 :: Word8)
putWord8 (0x4D :: Word8)
putWord32le (fromIntegral $ 4 * width * height + 0x0E + 40 :: Word32)
putWord16le 0x0000
putWord16le 0x0000
putWord32le (0x0E + 40 :: Word32)
putWord32le (40 :: Word32)
putWord32le (fromIntegral width :: Word32)
putWord32le (fromIntegral height :: Word32)
putWord16le (1 :: Word16)
putWord16le (32 :: Word16)
putWord32le (0 :: Word32)
putWord32le (fromIntegral $ 4 * width * height :: Word32)
putWord32le (3000 :: Word32)
putWord32le (3000 :: Word32)
putWord32le (0 :: Word32)
putWord32le (0 :: Word32)
image = encodeImageFmt IBF_BGRU32VR b
in header `S.append` image
encodeCBF_BMPIU64 :: (S.StringCells s, Bitmap bmp) => bmp -> s
encodeCBF_BMPIU64 = encode64 . encodeCompleteFmt CBF_BMPIU
encodeCBF_BMPIUZ64 :: (S.StringCells s, Bitmap bmp) => bmp -> s
encodeCBF_BMPIUZ64 = encode64 . S.fromStringCells . compress . encodeCompleteFmt CBF_BMPIU
defaultCompleteDecoders :: [(CompleteBitmapFormat, GenericBitmapSerializer CompleteDecoder)]
defaultCompleteDecoders =
[ (CBF_BMPIUZ64, GenericBitmapSerializer $ CompleteDecoder $ tryCBF_BMPIUZ64)
, (CBF_BMPIU64, GenericBitmapSerializer $ CompleteDecoder $ tryCBF_BMPIU64)
, (CBF_BMPIU, GenericBitmapSerializer $ CompleteDecoder $ tryCBF_BMPIU)
, (CBF_BMPIUU, GenericBitmapSerializer $ CompleteDecoder $ tryCBF_BMPIUU)
]
tryCBF_BMPIU :: (S.StringCells s, Bitmap bmp) => s -> Either String bmp
tryCBF_BMPIU s = do
let getImgInfo = do
m0 <- getWord8
m1 <- getWord8
when (m0 /= 0x42 || m1 /= 0x4D) $ do
fail "magic sequence is not that of BMP format"
skip 8
offset <- getWord32le
let offset' = offset 0x0E 40
when (offset' < 0) $ do
fail $ printf "rewinding to image data at offset %d not supported" offset
headerSize <- getWord32le
when (headerSize /= 40) $ do
fail $ printf "header with size '%d' which is other than 40 is not supported" headerSize
width <- getWord32le
height <- getWord32le
numColorPlanes <- getWord16le
when (numColorPlanes /= 1) $ do
fail $ printf "numColorPlanes with value '%d' which is other than 1 is not supported" numColorPlanes
bitsPerPixel <- getWord16le
when (bitsPerPixel /= 24) $ do
fail $ printf "bitsPerPixel with value '%d' which is other than 24 is not supported" bitsPerPixel
compression <- getWord32le
when (compression /= 0) $ do
fail $ printf "compression with value '%d' which is other than 0 is not supported; needs to be uncompressed RGB" compression
imageSize <- getWord32le
let shouldBeImageSize = (3 * width + padding) * height
padding = case (3 * width) `mod` 4 of
0 -> 0
n -> 4 n
when (imageSize /= shouldBeImageSize) $ do
fail $ printf "imageSize was read to be '%d', but it should be '%d' since the dimensions of the bitmap are (%d, %d)" imageSize shouldBeImageSize width height
skip 16
when (offset' > 0) $ do
skip $ fromIntegral offset'
imgData <- getLazyByteString (fromIntegral imageSize)
return (width, height, imgData)
(width, height, imgData) <- tablespoon . flip runGet (S.toLazyByteString s) $ getImgInfo
let metaBitmap = constructPixels (const leastIntensity) (fromIntegral width, fromIntegral height)
decodeImageFmt IBF_BGR24A4VR metaBitmap $ imgData
tryCBF_BMPIUU :: (S.StringCells s, Bitmap bmp) => s -> Either String bmp
tryCBF_BMPIUU s = do
let getImgInfo = do
m0 <- getWord8
m1 <- getWord8
when (m0 /= 0x42 || m1 /= 0x4D) $ do
fail "magic sequence is not that of BMP format"
skip 8
offset <- getWord32le
let offset' = offset 0x0E 40
when (offset' < 0) $ do
fail $ printf "rewinding to image data at offset %d not supported" offset
headerSize <- getWord32le
when (headerSize /= 40) $ do
fail $ printf "header with size '%d' which is other than 40 is not supported" headerSize
width <- getWord32le
height <- getWord32le
numColorPlanes <- getWord16le
when (numColorPlanes /= 1) $ do
fail $ printf "numColorPlanes with value '%d' which is other than 1 is not supported" numColorPlanes
bitsPerPixel <- getWord16le
when (bitsPerPixel /= 32) $ do
fail $ printf "bitsPerPixel with value '%d' which is other than 32 is not supported" bitsPerPixel
compression <- getWord32le
when (compression /= 0) $ do
fail $ printf "compression with value '%d' which is other than 0 is not supported; needs to be uncompressed RGB" compression
imageSize <- getWord32le
let shouldBeImageSize = 4 * width * height
when (imageSize /= shouldBeImageSize) $ do
fail $ printf "imageSize was read to be '%d', but it should be '%d' since the dimensions of the bitmap are (%d, %d)" imageSize shouldBeImageSize width height
skip 16
when (offset' > 0) $ do
skip $ fromIntegral offset'
imgData <- getLazyByteString (fromIntegral imageSize)
return (width, height, imgData)
(width, height, imgData) <- tablespoon . flip runGet (S.toLazyByteString s) $ getImgInfo
let metaBitmap = constructPixels (const leastIntensity) (fromIntegral width, fromIntegral height)
decodeImageFmt IBF_BGRU32VR metaBitmap $ imgData
tryCBF_BMPIU64 :: (S.StringCells s, Bitmap bmp) => s -> Either String bmp
tryCBF_BMPIU64 s = decodeCompleteFmt CBF_BMPIU =<< (maybe (Left "Data.Bitmap.Class.tryCBF_BMPIU64: not a valid sequence of characters representing a base-64 encoded string") Right $ decode64 s)
tryCBF_BMPIUZ64 :: (S.StringCells s, Bitmap bmp) => s -> Either String bmp
tryCBF_BMPIUZ64 s = decodeCompleteFmt CBF_BMPIU =<< tablespoon . decompress . S.toStringCells =<< (maybe (Left "Data.Bitmap.Class.tryCBF_BMPIUZ64: not a valid sequence of characters representing a base-64 encoded string") Right $ decode64 s)
defaultImageEncoders :: [(ImageBitmapFormat, GenericBitmapSerializer ImageEncoder)]
defaultImageEncoders =
[ (IBF_IDRGB32Z64, GenericBitmapSerializer $ ImageEncoder $ encodeIBF_IDRGB32Z64)
, (IBF_IDRGB24Z64, GenericBitmapSerializer $ ImageEncoder $ encodeIBF_IDRGB24Z64)
, (IBF_IDBGR24R2RZ64, GenericBitmapSerializer $ ImageEncoder $ encodeIBF_IDBGR24R2RZ64)
, (IBF_IDBGR24HZH, GenericBitmapSerializer $ ImageEncoder $ encodeIBF_IDBGR24HZH)
, (IBF_BGR24H, GenericBitmapSerializer $ ImageEncoder $ encodeIBF_BGR24H)
, (IBF_BGR24A4VR, GenericBitmapSerializer $ ImageEncoder $ encodeIBF_BGR24A4VR)
, (IBF_BGRU32VR, GenericBitmapSerializer $ ImageEncoder $ encodeIBF_BGRU32VR)
, (IBF_BGRU32, GenericBitmapSerializer $ ImageEncoder $ encodeIBF_BGRU32)
, (IBF_RGB24A4VR, GenericBitmapSerializer $ ImageEncoder $ encodeIBF_RGB24A4VR)
, (IBF_RGB24A4, GenericBitmapSerializer $ ImageEncoder $ encodeIBF_RGB24A4)
, (IBF_RGB32, GenericBitmapSerializer $ ImageEncoder $ encodeIBF_RGB32)
, (IBF_RGB32Z64, GenericBitmapSerializer $ ImageEncoder $ encodeIBF_RGB32Z64)
]
encodeIBF_IDRGB24Z64 :: forall s bmp. (S.StringCells s, Bitmap bmp) => bmp -> s
encodeIBF_IDRGB24Z64 b = ((untag' . S.toMainChar $ 'm') `S.cons`) . encode64 . S.fromStringCells . compress
$ S.unfoldrN (fromIntegral $ 3 * width * height) getComponent (0, 0, 0 :: Int)
where getComponent (row, column, orgb)
| orgb > 2 =
getComponent (row, succ column, 0)
| column > maxColumn =
getComponent (succ row, 0, 0)
| row > maxRow =
Nothing
| otherwise =
let pixel = pixelf (row, column)
componentGetter =
case orgb of
0 -> untagBS . S.toMainChar . (red <:)
1 -> untagBS . S.toMainChar . (green <:)
2 -> untagBS . S.toMainChar . (blue <:)
_ -> undefined
in Just (componentGetter pixel, (row, column, succ orgb))
pixelf = (b `getPixel`)
(width_, height_) = dimensions b
(width, height) = (fromIntegral width_, fromIntegral height_)
maxRow = abs . pred $ height
maxColumn = abs . pred $ width
untag' = untag :: Tagged s a -> a
untagBS = untag :: Tagged B.ByteString a -> a
encodeIBF_IDBGR24R2RZ64 :: forall s bmp. (S.StringCells s, Bitmap bmp) => bmp -> s
encodeIBF_IDBGR24R2RZ64 b = ((untag' . S.toMainChar $ 'b') `S.cons`) . encode64 . S.fromStringCells . compress
$ S.unfoldrN (fromIntegral $ 3 * width * height) getComponent (0, 0, 0 :: Int)
where getComponent (row, column, orgb)
| orgb > 2 =
getComponent (row, succ column, 0)
| column > maxColumn =
getComponent (succ row, 0, 0)
| row > maxRow =
Nothing
| otherwise =
let pixel = pixelf (row, column)
componentGetter =
case orgb of
2 -> untagBS . S.toMainChar . (red <:)
1 -> untagBS . S.toMainChar . (green <:)
0 -> untagBS . S.toMainChar . (blue <:)
_ -> undefined
in Just (componentGetter pixel, (row, column, succ orgb))
pixelf = (b `getPixel`)
(width_, height_) = dimensions b
(width, height) = (fromIntegral width_, fromIntegral height_)
maxRow = abs . pred $ height
maxColumn = abs . pred $ width
untag' = untag :: Tagged s a -> a
untagBS = untag :: Tagged B.ByteString a -> a
encodeIBF_IDBGR24HZH :: forall s bmp. (S.StringCells s, Bitmap bmp) => bmp -> s
encodeIBF_IDBGR24HZH = ((untag' . S.toMainChar $ 'z') `S.cons`) . encodeHex . S.fromStringCells . compress . encodeImageFmt IBF_BGR24H
where untag' = untag :: Tagged s a -> a
encodeIBF_IDRGB32Z64 :: forall s bmp. (S.StringCells s, Bitmap bmp) => bmp -> s
encodeIBF_IDRGB32Z64 = ((untag' . S.toMainChar $ 'l') `S.cons`) . encodeImageFmt IBF_RGB32Z64
where untag' = untag :: Tagged s a -> a
encodeIBF_BGR24H :: forall s bmp. (S.StringCells s, Bitmap bmp) => bmp -> s
encodeIBF_BGR24H b =
encodeHex $ S.unfoldrN (fromIntegral $ 4 * width * height) getComponent (0, 0, 0 :: Int)
where getComponent (row, column, orgb)
| orgb > 2 =
getComponent (row, succ column, 0)
| column > maxColumn =
getComponent (succ row, 0, 0)
| row > maxRow =
Nothing
| otherwise =
let pixel = pixelf (row, column)
componentGetter =
case orgb of
2 -> untag' . S.toMainChar . (red <:)
1 -> untag' . S.toMainChar . (green <:)
0 -> untag' . S.toMainChar . (blue <:)
_ -> undefined
in Just (componentGetter pixel, (row, column, succ orgb))
pixelf = (b `getPixel`)
(width_, height_) = dimensions b
(width, height) = (fromIntegral width_, fromIntegral height_)
maxRow = abs . pred $ height
maxColumn = abs . pred $ width
untag' = untag :: Tagged s a -> a
encodeIBF_RGB24A4 :: forall s bmp. (S.StringCells s, Bitmap bmp) => bmp -> s
encodeIBF_RGB24A4 b =
S.unfoldrN (fromIntegral $ (3 * width + paddingSize) * height) getComponent (0, 0, 0 :: Int, 0)
where getComponent (row, column, orgb, paddingLeft)
| paddingLeft > 0 =
Just (padCell, (row, column, orgb, pred paddingLeft))
| orgb > 2 =
getComponent (row, succ column, 0, 0)
| column > maxColumn =
getComponent (succ row, 0, 0, paddingSize)
| row > maxRow =
Nothing
| otherwise =
let pixel = pixelf (row, column)
componentGetter =
case orgb of
0 -> untag' . S.toMainChar . (red <:)
1 -> untag' . S.toMainChar . (green <:)
2 -> untag' . S.toMainChar . (blue <:)
_ -> undefined
in Just (componentGetter pixel, (row, column, succ orgb, 0))
pixelf = (b `getPixel`)
(width_, height_) = dimensions b
(width, height) = (fromIntegral width_, fromIntegral height_)
maxRow = abs . pred $ height
maxColumn = abs . pred $ width
paddingSize = case 4 ((3 * width) `mod` 4) of
4 -> 0
n -> n
padCell = untag' . S.toMainChar $ padByte
untag' = untag :: Tagged s a -> a
encodeIBF_BGR24A4VR :: forall s bmp. (S.StringCells s, Bitmap bmp) => bmp -> s
encodeIBF_BGR24A4VR b =
S.unfoldrN (fromIntegral $ (3 * width + paddingSize) * height) getComponent (0, 0, 0 :: Int, 0)
where getComponent (row, column, orgb, paddingLeft)
| paddingLeft > 0 =
Just (padCell, (row, column, orgb, pred paddingLeft))
| orgb > 2 =
getComponent (row, succ column, 0, 0)
| column > maxColumn =
getComponent (succ row, 0, 0, paddingSize)
| row > maxRow =
Nothing
| otherwise =
let pixel = pixelf (maxRow row, column)
componentGetter =
case orgb of
2 -> untag' . S.toMainChar . (red <:)
1 -> untag' . S.toMainChar . (green <:)
0 -> untag' . S.toMainChar . (blue <:)
_ -> undefined
in Just (componentGetter pixel, (row, column, succ orgb, 0))
pixelf = (b `getPixel`)
(width_, height_) = dimensions b
(width, height) = (fromIntegral width_, fromIntegral height_)
maxRow = abs . pred $ height
maxColumn = abs . pred $ width
paddingSize = case 4 ((3 * width) `mod` 4) of
4 -> 0
n -> n
padCell = untag' . S.toMainChar $ padByte
untag' = untag :: Tagged s a -> a
encodeIBF_BGRU32VR :: forall s bmp. (S.StringCells s, Bitmap bmp) => bmp -> s
encodeIBF_BGRU32VR b =
S.unfoldrN (fromIntegral $ 4 * width * height) getComponent (0, 0, 0 :: Int)
where getComponent (row, column, orgb)
| orgb > 3 =
getComponent (row, succ column, 0)
| column > maxColumn =
getComponent (succ row, 0, 0)
| row > maxRow =
Nothing
| otherwise =
let pixel = pixelf (maxRow row, column)
componentGetter =
case orgb of
3 -> const padCell
2 -> untag' . S.toMainChar . (red <:)
1 -> untag' . S.toMainChar . (green <:)
0 -> untag' . S.toMainChar . (blue <:)
_ -> undefined
in Just (componentGetter pixel, (row, column, succ orgb))
pixelf = (b `getPixel`)
(width_, height_) = dimensions b
(width, height) = (fromIntegral width_, fromIntegral height_)
maxRow = abs . pred $ height
maxColumn = abs . pred $ width
padCell = untag' . S.toMainChar $ padByte
untag' = untag :: Tagged s a -> a
encodeIBF_BGRU32 :: forall s bmp. (S.StringCells s, Bitmap bmp) => bmp -> s
encodeIBF_BGRU32 b =
S.unfoldrN (fromIntegral $ 4 * width * height) getComponent (0, 0, 0 :: Int)
where getComponent (row, column, orgb)
| orgb > 3 =
getComponent (row, succ column, 0)
| column > maxColumn =
getComponent (succ row, 0, 0)
| row > maxRow =
Nothing
| otherwise =
let pixel = pixelf (row, column)
componentGetter =
case orgb of
3 -> const padCell
2 -> untag' . S.toMainChar . (red <:)
1 -> untag' . S.toMainChar . (green <:)
0 -> untag' . S.toMainChar . (blue <:)
_ -> undefined
in Just (componentGetter pixel, (row, column, succ orgb))
pixelf = (b `getPixel`)
(width_, height_) = dimensions b
(width, height) = (fromIntegral width_, fromIntegral height_)
maxRow = abs . pred $ height
maxColumn = abs . pred $ width
padCell = untag' . S.toMainChar $ padByte
untag' = untag :: Tagged s a -> a
encodeIBF_RGB24A4VR :: forall s bmp. (S.StringCells s, Bitmap bmp) => bmp -> s
encodeIBF_RGB24A4VR b =
S.unfoldrN (fromIntegral $ (3 * width + paddingSize) * height) getComponent (0, 0, 0 :: Int, 0)
where getComponent (row, column, orgb, paddingLeft)
| paddingLeft > 0 =
Just (padCell, (row, column, orgb, pred paddingLeft))
| orgb > 2 =
getComponent (row, succ column, 0, 0)
| column > maxColumn =
getComponent (succ row, 0, 0, paddingSize)
| row > maxRow =
Nothing
| otherwise =
let pixel = pixelf (maxRow row, column)
componentGetter =
case orgb of
0 -> untag' . S.toMainChar . (red <:)
1 -> untag' . S.toMainChar . (green <:)
2 -> untag' . S.toMainChar . (blue <:)
_ -> undefined
in Just (componentGetter pixel, (row, column, succ orgb, 0))
pixelf = (b `getPixel`)
(width_, height_) = dimensions b
(width, height) = (fromIntegral width_, fromIntegral height_)
maxRow = abs . pred $ height
maxColumn = abs . pred $ width
paddingSize = case 4 ((3 * width) `mod` 4) of
4 -> 0
n -> n
padCell = untag' . S.toMainChar $ padByte
untag' = untag :: Tagged s a -> a
encodeIBF_RGB32 :: forall s bmp. (S.StringCells s, Bitmap bmp) => bmp -> s
encodeIBF_RGB32 b =
S.unfoldrN (fromIntegral $ 4 * width * height) getComponent (0, 0, 0 :: Int)
where getComponent (row, column, orgb)
| orgb > 3 =
getComponent (row, succ column, 0)
| column > maxColumn =
getComponent (succ row, 0, 0)
| row > maxRow =
Nothing
| otherwise =
let pixel = pixelf (row, column)
componentGetter =
case orgb of
0 -> const padCell
1 -> untag' . S.toMainChar . (red <:)
2 -> untag' . S.toMainChar . (green <:)
3 -> untag' . S.toMainChar . (blue <:)
_ -> undefined
in Just (componentGetter pixel, (row, column, succ orgb))
pixelf = (b `getPixel`)
(width_, height_) = dimensions b
(width, height) = (fromIntegral width_, fromIntegral height_)
maxRow = abs . pred $ height
maxColumn = abs . pred $ width
padCell = untag' . S.toMainChar $ padByte
untag' = untag :: Tagged s a -> a
encodeIBF_RGB32Z64 :: forall s bmp. (S.StringCells s, Bitmap bmp) => bmp -> s
encodeIBF_RGB32Z64 = encode64 . S.fromStringCells . compress . encodeImageFmt IBF_RGB32
defaultImageDecoders :: [(ImageBitmapFormat, GenericBitmapSerializer ImageDecoder)]
defaultImageDecoders =
[ (IBF_IDRGB32Z64, GenericBitmapSerializer $ ImageDecoder $ tryIBF_IDRGB32Z64)
, (IBF_IDRGB24Z64, GenericBitmapSerializer $ ImageDecoder $ tryIBF_IDRGB24Z64)
, (IBF_IDBGR24R2RZ64, GenericBitmapSerializer $ ImageDecoder $ tryIBF_IDBGR24R2RZ64)
, (IBF_IDBGR24HZH, GenericBitmapSerializer $ ImageDecoder $ tryIBF_IDBGR24HZH)
, (IBF_BGR24H, GenericBitmapSerializer $ ImageDecoder $ tryIBF_BGR24H)
, (IBF_BGR24A4VR, GenericBitmapSerializer $ ImageDecoder $ tryIBF_BGR24A4VR)
, (IBF_BGRU32VR, GenericBitmapSerializer $ ImageDecoder $ tryIBF_BGRU32VR)
, (IBF_BGRU32, GenericBitmapSerializer $ ImageDecoder $ tryIBF_BGRU32)
, (IBF_RGB24A4VR, GenericBitmapSerializer $ ImageDecoder $ tryIBF_RGB24A4VR)
, (IBF_RGB24A4, GenericBitmapSerializer $ ImageDecoder $ tryIBF_RGB24A4)
, (IBF_RGB32, GenericBitmapSerializer $ ImageDecoder $ tryIBF_RGB32)
, (IBF_RGB32Z64, GenericBitmapSerializer $ ImageDecoder $ tryIBF_RGB32Z64)
]
tryIBF_IDRGB24Z64 :: forall s bmp. (S.StringCells s, Bitmap bmp) => bmp -> s -> Either String bmp
tryIBF_IDRGB24Z64 metaBitmap s_
| (Just ('m', s')) <- (first S.toChar) <$> S.safeUncons s_
= tryIBF_IDRGB24Z64' =<< tablespoon . decompress . S.toStringCells =<< (maybe (Left "Data.Bitmap.Class.tryIBF_IDRGB24Z64: not a valid sequence of characters representing a base-64 encoded string") Right $ decode64 s')
| otherwise
= Left "Data.Bitmap.Class.tryIBF_IDRGB24Z64: string does not begin with identifying 'b' character"
where tryIBF_IDRGB24Z64' :: (S.StringCells s2) => s2 -> Either String bmp
tryIBF_IDRGB24Z64' s
| S.length s < minLength = Left $ printf "Data.Bitmap.Class.tryIBF_IDRGB24Z64: string is too small to contain the pixels of a bitmap with the dimensions of the passed bitmap, which are (%d, %d); the string is %d bytes long, but needs to be at least %d bytes long" (fromIntegral width :: Integer) (fromIntegral height :: Integer) (S.length s) minLength
| otherwise = Right $
constructPixels pixelf dms
where (width, height) = dimensions metaBitmap
dms = (fromIntegral width, fromIntegral height)
bytesPerPixel = 3
bytesPerRow = bytesPerPixel * width
minLength = fromIntegral $ bytesPerRow * height
pixelf (row, column) = let offset = fromIntegral $ bytesPerRow * (fromIntegral row) + bytesPerPixel * (fromIntegral column)
in (red =: (S.toWord8 $ s `S.index` (offset + 0)))
. (green =: (S.toWord8 $ s `S.index` (offset + 1)))
. (blue =: (S.toWord8 $ s `S.index` (offset + 2)))
$ leastIntensity
tryIBF_IDBGR24R2RZ64 :: forall s bmp. (S.StringCells s, Bitmap bmp) => bmp -> s -> Either String bmp
tryIBF_IDBGR24R2RZ64 metaBitmap s_
| (Just ('b', s')) <- (first S.toChar) <$> S.safeUncons s_
= tryIBF_IDBGR24R2RZ64' =<< tablespoon . decompress . S.toStringCells =<< (maybe (Left "Data.Bitmap.Class.tryIBF_IDBGR24R2RZ64: not a valid sequence of characters representing a base-64 encoded string") Right $ decode64 s')
| otherwise
= Left "Data.Bitmap.Class.tryIBF_IDBGR24R2RZ64: string does not begin with identifying 'b' character"
where tryIBF_IDBGR24R2RZ64' :: (S.StringCells s2) => s2 -> Either String bmp
tryIBF_IDBGR24R2RZ64' s
| S.length s < minLength = Left $ printf "Data.Bitmap.Class.tryIBF_IDBGR24R2RZ64: string is too small to contain the pixels of a bitmap with the dimensions of the passed bitmap, which are (%d, %d); the string is %d bytes long, but needs to be at least %d bytes long" (fromIntegral width :: Integer) (fromIntegral height :: Integer) (S.length s) minLength
| otherwise = Right $
constructPixels pixelf dms
where (width, height) = dimensions metaBitmap
dms = (fromIntegral width, fromIntegral height)
maxRow = abs . pred $ height
maxColumn = abs . pred $ width
bytesPerPixel = 3
bytesPerRow = bytesPerPixel * width
minLength = fromIntegral $ bytesPerRow * height
pixelf (row, column)
| (row, column) == (maxRow, maxColumn)
= (red =: (S.toWord8 $ s `S.index` 1))
. (green =: (S.toWord8 $ s `S.index` 0))
. (blue =: (S.toWord8 . S.last $ s))
$ leastIntensity
| otherwise
= let offset = fromIntegral $ bytesPerRow * (fromIntegral row) + bytesPerPixel * (fromIntegral column) + 2
in (red =: (S.toWord8 $ s `S.index` (offset + 2)))
. (green =: (S.toWord8 $ s `S.index` (offset + 1)))
. (blue =: (S.toWord8 $ s `S.index` (offset + 0)))
$ leastIntensity
tryIBF_IDBGR24HZH :: forall s bmp. (S.StringCells s, Bitmap bmp) => bmp -> s -> Either String bmp
tryIBF_IDBGR24HZH metaBitmap s_
| (Just ('z', s')) <- (first S.toChar) <$> S.safeUncons s_
= decodeImageFmt IBF_BGR24H metaBitmap =<< tablespoon . decompress . S.toStringCells =<< (maybe (Left "Data.Bitmap.Class.tryIBF_IDBGR24HZH: not a valid sequence of characters representing a base-16 encoded string") Right $ decodeHex s')
| otherwise
= Left "Data.Bitmap.Class.tryIBF_IDBGR24HZH: string does not begin with identifying 'z' character"
tryIBF_IDRGB32Z64 :: forall s bmp. (S.StringCells s, Bitmap bmp) => bmp -> s -> Either String bmp
tryIBF_IDRGB32Z64 metaBitmap s_
| (Just ('l', s')) <- (first S.toChar) <$> S.safeUncons s_
= decodeImageFmt IBF_RGB32Z64 metaBitmap s'
| otherwise
= Left "Data.Bitmap.Class.tryIBF_IDRGB32Z64: string does not begin with identifying 'l' character"
tryIBF_BGR24H :: forall s bmp. (S.StringCells s, Bitmap bmp) => bmp -> s -> Either String bmp
tryIBF_BGR24H metaBitmap s_
| S.length s_ < minLength = Left $ printf "Data.Bitmap.Class.tryIBF_BGR24H: string is too small to contain the pixels of a bitmap with the dimensions of the passed bitmap, which are (%d, %d); the string is %d bytes long, but needs to be at least %d bytes long" (fromIntegral width :: Integer) (fromIntegral height :: Integer) (S.length s_) minLength
| otherwise = tryIBF_BGR24H' =<< (maybe (Left "Data.Bitmap.Class.tryIBF_BGR24H: not a valid sequence of characters representing a base-16 encoded string") Right $ decodeHex s_)
where tryIBF_BGR24H' :: (S.StringCells s2) => s2 -> Either String bmp
tryIBF_BGR24H' s
| S.length s < minLengthDecoded = Left $ printf "Data.Bitmap.Class.tryIBF_BGR24H: the size of the encoded string, %d, is correct because it is at least %d, but after it was hex decoded, its size was incorrect; it was %d and it should have been at least %d; most likely there is a non-hex character too early in the string" (S.length s_) minLength (S.length s) minLengthDecoded
| otherwise = Right $ constructPixels pixelf dms
where pixelf (row, column) = let offset = fromIntegral $ bytesPerRow * (fromIntegral row) + bytesPerPixel * (fromIntegral column)
in (red =: (S.toWord8 $ s `S.index` (offset + 2)))
. (green =: (S.toWord8 $ s `S.index` (offset + 1)))
. (blue =: (S.toWord8 $ s `S.index` (offset + 0)))
$ leastIntensity
dms = (fromIntegral width, fromIntegral height)
(width, height) = dimensions metaBitmap
bytesPerPixel = 3
bytesPerRow = bytesPerPixel * width
minLength = fromIntegral $ 2 * 3 * width * height
minLengthDecoded = fromIntegral $ bytesPerRow * height
tryIBF_RGB24A4 :: (S.StringCells s, Bitmap bmp) => bmp -> s -> Either String bmp
tryIBF_RGB24A4 metaBitmap s
| S.length s < minLength = Left $ printf "Data.Bitmap.Class.tryIBF_RGB24A4: string is too small to contain the pixels of a bitmap with the dimensions of the passed bitmap, which are (%d, %d); the string is %d bytes long, but needs to be at least %d bytes long" (fromIntegral width :: Integer) (fromIntegral height :: Integer) (S.length s) minLength
| otherwise = Right $
constructPixels pixelf dms
where (width, height) = dimensions metaBitmap
dms = (fromIntegral width, fromIntegral height)
padding = case 4 ((3 * width) `mod` 4) of
4 -> 0
n -> n
bytesPerPixel = 3
bytesPerRow = bytesPerPixel * width + padding
minLength = fromIntegral $ bytesPerRow * height
pixelf (row, column) = let offset = fromIntegral $ bytesPerRow * (fromIntegral row) + bytesPerPixel * (fromIntegral column)
in (red =: (S.toWord8 $ s `S.index` (offset + 0)))
. (green =: (S.toWord8 $ s `S.index` (offset + 1)))
. (blue =: (S.toWord8 $ s `S.index` (offset + 2)))
$ leastIntensity
tryIBF_BGR24A4VR :: (S.StringCells s, Bitmap bmp) => bmp -> s -> Either String bmp
tryIBF_BGR24A4VR metaBitmap s
| S.length s < minLength = Left $ printf "Data.Bitmap.Class.tryIBF_BGR24A4VR: string is too small to contain the pixels of a bitmap with the dimensions of the passed bitmap, which are (%d, %d); the string is %d bytes long, but needs to be at least %d bytes long" (fromIntegral width :: Integer) (fromIntegral height :: Integer) (S.length s) minLength
| otherwise = Right $
constructPixels pixelf dms
where (width, height) = dimensions metaBitmap
dms = (fromIntegral width, fromIntegral height)
padding = case 4 ((3 * width) `mod` 4) of
4 -> 0
n -> n
bytesPerPixel = 3
bytesPerRow = bytesPerPixel * width + padding
minLength = fromIntegral $ bytesPerRow * height
maxRow = abs . pred $ height
pixelf (row, column) = let offset = fromIntegral $ bytesPerRow * (fromIntegral $ maxRow row) + bytesPerPixel * (fromIntegral column)
in (red =: (S.toWord8 $ s `S.index` (offset + 2)))
. (green =: (S.toWord8 $ s `S.index` (offset + 1)))
. (blue =: (S.toWord8 $ s `S.index` (offset + 0)))
$ leastIntensity
tryIBF_BGRU32VR :: (S.StringCells s, Bitmap bmp) => bmp -> s -> Either String bmp
tryIBF_BGRU32VR metaBitmap s
| S.length s < minLength = Left $ printf "Data.Bitmap.Class.tryIBF_BGRU32VR: string is too small to contain the pixels of a bitmap with the dimensions of the passed bitmap, which are (%d, %d); the string is %d bytes long, but needs to be at least %d bytes long" (fromIntegral width :: Integer) (fromIntegral height :: Integer) (S.length s) minLength
| otherwise = Right $
constructPixels pixelf dms
where (width, height) = dimensions metaBitmap
dms = (fromIntegral width, fromIntegral height)
bytesPerPixel = 4
bytesPerRow = bytesPerPixel * width
minLength = fromIntegral $ bytesPerRow * height
maxRow = abs . pred $ height
pixelf (row, column) = let offset = fromIntegral $ bytesPerRow * (fromIntegral $ maxRow row) + bytesPerPixel * (fromIntegral column)
in (red =: (S.toWord8 $ s `S.index` (offset + 2)))
. (green =: (S.toWord8 $ s `S.index` (offset + 1)))
. (blue =: (S.toWord8 $ s `S.index` (offset + 0)))
$ leastIntensity
tryIBF_BGRU32 :: (S.StringCells s, Bitmap bmp) => bmp -> s -> Either String bmp
tryIBF_BGRU32 metaBitmap s
| S.length s < minLength = Left $ printf "Data.Bitmap.Class.tryIBF_BGRU32: string is too small to contain the pixels of a bitmap with the dimensions of the passed bitmap, which are (%d, %d); the string is %d bytes long, but needs to be at least %d bytes long" (fromIntegral width :: Integer) (fromIntegral height :: Integer) (S.length s) minLength
| otherwise = Right $
constructPixels pixelf dms
where (width, height) = dimensions metaBitmap
dms = (fromIntegral width, fromIntegral height)
bytesPerPixel = 4
bytesPerRow = bytesPerPixel * width
minLength = fromIntegral $ bytesPerRow * height
pixelf (row, column) = let offset = fromIntegral $ bytesPerRow * (fromIntegral row) + bytesPerPixel * (fromIntegral column)
in (red =: (S.toWord8 $ s `S.index` (offset + 2)))
. (green =: (S.toWord8 $ s `S.index` (offset + 1)))
. (blue =: (S.toWord8 $ s `S.index` (offset + 0)))
$ leastIntensity
tryIBF_RGB24A4VR :: (S.StringCells s, Bitmap bmp) => bmp -> s -> Either String bmp
tryIBF_RGB24A4VR metaBitmap s
| S.length s < minLength = Left $ printf "Data.Bitmap.Class.tryIBF_RGB24A4VR: string is too small to contain the pixels of a bitmap with the dimensions of the passed bitmap, which are (%d, %d); the string is %d bytes long, but needs to be at least %d bytes long" (fromIntegral width :: Integer) (fromIntegral height :: Integer) (S.length s) minLength
| otherwise = Right $
constructPixels pixelf dms
where (width, height) = dimensions metaBitmap
dms = (fromIntegral width, fromIntegral height)
padding = case 4 ((3 * width) `mod` 4) of
4 -> 0
n -> n
bytesPerPixel = 3
bytesPerRow = bytesPerPixel * width + padding
minLength = fromIntegral $ bytesPerRow * height
maxRow = abs . pred $ height
pixelf (row, column) = let offset = fromIntegral $ bytesPerRow * (fromIntegral $ maxRow row) + bytesPerPixel * (fromIntegral column)
in (red =: (S.toWord8 $ s `S.index` (offset + 0)))
. (green =: (S.toWord8 $ s `S.index` (offset + 1)))
. (blue =: (S.toWord8 $ s `S.index` (offset + 2)))
$ leastIntensity
tryIBF_RGB32 :: (S.StringCells s, Bitmap bmp) => bmp -> s -> Either String bmp
tryIBF_RGB32 metaBitmap s
| S.length s < minLength = Left $ printf "Data.Bitmap.Class.tryIBF_RGB32: string is too small to contain the pixels of a bitmap with the dimensions of the passed bitmap, which are (%d, %d); the string is %d bytes long, but needs to be at least %d bytes long" (fromIntegral width :: Integer) (fromIntegral height :: Integer) (S.length s) minLength
| otherwise = Right $
constructPixels pixelf dms
where (width, height) = dimensions metaBitmap
dms = (fromIntegral width, fromIntegral height)
bytesPerPixel = 4
bytesPerRow = bytesPerPixel * width
minLength = fromIntegral $ bytesPerRow * height
pixelf (row, column) = let offset = fromIntegral $ bytesPerRow * (fromIntegral row) + bytesPerPixel * (fromIntegral column)
in (red =: (S.toWord8 $ s `S.index` (offset + 1)))
. (green =: (S.toWord8 $ s `S.index` (offset + 2)))
. (blue =: (S.toWord8 $ s `S.index` (offset + 3)))
$ leastIntensity
tryIBF_RGB32Z64 :: (S.StringCells s, Bitmap bmp) => bmp -> s -> Either String bmp
tryIBF_RGB32Z64 metaBitmap s = decodeImageFmt IBF_RGB32 metaBitmap =<< tablespoon . decompress . S.toStringCells =<< (maybe (Left "Data.Bitmap.Class.tryIBF_RGB32Z64: not a valid sequence of characters representing a base-64 encoded string") Right $ decode64 s)
encodeComplete :: (S.StringCells s, Bitmap bmp) => bmp -> s
encodeComplete
| null encoders = error $ printf "encodeComplete: implementation defines no encoders"
| otherwise = unwrapCompleteEncoder . snd . head $ encoders
where encoders = completeEncoders
decodeComplete :: (S.StringCells s, Bitmap bmp) => s -> Maybe (CompleteBitmapFormat, bmp)
decodeComplete s = listToMaybe . catMaybes . map (\(fmt, decoder) -> either (const Nothing) (Just . (fmt, )) $ unwrapCompleteDecoder decoder s) $ completeDecoders
encodeImage :: (S.StringCells s, Bitmap bmp) => bmp -> s
encodeImage
| null encoders = error $ printf "encodeImage: implementation defines no encoders"
| otherwise = unwrapImageEncoder . snd . head $ encoders
where encoders = imageEncoders
decodeImage :: (S.StringCells s, Bitmap bmp) => bmp -> s -> Maybe (ImageBitmapFormat, bmp)
decodeImage bmp s = listToMaybe . catMaybes . map (\(fmt, decoder) -> either (const Nothing) (Just . (fmt, )) $ unwrapImageDecoder decoder bmp s) $ imageDecoders
serializeFmt :: (Eq a, Show a) => [(a, b)] -> String -> (a -> b)
serializeFmt serializers noHandlerErrorFmtStr = \fmt -> case lookup fmt serializers of
(Just f) -> f
(Nothing) -> error $
printf
noHandlerErrorFmtStr
(show fmt)
encodeCompleteFmt :: (S.StringCells s, Bitmap bmp) => CompleteBitmapFormat -> bmp -> s
encodeCompleteFmt = unwrapCompleteEncoder . serializeFmt completeEncoders
"encodeCompleteFmt: Bitmap instance did not define handler for encoding format '%s'; does it use 'updateIdentifiableElements' with 'defaultCompleteEncoders' properly?"
decodeCompleteFmt :: (S.StringCells s, Bitmap bmp) => CompleteBitmapFormat -> s -> Either String bmp
decodeCompleteFmt = unwrapCompleteDecoder . serializeFmt completeDecoders
"decodeCompleteFmt: Bitmap instance did not define handler for decoding '%s'; does it use 'updateIdentifiableElements' with 'defaultCompleteDecoders' properly?"
encodeImageFmt :: (S.StringCells s, Bitmap bmp) => ImageBitmapFormat -> bmp -> s
encodeImageFmt = unwrapImageEncoder . serializeFmt imageEncoders
"encodeImageFmt: Bitmap instance did not define handler for encoding format '%s'; does it use 'updateIdentifiableElements' with 'defaultImageEncoders' properly?"
decodeImageFmt :: (S.StringCells s, Bitmap bmp) => ImageBitmapFormat -> bmp -> s -> Either String bmp
decodeImageFmt = unwrapImageDecoder . serializeFmt imageDecoders
"decodeImageFmt: Bitmap instance did not define handler for decoding format '%s'; does it use 'updateIdentifiableElements' with 'defaultImageDecoders' properly?"
decodeImageDimensions :: (S.StringCells s, Bitmap bmp) => Dimensions (BIndexType bmp) -> s -> Maybe (ImageBitmapFormat, bmp)
decodeImageDimensions dms = decodeImage (constructPixels (const leastIntensity) dms)
decodeImageDimensionsFmt :: (S.StringCells s, Bitmap bmp) => ImageBitmapFormat -> Dimensions (BIndexType bmp) -> s -> Either String bmp
decodeImageDimensionsFmt fmt dms = decodeImageFmt fmt (constructPixels (const leastIntensity) dms)
dimensionsFit :: (Integral a) => Dimensions a -> Dimensions a -> Bool
dimensionsFit (widthSuper, heightSuper) (widthSub, heightSub)
| widthSub > widthSuper = False
| heightSub > heightSuper = False
| otherwise = True
bitmapWidth :: (Bitmap bmp) => bmp -> BIndexType bmp
bitmapWidth bmp = let (width, _) = dimensions bmp in width
bitmapHeight :: (Bitmap bmp) => bmp -> BIndexType bmp
bitmapHeight bmp = let (_, height) = dimensions bmp in height