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