bitmaps-0.2.6.3: src/Data/Bitmap/StringRGB24A4VR/Internal.hs
{-# LANGUAGE TemplateHaskell, TypeFamilies, ExistentialQuantification, TypeOperators, ScopedTypeVariables, TupleSections #-}
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
-- | Container for a string that represents a sequence of raw pixels lacking the alpha component and that is stored upside down
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
-- | A bitmap represented as a string
--
-- This is essentially the format of pixels
-- in the BMP format in which each row is aligned to
-- a four-byte boundry and each row contains a series of
-- RGB pixels.
--
-- This type is most efficient for programs interacting heavily with BMP files.
data BitmapStringRGB24A4VR = BitmapStringRGB24A4VR
{ _bmps_dimensions :: (Int, Int) -- ^ Width and height of the bitmap
, _bmps_data :: BitmapImageString -- ^ Data stored in a string
}
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
-- | Return (rowSize, paddingSize) based on width, bytes per pixel, and alignment
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