module Data.Bitmap.String.Internal
( BitmapString(..), bmps_data, bmps_dimensions, bmps_rowAlignment, bmps_redHead, bmps_alphaHead, bmps_paddingHead, bmps_paddingTail, bmps_rowFromTop, bmps_columnFromLeft, bmps_rowFromBeg, bmps_rowFromEnd, bmps_columnFromBeg, bmps_columnFromEnd
, formatEq
, defaultBSFormat
, rowPadding
, bytesPerPixel
, rowPaddingBS
, rgbOffsets
, alphaOffset
, pixelPart
, imageSizeBS
, constructBitmapStringFormatted
, bitmapFmtBGR24A4VR
, bitmapFmtRGB24A4VR
, bitmapFmtRGB24A4
, bitmapFmtRGB32
, encodeBSFormat
, encodeIBF_BGR24A4VR'
, encodeIBF_RGB24A4VR'
, encodeIBF_RGB24A4'
, encodeIBF_RGB32'
, tryBSFormat
, tryIBF_BGR24A4VR'
, tryIBF_RGB24A4VR'
, tryIBF_RGB24A4'
, tryIBF_RGB32'
) where
import Control.Applicative
import Control.Monad.Record hiding (get)
import Data.Bits
import Data.Binary
import Data.Bitmap.Class
import Data.Bitmap.Croppable
import Data.Bitmap.Pixel
import Data.Bitmap.Reflectable
import Data.Bitmap.Types
import Data.Bitmap.Util
import qualified Data.ByteString.Lazy as B
import qualified Data.Serialize as S
import qualified Data.String.Class as S
import Data.Tagged
import Text.Printf
data BitmapString = BitmapString
{ _bmps_data :: S.GenString
, _bmps_dimensions :: Dimensions (BIndexType BitmapString)
, _bmps_rowAlignment :: Int
, _bmps_redHead :: Bool
, _bmps_alphaHead :: Maybe Bool
, _bmps_paddingHead :: Int
, _bmps_paddingTail :: Int
, _bmps_rowFromTop :: Bool
, _bmps_columnFromLeft :: Bool
, _bmps_rowFromBeg :: Int
, _bmps_rowFromEnd :: Int
, _bmps_columnFromBeg :: Int
, _bmps_columnFromEnd :: Int
}
mkLabels [''BitmapString]
instance Binary BitmapString where
get = pure BitmapString <*> (S.toStringCells <$> (get :: Get B.ByteString)) <*> get <*> get <*> get <*> get <*> get <*> get <*> get <*> get <*> get <*> get <*> get <*> get
put b = do
put ((S.toStringCells :: S.GenString -> B.ByteString) $ bmps_data <: b)
put $ bmps_dimensions <: b
put $ bmps_rowAlignment <: b
put $ bmps_redHead <: b
put $ bmps_alphaHead <: b
put $ bmps_paddingHead <: b
put $ bmps_paddingTail <: b
put $ bmps_rowFromTop <: b
put $ bmps_columnFromLeft <: b
put $ bmps_rowFromBeg <: b
put $ bmps_rowFromEnd <: b
put $ bmps_columnFromBeg <: b
put $ bmps_columnFromEnd <: b
instance S.Serialize BitmapString where
get = pure BitmapString <*> (S.toStringCells <$> (S.get :: S.Get B.ByteString)) <*> S.get <*> S.get <*> S.get <*> S.get <*> S.get <*> S.get <*> S.get <*> S.get <*> S.get <*> S.get <*> S.get <*> S.get
put b = do
S.put ((S.toStringCells :: S.GenString -> B.ByteString) $ bmps_data <: b)
S.put $ bmps_dimensions <: b
S.put $ bmps_rowAlignment <: b
S.put $ bmps_redHead <: b
S.put $ bmps_alphaHead <: b
S.put $ bmps_paddingHead <: b
S.put $ bmps_paddingTail <: b
S.put $ bmps_rowFromTop <: b
S.put $ bmps_columnFromLeft <: b
S.put $ bmps_rowFromBeg <: b
S.put $ bmps_rowFromEnd <: b
S.put $ bmps_columnFromBeg <: b
S.put $ bmps_columnFromEnd <: b
formatEq :: BitmapString -> BitmapString -> Bool
formatEq a b
| bmps_rowAlignment <: a /= bmps_rowAlignment <: b = False
| bmps_redHead <: a /= bmps_redHead <: b = False
| bmps_alphaHead <: a /= bmps_alphaHead <: b = False
| bmps_paddingHead <: a /= bmps_paddingHead <: b = False
| bmps_paddingTail <: a /= bmps_paddingTail <: b = False
| bmps_rowFromTop <: a /= bmps_rowFromTop <: b = False
| bmps_columnFromLeft <: a /= bmps_columnFromLeft <: b = False
| bmps_rowFromBeg <: a /= bmps_rowFromBeg <: b = False
| bmps_rowFromEnd <: a /= bmps_rowFromEnd <: b = False
| bmps_columnFromBeg <: a /= bmps_columnFromBeg <: b = False
| bmps_columnFromEnd <: a /= bmps_columnFromEnd <: b = False
| otherwise = True
defaultBSFormat :: BitmapString
defaultBSFormat = BitmapString
{ _bmps_data = error "data of defaultBSFormat is undefined"
, _bmps_dimensions = error "dimensions of defaultBSFormat is undefined"
, _bmps_rowAlignment = 1
, _bmps_redHead = False
, _bmps_alphaHead = Nothing
, _bmps_paddingHead = 0
, _bmps_paddingTail = 1
, _bmps_rowFromTop = True
, _bmps_columnFromLeft = True
, _bmps_rowFromBeg = 0
, _bmps_rowFromEnd = 0
, _bmps_columnFromBeg = 0
, _bmps_columnFromEnd = 0
}
rowPadding :: BIndexType BitmapString -> Int -> Int -> (Int, Int)
rowPadding bytes_per_pixel width alignment =
(rawRowSize + off', off')
where rawRowSize = bytes_per_pixel * width
off = rawRowSize `mod` alignment
off'
| off == 0 = 0
| otherwise = alignment off
bytesPerPixel :: BitmapString -> Int
bytesPerPixel bmp = (maybe 0 (const 1) $ bmps_alphaHead <: bmp) + (bmps_paddingHead <: bmp) + (bmps_paddingTail <: bmp) + 3
rowPaddingBS :: BitmapString -> (Int, Int)
rowPaddingBS bmp = rowPadding (bytesPerPixel bmp) (fst $ bmps_dimensions <: bmp) (bmps_rowAlignment <: bmp)
rgbOffsets :: BitmapString -> (Int, Int, Int)
rgbOffsets b
| (Just True) <- bmps_alphaHead <: b
, True <- bmps_redHead <: b
= (ph + 1, ph + 2, ph + 3)
| (Just True) <- bmps_alphaHead <: b
, False <- bmps_redHead <: b
= (ph + 3, ph + 2, ph + 1)
| True <- bmps_redHead <: b
= (ph + 0, ph + 1, ph + 2)
| False <- bmps_redHead <: b
= (ph + 2, ph + 1, ph + 0)
| otherwise = error "Data.Bitmap.String.Internal.rgbOffsets: unexpected case"
where ph = bmps_paddingHead <: b
alphaOffset :: BitmapString -> Maybe Int
alphaOffset b
| (Just True) <- bmps_alphaHead <: b
= Just (ph)
| (Just False) <- bmps_alphaHead <: b
= Just (ph + 3)
| (Nothing) <- bmps_alphaHead <: b
= Nothing
| otherwise = error "Data.Bitmap.String.Internal.alphaOffset: unexpected case"
where ph = bmps_paddingHead <: b
pixelPart :: BitmapString -> BPixelType BitmapString -> Int -> S.StringCellChar S.GenStringDefault
pixelPart bmp pixel part
| Just True <- bmps_alphaHead <: bmp
, True <- bmps_redHead <: bmp
= case baseIndex of
1 -> r red
2 -> r green
3 -> r blue
_ -> padCell
| Just True <- bmps_alphaHead <: bmp
, False <- bmps_redHead <: bmp
= case baseIndex of
3 -> r red
2 -> r green
1 -> r blue
_ -> padCell
| True <- bmps_redHead <: bmp
= case baseIndex of
0 -> r red
1 -> r green
2 -> r blue
_ -> padCell
| False <- bmps_redHead <: bmp
= case baseIndex of
2 -> r red
1 -> r green
0 -> r blue
_ -> padCell
| otherwise = error "Data.Bitmap.String.Internal.pixelPart: unexpected case"
where ph = bmps_paddingHead <: bmp
baseIndex = part ph
r = untag' . S.toMainChar . (<: pixel)
padCell = untag' . S.toMainChar $ padByte
untag' = untag :: Tagged S.GenStringDefault a -> a
imageSizeBS :: BitmapString -> Int
imageSizeBS b = (fst $ rowPaddingBS b) * (snd $ dimensions b)
constructBitmapStringFormatted :: BitmapString -> Dimensions (BIndexType BitmapString) -> (Coordinates (BIndexType BitmapString) -> BPixelType BitmapString) -> BitmapString
constructBitmapStringFormatted metaBitmap dms@(width, height) f =
let maxRow = abs . pred $ height
maxColumn = abs . pred $ width
pixelSize = bytesPerPixel metaBitmap
(_, paddingSize) = rowPadding pixelSize width (bmps_rowAlignment <: metaBitmap)
rowSize = pixelSize * (width + bmps_columnFromBeg <: metaBitmap + bmps_columnFromEnd <: metaBitmap) + paddingSize
newImageSize = rowSize * (height + bmps_rowFromBeg <: metaBitmap + bmps_rowFromEnd <: metaBitmap)
data_ :: S.GenStringDefault
data_ = S.unfoldrN newImageSize getComponent (0 :: BIndexType BitmapString, 0 :: BIndexType BitmapString, 0 :: Int, rowSize * bmps_rowFromBeg <: metaBitmap :: Int)
untag' = untag :: Tagged S.GenStringDefault a -> a
padCell = untag' . S.toMainChar $ padByte
getComponent (row, column, part, paddingLeft)
| paddingLeft > 0 =
Just (padCell, (row, column, part, pred paddingLeft))
| part >= pixelSize =
getComponent (row, succ column, 0, 0)
| column > maxColumn =
getComponent (succ row, 0, 0, paddingSize)
| row == succ maxRow =
getComponent (succ row, column, part, rowSize * bmps_rowFromEnd <: metaBitmap)
| row > maxRow =
Nothing
| otherwise =
let pixel = f (row, column)
in Just (pixelPart metaBitmap pixel part, (row, column, succ part, 0))
in ((bmps_dimensions =: dms) . (bmps_data =: S.toStringCells data_)) $ metaBitmap
instance Bitmap BitmapString where
type BIndexType BitmapString = Int
type BPixelType BitmapString = PixelBGR
depth = maybe Depth24RGB (const Depth32RGBA) . (bmps_alphaHead <:)
dimensions bmp =
let (width, height) = bmps_dimensions <: bmp
in (width bmps_columnFromEnd <: bmp bmps_columnFromBeg <: bmp, height bmps_rowFromEnd <: bmp bmps_rowFromBeg <: bmp)
getPixel b (row, column) =
let data_ = bmps_data <: b
(width, height) = dimensions b
maxRow = abs . pred $ height
maxColumn = abs . pred $ width
rowSize = fst $ rowPaddingBS b
pixelSize = bytesPerPixel b
row' = row + bmps_rowFromBeg <: b
column' = column + bmps_columnFromBeg <: b
rowOffset
| bmps_rowFromTop <: b =
rowSize * row'
| otherwise =
rowSize * (maxRow row')
columnOffset
| bmps_columnFromLeft <: b =
pixelSize * column'
| otherwise =
pixelSize * (maxColumn column')
offset = rowOffset + columnOffset
(offR, offG, offB) = rgbOffsets b
in PixelBGR
$ ((fromIntegral . S.toWord8 $ data_ `S.index` (offset + offR)))
.|. ((fromIntegral . S.toWord8 $ data_ `S.index` (offset + offG)) `shiftL` 8)
.|. ((fromIntegral . S.toWord8 $ data_ `S.index` (offset + offB)) `shiftL` 16)
constructPixels = flip $ constructBitmapStringFormatted defaultBSFormat
convertInternalFormat metaBitmap imageBitmap
| formatEq metaBitmap imageBitmap = imageBitmap
| otherwise = constructBitmapStringFormatted metaBitmap (dimensions imageBitmap) (getPixel imageBitmap)
bitmapFmtBGR24A4VR :: BitmapString
bitmapFmtBGR24A4VR = BitmapString
{ _bmps_data = error "Data.Bitmap.String.Internal.bitmapFmtBGR24A4VR: data of format is undefined"
, _bmps_dimensions = error "Data.Bitmap.String.Internal.bitmapFmtBGR24A4VR: dimensions of format is undefined"
, _bmps_rowAlignment = 4
, _bmps_redHead = False
, _bmps_alphaHead = Nothing
, _bmps_paddingHead = 0
, _bmps_paddingTail = 0
, _bmps_rowFromTop = False
, _bmps_columnFromLeft = True
, _bmps_rowFromBeg = 0
, _bmps_rowFromEnd = 0
, _bmps_columnFromBeg = 0
, _bmps_columnFromEnd = 0
}
bitmapFmtRGB24A4VR :: BitmapString
bitmapFmtRGB24A4VR = BitmapString
{ _bmps_data = error "Data.Bitmap.String.Internal.bitmapFmtRGB24A4VR: data of format is undefined"
, _bmps_dimensions = error "Data.Bitmap.String.Internal.bitmapFmtBGR24A4VR: dimensions of format is undefined"
, _bmps_rowAlignment = 4
, _bmps_redHead = True
, _bmps_alphaHead = Nothing
, _bmps_paddingHead = 0
, _bmps_paddingTail = 0
, _bmps_rowFromTop = False
, _bmps_columnFromLeft = True
, _bmps_rowFromBeg = 0
, _bmps_rowFromEnd = 0
, _bmps_columnFromBeg = 0
, _bmps_columnFromEnd = 0
}
bitmapFmtRGB24A4 :: BitmapString
bitmapFmtRGB24A4 = BitmapString
{ _bmps_data = error "Data.Bitmap.String.Internal.bitmapFmtRGB24A4: data of format is undefined"
, _bmps_dimensions = error "Data.Bitmap.String.Internal.bitmapFmtBGR24A4: dimensions of format is undefined"
, _bmps_rowAlignment = 4
, _bmps_redHead = True
, _bmps_alphaHead = Nothing
, _bmps_paddingHead = 0
, _bmps_paddingTail = 0
, _bmps_rowFromTop = True
, _bmps_columnFromLeft = True
, _bmps_rowFromBeg = 0
, _bmps_rowFromEnd = 0
, _bmps_columnFromBeg = 0
, _bmps_columnFromEnd = 0
}
bitmapFmtRGB32 :: BitmapString
bitmapFmtRGB32 = BitmapString
{ _bmps_data = error "Data.Bitmap.String.Internal.bitmapFmtRGB32: data of format is undefined"
, _bmps_dimensions = error "Data.Bitmap.String.Internal.bitmapFmtBGR32: dimensions of format is undefined"
, _bmps_rowAlignment = 4
, _bmps_redHead = True
, _bmps_alphaHead = Nothing
, _bmps_paddingHead = 1
, _bmps_paddingTail = 0
, _bmps_rowFromTop = True
, _bmps_columnFromLeft = True
, _bmps_rowFromBeg = 0
, _bmps_rowFromEnd = 0
, _bmps_columnFromBeg = 0
, _bmps_columnFromEnd = 0
}
encodeBSFormat :: (S.Stringy s) => BitmapString -> (BitmapString -> s)
encodeBSFormat bsFmt = S.toStringCells . (bmps_data <:) . convertInternalFormat bsFmt
encodeIBF_BGR24A4VR' :: (S.Stringy s) => BitmapString -> s
encodeIBF_BGR24A4VR' = encodeBSFormat bitmapFmtBGR24A4VR
encodeIBF_RGB24A4VR' :: (S.Stringy s) => BitmapString -> s
encodeIBF_RGB24A4VR' = encodeBSFormat bitmapFmtRGB24A4VR
encodeIBF_RGB24A4' :: (S.Stringy s) => BitmapString -> s
encodeIBF_RGB24A4' = encodeBSFormat bitmapFmtRGB24A4
encodeIBF_RGB32' :: (S.Stringy s) => BitmapString -> s
encodeIBF_RGB32' = encodeBSFormat bitmapFmtRGB32
tryBSFormat :: (S.Stringy s) => String -> BitmapString -> (BitmapString -> s -> Either String BitmapString)
tryBSFormat identifier bsFmt bmp s
| S.length s < minLength = Left $ printf "Data.Bitmap.String.Internal.tryBSFormat: %s: 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 " identifier
| otherwise = Right $
(bmps_data =: S.toStringCells s)
. (bmps_dimensions =: dms)
$ bsFmt
where dms@(_, height) = dimensions bmp
rowSize = fst . rowPaddingBS . (bmps_dimensions =: dms) $ bsFmt
minLength = rowSize * height
tryIBF_BGR24A4VR' :: (S.Stringy s) => BitmapString -> s -> Either String BitmapString
tryIBF_BGR24A4VR' = tryBSFormat "tryIBF_BGR24A4VR'" bitmapFmtBGR24A4VR
tryIBF_RGB24A4VR' :: (S.Stringy s) => BitmapString -> s -> Either String BitmapString
tryIBF_RGB24A4VR' = tryBSFormat "tryIBF_RGB24A4VR'" bitmapFmtRGB24A4VR
tryIBF_RGB24A4' :: (S.Stringy s) => BitmapString -> s -> Either String BitmapString
tryIBF_RGB24A4' = tryBSFormat "tryIBF_RGB24A4'" bitmapFmtRGB24A4
tryIBF_RGB32' :: (S.Stringy s) => BitmapString -> s -> Either String BitmapString
tryIBF_RGB32' = tryBSFormat "tryIBF_RGB32'" bitmapFmtRGB32
instance BitmapReflectable BitmapString where
reflectVertically b = (bmps_rowFromTop $: not)
. (bmps_rowFromBeg =: bmps_rowFromEnd <: b)
. (bmps_rowFromEnd =: bmps_rowFromBeg <: b)
$ b
reflectHorizontally b = (bmps_columnFromLeft $: not)
. (bmps_columnFromBeg =: bmps_columnFromEnd <: b)
. (bmps_columnFromEnd =: bmps_columnFromBeg <: b)
$ b
instance BitmapCroppable BitmapString where
crop bmp (row, column) (width, height) =
(bmps_rowFromBeg $: (+ row))
. (bmps_rowFromEnd $: (+ (bitmapHeight bmp height row)))
. (bmps_columnFromBeg $: (+ column))
. (bmps_columnFromEnd $: (+ (bitmapWidth bmp width column)))
$ bmp