bitmaps-0.2.6.0: src/Data/Bitmap/Class.hs
{-# LANGUAGE TypeFamilies, PolymorphicComponents, TupleSections, FlexibleContexts, ScopedTypeVariables #-}
module Data.Bitmap.Class
( Bitmap(..)
, convertBitmap
-- * Polymorphic type wrappers
, CompleteEncoder(..)
, CompleteDecoder(..)
, ImageEncoder(..)
, ImageDecoder(..)
, GenericBitmapSerializer(..)
-- * Bitmap serialization
, 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
-- * Utility functions
, 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 -- For zlib
import Data.Maybe
import qualified Data.String.Class as S
import Data.Tagged
import Text.Printf
-- | Bitmap class
--
-- Pixels are indexed by (row, column), where (0, 0) represents the
-- upper-left-most corner of the bitmap. Instances of this class
-- are not required to support empty bitmaps.
--
-- The encoding and decoding lists contain functions that can encode
-- and decode or return a string containing information about why
-- it could not be decoded in that format. The order is important:
-- When a function tries multiple or any decoder, it will use or return
-- the one(s) closest to the head of the list. There are lists
-- of generic functions that are defined by default. Normally, if an
-- implementation of a bitmap type overrides the default instance,
-- it will only need to replace one or a few decoders, not touching
-- the rest of the default decoders or the order of the decoders;
-- thus the function 'updateIdentifiableElements' is defined and exported.
--
-- Instances *must* support every serialization format.
class (Integral (BIndexType bmp), Pixel (BPixelType bmp)) => Bitmap bmp where
type BIndexType bmp -- @ Integral type for each coordinate in an index
type BPixelType bmp -- @ Pixel type of structure
depth :: bmp -> Depth
-- ^ The color depth of the bitmap in bits
dimensions :: bmp -> Dimensions (BIndexType bmp)
-- ^ Return the width and height of the bitmap in pixels
getPixel :: bmp -> Coordinates (BIndexType bmp) -> BPixelType bmp
-- ^ Get a pixel; indexing starts at 0
--
-- Implementations can assume that the coordinates are within the
-- bounds of the bitmap. Thus callers of this function should always
-- ensure that the coordinates are within the bounds of the bitmap.
constructPixels :: (Coordinates (BIndexType bmp) -> BPixelType bmp) -> Dimensions (BIndexType bmp) -> bmp
-- ^ Construct a bitmap with a function that returns a pixel for each coordinate with the given dimensions
--
-- The function should return the same type of pixel for each coordinate.
--
-- Implementations are not required to call the function in any particular order, and are not even
-- required to guarantee that the function will be called for each pixel, which might be true for
-- a bitmap that is evaluated lazily as needed.
convertInternalFormat :: bmp -> bmp -> bmp
-- ^ Construct a new bitmap from the bitmap passed as the second argument but storing it in the bitmap of the meta-bitmap passed as the first argument
--
-- The purpose of this function is efficiency. Some bitmap types have multiple possible internal representations of bitmaps.
-- For these bitmap types, it is often more efficient when performing operations on multiple bitmaps for them be stored in the
-- same format. Instances might even always convert the bitmaps if their formats differ.
--
-- Implementations are not required to define this function
-- to store the second bitmap in another format, or even in the same
-- format as the first bitmap; this is only used for efficiency. They
-- should, however, return a bitmap that represents the same bitmap as
-- what the main bitmap (passed as the second argument) represents.
-- The default behaviour of this function is to return the main bitmap
-- (passed second) verbatim.
--
-- As an example application of this function, consider a program that
-- regularly captures the screen and searches for any of several
-- bitmaps which are read from the filesystem. The programmer
-- chooses the type that is most efficient for the format that
-- the screen capture is in, and uses it as the main type.
-- As the screen is expected to change, it would be inefficient
-- to convert each capture into another internal format each time,
-- especially since screen dumps can be very large. The bitmaps, however,
-- are generally static (and much smaller), so they could be converted
-- once using this function, 'convertInternalFormat', to the format that
-- screen captures are represented in, and reused. If the formats would
-- otherwise differ, this is much more efficient than converting the format
-- of every sub-bitmap every time a search or operation is needed.
--
-- NB: again, the format of the first argument is used along with
-- the image of the second argument to return (possibly) a bitmap
-- with the image of the second argument and with the format of the
-- first argument.
completeEncoders :: [(CompleteBitmapFormat, CompleteEncoder bmp)]
-- ^ Bitmap encoders; default definition is based on 'defaultCompleteEncoders'
--
-- As the head of the list might be best suited for writing to files
-- or generating text strings but not both, it is suggested that this
-- function is used only when it does not matter whether the result
-- is writable to a file or is generally "human readable".
completeDecoders :: [(CompleteBitmapFormat, CompleteDecoder bmp)]
-- ^ Bitmap decodes; extra bytes after the end should be ignored by them; default definition is based on 'defaultCompleteDecoders'
imageEncoders :: [(ImageBitmapFormat, ImageEncoder bmp)]
-- ^ Bitmap encoders; the meta-information is lost; default definition is based on 'defaultImageEncoders'
imageDecoders :: [(ImageBitmapFormat, ImageDecoder bmp)]
-- ^ Decode the bitmap; the meta-information from the given bitmap is used (see 'ImageDecoder'); default definition is based on 'defaultImageDecoders'
convertInternalFormat = const
completeEncoders = map (second unwrapGenericBitmapSerializer) defaultCompleteEncoders
completeDecoders = map (second unwrapGenericBitmapSerializer) defaultCompleteDecoders
imageEncoders = map (second unwrapGenericBitmapSerializer) defaultImageEncoders
imageDecoders = map (second unwrapGenericBitmapSerializer) defaultImageDecoders
-- | Convert one bitmap type to another
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.Stringy s) => bmp -> s}
newtype CompleteDecoder bmp = CompleteDecoder {unwrapCompleteDecoder :: (S.Stringy s) => s -> Either String bmp}
newtype ImageEncoder bmp = ImageEncoder {unwrapImageEncoder :: (S.Stringy s) => bmp -> s}
newtype ImageDecoder bmp = ImageDecoder {unwrapImageDecoder :: (S.Stringy s) => bmp -> s -> Either String bmp}
newtype GenericBitmapSerializer s = GenericBitmapSerializer {unwrapGenericBitmapSerializer :: (Bitmap bmp) => s bmp}
-- | Update identifiable elements
--
-- 'updateIdentifiableElements' @orig new@ returns @orig@ with each matching
-- pair updated; extraneous replacements in @new@ are ignored.
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.Stringy s, Bitmap bmp) => bmp -> s
encodeCBF_BMPIU b =
let (width, height) = dimensions b
header = S.fromLazyByteString . runPut $ do
-- Magic sequence
putWord8 (0x42 :: Word8)
putWord8 (0x4D :: Word8)
-- File size
putWord32le (fromIntegral $ 3 * width * height + padding * height + 0x0E + 40 :: Word32)
-- Reserved
putWord16le 0x0000
putWord16le 0x0000
-- Offset
putWord32le (0x0E + 40 :: Word32)
-- Bitmap information header; BITMAPINFOHEADER
-- header size
putWord32le (40 :: Word32)
-- width
putWord32le (fromIntegral width :: Word32)
-- height
putWord32le (fromIntegral height :: Word32)
-- number of color planes
putWord16le (1 :: Word16)
-- bits per pixel / depth
putWord16le (24 :: Word16)
-- compression
putWord32le (0 :: Word32) -- no compression
-- image size
putWord32le (fromIntegral $ 3 * width * height + padding * height :: Word32)
-- horizontal resolution; pixel per meter
putWord32le (3000 :: Word32)
-- vertical resolution; pixel per meter
putWord32le (3000 :: Word32)
-- number of colors
putWord32le (0 :: Word32)
-- number of important colors
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.Stringy s, Bitmap bmp) => bmp -> s
encodeCBF_BMPIUU b =
let (width, height) = dimensions b
header = S.fromLazyByteString . runPut $ do
-- Magic sequence
putWord8 (0x42 :: Word8)
putWord8 (0x4D :: Word8)
-- File size
putWord32le (fromIntegral $ 4 * width * height + 0x0E + 40 :: Word32)
-- Reserved
putWord16le 0x0000
putWord16le 0x0000
-- Offset
putWord32le (0x0E + 40 :: Word32)
-- Bitmap information header; BITMAPINFOHEADER
-- header size
putWord32le (40 :: Word32)
-- width
putWord32le (fromIntegral width :: Word32)
-- height
putWord32le (fromIntegral height :: Word32)
-- number of color planes
putWord16le (1 :: Word16)
-- bits per pixel / depth
putWord16le (32 :: Word16)
-- compression
putWord32le (0 :: Word32) -- no compression
-- image size
putWord32le (fromIntegral $ 4 * width * height :: Word32)
-- horizontal resolution; pixel per meter
putWord32le (3000 :: Word32)
-- vertical resolution; pixel per meter
putWord32le (3000 :: Word32)
-- number of colors
putWord32le (0 :: Word32)
-- number of important colors
putWord32le (0 :: Word32)
image = encodeImageFmt IBF_BGRU32VR b
in header `S.append` image
encodeCBF_BMPIU64 :: (S.Stringy s, Bitmap bmp) => bmp -> s
encodeCBF_BMPIU64 = encode64 . encodeCompleteFmt CBF_BMPIU
encodeCBF_BMPIUZ64 :: (S.Stringy 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.Stringy 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 filesize 4, reserved 2, reserved, 2
skip 8
offset <- getWord32le
-- get offset to image data
let offset' = offset - 0x0E - 40
when (offset' < 0) $ do
fail $ printf "rewinding to image data at offset %d not supported" offset
-- read DIB header
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 horRes 4, verRes 4, usedColors 4, importantColors 4
skip 16
-- skip to image data
when (offset' > 0) $ do
skip $ fromIntegral offset'
-- get image data
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.Stringy 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 filesize 4, reserved 2, reserved, 2
skip 8
offset <- getWord32le
-- get offset to image data
let offset' = offset - 0x0E - 40
when (offset' < 0) $ do
fail $ printf "rewinding to image data at offset %d not supported" offset
-- read DIB header
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 horRes 4, verRes 4, usedColors 4, importantColors 4
skip 16
-- skip to image data
when (offset' > 0) $ do
skip $ fromIntegral offset'
-- get image data
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.Stringy 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.Stringy 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.Stringy 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.Stringy 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.Stringy 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.Stringy 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.Stringy 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.Stringy 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.Stringy 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.Stringy 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.Stringy 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.Stringy 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.Stringy 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.Stringy 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.Stringy 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.Stringy 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.Stringy 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.Stringy 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.Stringy 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.Stringy 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.Stringy 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.Stringy 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.Stringy 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.Stringy 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.Stringy 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.Stringy 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.Stringy 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.Stringy 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.Stringy 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)
-- | Encode a bitmap
--
-- An implementation can choose the most efficient or appropriate
-- format by placing its encoder first in its list of encoders.
encodeComplete :: (S.Stringy s, Bitmap bmp) => bmp -> s
encodeComplete
| null encoders = error $ printf "encodeComplete: implementation defines no encoders"
| otherwise = unwrapCompleteEncoder . snd . head $ encoders
where encoders = completeEncoders
-- | Decode a bitmap
--
-- The result of first decoder of the implementation that succeeds
-- will be returned. If none succeed, 'Nothing' is returned.
decodeComplete :: (S.Stringy s, Bitmap bmp) => s -> Maybe (CompleteBitmapFormat, bmp)
decodeComplete s = listToMaybe . catMaybes . map (\(fmt, decoder) -> either (const Nothing) (Just . (fmt, )) $ unwrapCompleteDecoder decoder s) $ completeDecoders
-- | Encode the pixels of a bitmap
--
-- An implementation can choose the most efficient or appropriate
-- format by placing its encoder first in its list of encoders.
encodeImage :: (S.Stringy s, Bitmap bmp) => bmp -> s
encodeImage
| null encoders = error $ printf "encodeImage: implementation defines no encoders"
| otherwise = unwrapImageEncoder . snd . head $ encoders
where encoders = imageEncoders
-- | Decode the pixels of a bitmap
--
-- The result of first decoder of the implementation that succeeds
-- will be returned. If none succeed, 'Nothing' is returned.
decodeImage :: (S.Stringy 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)
-- | Encode a bitmap in a particular format
encodeCompleteFmt :: (S.Stringy 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?"
-- | Decode a bitmap in a particular format
decodeCompleteFmt :: (S.Stringy 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?"
-- | Encode the pixels of a bitmap in a particular format
encodeImageFmt :: (S.Stringy 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?"
-- | Decode the pixels of a bitmap in a particular format
decodeImageFmt :: (S.Stringy 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?"
-- | Decode an image with the given dimensions
--
-- This is only guaranteed to work on implementations and formats that only
-- need dimensions in addition to the raw pixel data. This is convenient
-- because most often the dimensions are all that is needed.
--
-- Currently, this function works by constructing a bitmap with the given dimensions
-- and with each pixel set to the least intensity. Thus it is significantly more efficient
-- if this is used with a bitmap that doesn't strictly evaluate the entire pixel data when the structure
-- is first constructed (not necessarily when any pixel is accessed) (currently
-- none of the bitmap types exported in this library are so strict), as the
-- bitmap will not need to be fully evaluated; only the dimensions will be used.
decodeImageDimensions :: (S.Stringy s, Bitmap bmp) => Dimensions (BIndexType bmp) -> s -> Maybe (ImageBitmapFormat, bmp)
decodeImageDimensions dms = decodeImage (constructPixels (const leastIntensity) dms)
-- | Decode an image with the given dimensions as 'decodeImageDimensions' does it, but in a specific format
decodeImageDimensionsFmt :: (S.Stringy s, Bitmap bmp) => ImageBitmapFormat -> Dimensions (BIndexType bmp) -> s -> Either String bmp
decodeImageDimensionsFmt fmt dms = decodeImageFmt fmt (constructPixels (const leastIntensity) dms)
-- | Determine whether the seconds dimensions passed can fit within the first dimensions passed
--
-- If the width or height of the second dimensions exceeds those of first
-- dimensions, 'False' is returned.
dimensionsFit :: (Integral a) => Dimensions a -> Dimensions a -> Bool
dimensionsFit (widthSuper, heightSuper) (widthSub, heightSub)
| widthSub > widthSuper = False
| heightSub > heightSuper = False
| otherwise = True
-- | Returns the width of a bitmap
bitmapWidth :: (Bitmap bmp) => bmp -> BIndexType bmp
bitmapWidth bmp = let (width, _) = dimensions bmp in width
-- | Returns the height of a bitmap
bitmapHeight :: (Bitmap bmp) => bmp -> BIndexType bmp
bitmapHeight bmp = let (_, height) = dimensions bmp in height