module Data.Bitmap.StringRGB24A4VR.Internal
( BitmapImageString(..)
, BitmapStringRGB24A4VR(..), bmps_dimensions, bmps_data
, bytesPerRow
, bitmapStringBytesPerRow
, widthPadding
, encodeIBF_RGB24A4VR'
, tryIBF_RGB24A4VR'
, padByte
, imageSize
) where
import Control.Applicative
import Control.Arrow
import Control.Monad.Record hiding (get)
import Data.Binary
import Data.Bitmap.Class
import Data.Bitmap.Pixel
import Data.Bitmap.Reflectable
import Data.Bitmap.Searchable
import Data.Bitmap.Types
import Data.Bitmap.Util hiding (padByte)
import Data.Bits
import qualified Data.ByteString as B
import qualified Data.Serialize as S
import qualified Data.String.Class as S
import Data.Tagged
import Text.Printf
data BitmapImageString = forall s. (S.StringCells s) => BitmapImageString {_polyval_bitmapImageString :: s}
instance Eq BitmapImageString where
a == b = case (a, b) of
((BitmapImageString sa), (BitmapImageString sb)) -> S.toStrictByteString sa == S.toStrictByteString sb
a /= b = case (a, b) of
((BitmapImageString sa), (BitmapImageString sb)) -> S.toStrictByteString sa /= S.toStrictByteString sb
data BitmapStringRGB24A4VR = BitmapStringRGB24A4VR
{ _bmps_dimensions :: (Int, Int)
, _bmps_data :: BitmapImageString
}
mkLabels [''BitmapStringRGB24A4VR]
instance Binary BitmapStringRGB24A4VR where
get = pure BitmapStringRGB24A4VR <*> get <*> (BitmapImageString <$> (get :: Get B.ByteString))
put b = put (bmps_dimensions <: b) >> put (case bmps_data <: b of (BitmapImageString s) -> S.toLazyByteString s)
instance S.Serialize BitmapStringRGB24A4VR where
get = pure BitmapStringRGB24A4VR <*> S.get <*> (BitmapImageString <$> (S.get :: S.Get B.ByteString))
put b = S.put (bmps_dimensions <: b) >> S.put (case bmps_data <: b of (BitmapImageString s) -> S.toLazyByteString s)
instance Bitmap BitmapStringRGB24A4VR where
type BIndexType BitmapStringRGB24A4VR = Int
type BPixelType BitmapStringRGB24A4VR = PixelRGB
depth = const Depth24RGB
dimensions = (bmps_dimensions <:)
getPixel b (row, column) =
let bytesPixel = 3
bytesRow = fst $ bitmapStringBytesPerRow b
maxRow = abs . pred . snd . dimensions $ b
offset = bytesRow * (maxRow row) + bytesPixel * column
in case bmps_data <: b of
(BitmapImageString s) ->
PixelRGB $ ((fromIntegral . S.toWord8 $ s `S.index` (offset )) `shiftL` 16) .|.
((fromIntegral . S.toWord8 $ s `S.index` (offset + 1)) `shiftL` 8) .|.
((fromIntegral . S.toWord8 $ s `S.index` (offset + 2)))
constructPixels f dms@(width, height) = BitmapStringRGB24A4VR dms . (BitmapImageString :: B.ByteString -> BitmapImageString) $
S.unfoldrN (imageSize dms) getComponent (0 :: Int, 0 :: Int, 0 :: Int, 0 :: Int)
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 = f (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))
maxRow = abs . pred $ height
maxColumn = abs . pred $ width
paddingSize = snd $ bytesPerRow width 3 4
padCell = untag' . S.toMainChar $ padByte
untag' = untag :: Tagged B.ByteString a -> a
imageEncoders = updateIdentifiableElements (map (second unwrapGenericBitmapSerializer) defaultImageEncoders) $
[ (IBF_RGB24A4VR, ImageEncoder $ encodeIBF_RGB24A4VR')
]
imageDecoders = updateIdentifiableElements (map (second unwrapGenericBitmapSerializer) defaultImageDecoders) $
[ (IBF_RGB24A4VR, ImageDecoder $ tryIBF_RGB24A4VR')
]
encodeIBF_RGB24A4VR' :: (S.StringCells s) => BitmapStringRGB24A4VR -> s
encodeIBF_RGB24A4VR' b = case (bmps_data <: b) of (BitmapImageString s) -> S.fromStringCells s
tryIBF_RGB24A4VR' :: (S.StringCells s) => BitmapStringRGB24A4VR -> s -> Either String BitmapStringRGB24A4VR
tryIBF_RGB24A4VR' bmp s
| S.length s < minLength = Left $ printf "Data.Bitmap.StringRGB24A4VR.Internal.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 $
(bmps_data =: BitmapImageString s) bmp
where (width, height) = bmps_dimensions <: bmp
minLength = imageSize (bmps_dimensions <: bmp)
bitmapStringBytesPerRow :: BitmapStringRGB24A4VR -> (Int, Int)
bitmapStringBytesPerRow b = bytesPerRow (fst $ bmps_dimensions <: b) 3 4
widthPadding :: Int -> String
widthPadding w = replicate (snd $ bytesPerRow w 3 4) $ S.toChar padByte
bytesPerRow :: Int -> Int -> Int -> (Int, Int)
bytesPerRow width bytes_per_pixel alignment =
(rawRowSize + off', off')
where rawRowSize = bytes_per_pixel * width
off = rawRowSize `mod` alignment
off'
| off == 0 = 0
| otherwise = alignment off
padByte :: Word8
padByte = 0x00
imageSize :: Dimensions Int -> Int
imageSize (width, height) = (fst $ bytesPerRow width 3 4) * height
instance BitmapSearchable BitmapStringRGB24A4VR where
findSubBitmapEqual super sub = case (bmps_data <: super, bmps_data <: sub) of
((BitmapImageString dataSuper), (BitmapImageString dataSub)) ->
let (widthSuper, heightSuper) = bmps_dimensions <: super
(widthSub, heightSub) = bmps_dimensions <: sub
superBytesPerRow = fst $ bitmapStringBytesPerRow super
subBytesPerRow = fst $ bitmapStringBytesPerRow sub
maxSuperRow = heightSuper heightSub
maxSuperColumn = widthSuper widthSub
maxOffRow = abs . pred $ heightSub
offRowSize = subBytesPerRow (snd $ bitmapStringBytesPerRow sub)
r' (row, column)
| column > maxSuperColumn =
r' (succ row, 0)
| row > maxSuperRow =
Nothing
| matches 0 =
Just (maxSuperRow row, column)
| otherwise =
r' (row, succ column)
where superBaseIndex = row * superBytesPerRow + 3 * column
matches offRow
| offRow > maxOffRow
= True
| (S.toStringCells :: S.StringCells s => s -> B.ByteString) (subStr (superBaseIndex + offRow * superBytesPerRow) offRowSize dataSuper) /=
(S.toStringCells :: S.StringCells s => s -> B.ByteString) (subStr (offRow * subBytesPerRow) offRowSize dataSub)
= False
| otherwise
= matches (succ offRow)
in r'
instance BitmapReflectable BitmapStringRGB24A4VR