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