diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,28 @@ +Copyright (c) 2010, Byron James Johnson +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +3. Neither the name of the author nor the names of its contributors may be + used to endorse or promote products derived from this software without + specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/bitmaps.cabal b/bitmaps.cabal new file mode 100644 --- /dev/null +++ b/bitmaps.cabal @@ -0,0 +1,31 @@ +name: bitmaps +version: 0.2.5.1 +cabal-version: >= 1.10 +build-type: Simple +license: BSD3 +license-file: LICENSE +copyright: Copyright (C) 2010 Byron James Johnson +author: Byron James Johnson +maintainer: KrabbyKrap@gmail.com +synopsis: Bitmap library +description: Library defining several bitmap types, including ones stored as unboxed arrays, any string type, and functions + . + This library also supports conversion to and from bitmaps as defined in the "bitmap" package. + . + This library has not yet been tested extensively. + . + Note: This library is currently largely designed with RGB pixels with a color depth of 24 bits in mind. Better support for other pixel and color formats is intended to be implemented in the future. +category: Graphics, Codec, Data +tested-with: GHC == 7.0.1 + +library + default-language: Haskell2010 + hs-source-dirs: src + build-depends: base >= 4 && < 5, array, containers, binary, cereal, monad-state, zlib, bitmap, stb-image, string-class >= 0.1.4.0, tagged, bytestring + exposed-modules: Codec.String.Base16, Codec.String.Base64, Data.Bitmap.Array, Data.Bitmap.Array.Internal, Data.Bitmap.BMP, Data.Bitmap.Class, Data.Bitmap.Croppable, Data.Bitmap.Foreign, Data.Bitmap.Function, Data.Bitmap.Function.Internal, Data.Bitmap.Pixel, Data.Bitmap.Reflectable, Data.Bitmap.Searchable, Data.Bitmap.String, Data.Bitmap.String.Internal, Data.Bitmap.StringRGB24A4VR, Data.Bitmap.StringRGB24A4VR.Internal, Data.Bitmap.StringRGB32, Data.Bitmap.StringRGB32.Internal, Data.Bitmap.Types, Data.Bitmap.Util + ghc-options: -Wall -O2 + other-extensions: ScopedTypeVariables, TypeFamilies, GeneralizedNewtypeDeriving, PolymorphicComponents, TupleSections, FlexibleContexts, TemplateHaskell, DeriveDataTypeable, ExistentialQuantification, TypeOperators, FlexibleInstances, OverlappingInstances, UndecidableInstances + +source-repository head + type: darcs + location: http://patch-tag.com/r/bob/abitmap diff --git a/src/Codec/String/Base16.hs b/src/Codec/String/Base16.hs new file mode 100644 --- /dev/null +++ b/src/Codec/String/Base16.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +module Codec.String.Base16 + ( encodeHex + , decodeHex + ) where + +import Prelude hiding ((.), id, (++)) +import Control.Applicative hiding (empty) +import Control.Category +import Data.Maybe (listToMaybe) +import Data.Monoid (Monoid(mappend)) +import Data.String.Class as S +import Data.Tagged +import Data.Word +import Numeric + +encodeHex :: forall s. (StringCells s) => s -> s +encodeHex s + | (Just (a_, s')) <- safeUncons s + = case showHex (toWord8 a_) "" of + (a:b:[]) -> (untag' . toMainChar $ a) `cons` (untag' . toMainChar $ b) `cons` encodeHex s' + (a:_) -> (untag' . toMainChar $ '0') `cons` (untag' . toMainChar $ a) `cons` encodeHex s' + _ -> encodeHex s' + | otherwise + = empty + where untag' = untag :: Tagged s a -> a + +decodeHex :: forall s. (StringCells s) => s -> Maybe s +decodeHex s + | (Just (a, b, s')) <- safeUncons2 s + , (Just w) <- (maybeRead $ "0x" ++ [toChar $ a] ++ [toChar $ b] :: Maybe Word8) + = ((untag' . toMainChar $ w) `cons`) <$> decodeHex s' + | otherwise + = Just empty + where untag' = untag :: Tagged s a -> a + +(++) :: (Monoid a) => a -> a -> a +(++) = mappend +infixr 5 ++ + +maybeRead :: (S.StringCells s) => Read a => s -> Maybe a +maybeRead = (>>= \ ~(r, s') -> if S.null s' then Just r else Nothing) . listToMaybe . reads . S.toStringCells diff --git a/src/Codec/String/Base64.hs b/src/Codec/String/Base64.hs new file mode 100644 --- /dev/null +++ b/src/Codec/String/Base64.hs @@ -0,0 +1,104 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +module Codec.String.Base64 + ( bytes64 + , ibytes64 + , fillByte64 + , encode64 + , decode64 + ) where + +import Prelude hiding ((.), id, (++), length) +import Control.Applicative hiding (empty) +import Control.Category +import Data.Array.IArray +import Data.Bits +import qualified Data.Map as M +import Data.Monoid +import Data.String.Class +import Data.Tagged +import Data.Word + +bytes64 :: Array Word8 Word8 +bytes64 = listArray (0, 0x3F) $ + [0x41..0x5A] + ++ [0x61..0x7A] + ++ [0x30..0x39] + ++ [0x2B, 0x2F] + where (++) = mappend + +ibytes64 :: M.Map Word8 Word8 +ibytes64 = M.fromList $ map (\ ~(a_, b_) -> (b_, a_)) . assocs $ bytes64 + +fillByte64 :: Word8 +fillByte64 = 0x3D + +encode64 :: forall s. (StringCells s) => s -> s +encode64 s + | (Just (a, b, c, s')) <- safeUncons3 s = + let a' = toWord8 a + b' = toWord8 b + c' = toWord8 c + a'' = base $ a' `shiftR` 2 + b'' = base $ ((a' .&. 0x03) `shiftL` 4) .|. (b' `shiftR` 4) + c'' = base $ ((b' .&. 0x0F) `shiftL` 2) .|. (c' `shiftR` 6) + d'' = base $ c' .&. 0x3F + in cons4 a'' b'' c'' d'' $ encode64 s' + | 2 <- length s = + let ~(Just (a, b, _)) = safeUncons2 s + a' = toWord8 a + b' = toWord8 b + a'' = base $ a' `shiftR` 2 + b'' = base $ ((a' .&. 0x03) `shiftL` 4) .|. (b' `shiftR` 4) + c'' = base $ (b' .&. 0x0F) `shiftL` 2 + in cons4 a'' b'' c'' fillByte64' $ empty + | 1 <- length s = + let ~(Just (a, _)) = safeUncons s + a' = toWord8 a + a'' = base $ a' `shiftR` 2 + b'' = base $ (a' .&. 0x03) `shiftL` 4 + in cons4 a'' b'' fillByte64' fillByte64' $ empty + | otherwise = + empty + where base = untag' . toMainChar . (bytes64 !) . toWord8 + fillByte64' = untag' . toMainChar $ fillByte64 + untag' = untag :: Tagged s a -> a + +decode64 :: forall s. (StringCells s) => s -> Maybe s +decode64 s + | (Just (a, b, c, d, s')) <- safeUncons4 s = do + let n x + | (toWord8 x) == fillByte64 = Just 0xFF -- no regular base 64 digit can match with 0xFF; use this so we know whether a byte is a fill byte + | (Just y) <- M.lookup (toWord8 x) ibytes64 = Just y + | otherwise = Nothing + a' <- n a + b' <- n b + c' <- n c + d' <- n d + if c' /= 0xFF + then do + -- c is not a fill byte; check d + if d' /= 0xFF + then do + -- abcd + cons3 + (untag' . toMainChar $ (a' `shiftL` 2) .|. (b' `shiftR` 4)) + (untag' . toMainChar $ (b' `shiftL` 4) .|. (c' `shiftR` 2)) + (untag' . toMainChar $ (c' `shiftL` 6) .|. d') + <$> decode64 s' + else do + -- abc_ + Just . cons2 + (untag' . toMainChar $ (a' `shiftL` 2) .|. (b' `shiftR` 4)) + (untag' . toMainChar $ (b' `shiftL` 4) .|. (c' `shiftR` 2)) + $ empty + else do + do + do + -- ab__ + Just . cons + (untag' . toMainChar $ (a' `shiftL` 2) .|. (b' `shiftR` 4)) + $ empty + | otherwise = + Just empty + where untag' = untag :: Tagged s a -> a diff --git a/src/Data/Bitmap/Array.hs b/src/Data/Bitmap/Array.hs new file mode 100644 --- /dev/null +++ b/src/Data/Bitmap/Array.hs @@ -0,0 +1,21 @@ +-- | Bitmaps as unboxed arrays of 32-bit RGBA pixels +-- +-- These bitmaps are generally less efficient than 'BitmapString's, but can be arbitrarily +-- large (if having dimensions larger than the bound of 'Int' is really so useful), and have the advantages +-- of being stored in an array. + +module Data.Bitmap.Array + ( BitmapArray + , bitmapArrayToArray + , bitmapArrayToBitmapArray + ) where + +import Data.Array.Unboxed +import Data.Bitmap.Array.Internal +import Data.Word + +bitmapArrayToArray :: BitmapArray -> UArray (Integer, Integer) Word32 +bitmapArrayToArray = unwrapBitmapArray + +bitmapArrayToBitmapArray :: UArray (Integer, Integer) Word32 -> BitmapArray +bitmapArrayToBitmapArray = BitmapArray diff --git a/src/Data/Bitmap/Array/Internal.hs b/src/Data/Bitmap/Array/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/Bitmap/Array/Internal.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE TypeFamilies, GeneralizedNewtypeDeriving #-} + +module Data.Bitmap.Array.Internal + ( BitmapArray(..) + ) where + +import Data.Array.Unboxed +import Data.Binary +import Data.Bitmap.Class +import Data.Bitmap.Pixel +import Data.Bitmap.Types +import Data.Serialize + +-- | Arrays of 32-bit RGBA pixels +newtype BitmapArray = BitmapArray {unwrapBitmapArray :: UArray (Integer, Integer) Word32} + deriving (Eq, Ord, Binary, Serialize) + +-- | Instance for debugging purposes +instance Show BitmapArray where + --show = map (chr . fromIntegral) . elems . unwrapBitmap + show = show . unwrapBitmapArray + +instance Bitmap BitmapArray where + type BIndexType BitmapArray = Integer + type BPixelType BitmapArray = PixelRGBA + + depth = const Depth32RGBA + + dimensions (BitmapArray a) = + let (_, (maxRow, maxColumn)) = bounds a + in (abs . succ $ maxColumn, abs . succ $ maxRow) + + getPixel (BitmapArray a) = PixelRGBA . (a !) + + constructPixels f (width, height) = let maxRow = abs . pred $ height + maxColumn = abs . pred $ width + f' = unwrapPixelRGBA . toPixelRGBA . f + in BitmapArray . array ((0, 0), (maxRow, maxColumn)) $ [(i, f' i) | row <- [0..maxRow], column <- [0..maxColumn], let i = (row, column)] diff --git a/src/Data/Bitmap/BMP.hs b/src/Data/Bitmap/BMP.hs new file mode 100644 --- /dev/null +++ b/src/Data/Bitmap/BMP.hs @@ -0,0 +1,30 @@ +-- | Super module of bitmaps +-- +-- For functions that expect two bitmaps or otherwise two parameters based on +-- two bitmaps (such as dimensions) to be passed, this library's convention +-- is to accept the "super" bitmap or the larger / main bitmap first and the +-- "sub" bitmap second. + +module Data.Bitmap.BMP + ( module Data.Bitmap.Array + , module Data.Bitmap.Class + , module Data.Bitmap.Croppable + , module Data.Bitmap.Foreign + , module Data.Bitmap.Function + , module Data.Bitmap.Pixel + , module Data.Bitmap.Reflectable + , module Data.Bitmap.Searchable + , module Data.Bitmap.String + , module Data.Bitmap.Types + ) where + +import Data.Bitmap.Array +import Data.Bitmap.Class +import Data.Bitmap.Croppable +import Data.Bitmap.Foreign +import Data.Bitmap.Function +import Data.Bitmap.Pixel +import Data.Bitmap.Reflectable +import Data.Bitmap.Searchable +import Data.Bitmap.String +import Data.Bitmap.Types diff --git a/src/Data/Bitmap/Class.hs b/src/Data/Bitmap/Class.hs new file mode 100644 --- /dev/null +++ b/src/Data/Bitmap/Class.hs @@ -0,0 +1,1037 @@ +{-# LANGUAGE TypeFamilies, PolymorphicComponents, TupleSections, FlexibleContexts, ScopedTypeVariables #-} + +module Data.Bitmap.Class + ( Bitmap(..) + , convertBitmap + + -- * Polymorphic type wrappers + , CompleteEncoder(..) + , CompleteDecoder(..) + , ImageEncoder(..) + , ImageDecoder(..) + , GenericBitmapSerializer(..) + + -- * Bitmap serialization + , updateIdentifiableElements + , defaultCompleteEncoders + , encodeCBF_BMPIUZ64 + , encodeCBF_BMPIU64 + , encodeCBF_BMPIU + , encodeCBF_BMPIUU + , defaultCompleteDecoders + , tryCBF_BMPIUZ64 + , tryCBF_BMPIU64 + , tryCBF_BMPIU + , tryCBF_BMPIUU + , defaultImageEncoders + , encodeIBF_IDRGB24Z64 + , encodeIBF_IDBGR24R2RZ64 + , encodeIBF_IDBGR24HZH + , encodeIBF_IDRGB32Z64 + , encodeIBF_BGR24H + , encodeIBF_BGR24A4VR + , encodeIBF_BGRU32VR + , encodeIBF_BGRU32 + , encodeIBF_RGB24A4VR + , encodeIBF_RGB24A4 + , encodeIBF_RGB32 + , encodeIBF_RGB32Z64 + , defaultImageDecoders + , tryIBF_IDRGB24Z64 + , tryIBF_IDBGR24R2RZ64 + , tryIBF_IDBGR24HZH + , tryIBF_IDRGB32Z64 + , tryIBF_BGR24H + , tryIBF_BGR24A4VR + , tryIBF_BGRU32VR + , tryIBF_BGRU32 + , tryIBF_RGB24A4VR + , tryIBF_RGB24A4 + , tryIBF_RGB32 + , tryIBF_RGB32Z64 + , encodeComplete + , decodeComplete + , encodeImage + , decodeImage + , encodeCompleteFmt + , decodeCompleteFmt + , encodeImageFmt + , decodeImageFmt + , decodeImageDimensions + , decodeImageDimensionsFmt + + -- * Utility functions + , dimensionsFit + , bitmapWidth + , bitmapHeight + ) where + +import Codec.Compression.Zlib +import Codec.String.Base16 +import Codec.String.Base64 +import Control.Applicative +import Control.Arrow +import Control.Monad +import Control.Monad.Record +import Data.Binary +import Data.Binary.Get +import Data.Binary.Put +import Data.Bitmap.Pixel +import Data.Bitmap.Types +import Data.Bitmap.Util +import qualified Data.ByteString as B -- For zlib +import Data.Maybe +import qualified Data.String.Class as S +import Data.Tagged +import Text.Printf + +-- | Bitmap class +-- +-- Pixels are indexed by (row, column), where (0, 0) represents the +-- upper-left-most corner of the bitmap. Instances of this class +-- are not required to support empty bitmaps. +-- +-- The encoding and decoding lists contain functions that can encode +-- and decode or return a string containing information about why +-- it could not be decoded in that format. The order is important: +-- When a function tries multiple or any decoder, it will use or return +-- the one(s) closest to the head of the list. There are lists +-- of generic functions that are defined by default. Normally, if an +-- implementation of a bitmap type overrides the default instance, +-- it will only need to replace one or a few decoders, not touching +-- the rest of the default decoders or the order of the decoders; +-- thus the function 'updateIdentifiableElements' is defined and exported. +-- +-- Instances *must* support every serialization format. +class (Integral (BIndexType bmp), Pixel (BPixelType bmp)) => Bitmap bmp where + type BIndexType bmp -- @ Integral type for each coordinate in an index + type BPixelType bmp -- @ Pixel type of structure + + depth :: bmp -> Depth + -- ^ The color depth of the bitmap in bits + + dimensions :: bmp -> Dimensions (BIndexType bmp) + -- ^ Return the width and height of the bitmap in pixels + + getPixel :: bmp -> Coordinates (BIndexType bmp) -> BPixelType bmp + -- ^ Get a pixel; indexing starts at 0 + -- + -- Implementations can assume that the coordinates are within the + -- bounds of the bitmap. Thus callers of this function should always + -- ensure that the coordinates are within the bounds of the bitmap. + + constructPixels :: (Coordinates (BIndexType bmp) -> BPixelType bmp) -> Dimensions (BIndexType bmp) -> bmp + -- ^ Construct a bitmap with a function that returns a pixel for each coordinate with the given dimensions + -- + -- The function should return the same type of pixel for each coordinate. + -- + -- Implementations are not required to call the function in any particular order, and are not even + -- required to guarantee that the function will be called for each pixel, which might be true for + -- a bitmap that is evaluated lazily as needed. + + convertInternalFormat :: bmp -> bmp -> bmp + -- ^ Construct a new bitmap from the bitmap passed as the second argument but storing it in the bitmap of the meta-bitmap passed as the first argument + -- + -- The purpose of this function is efficiency. Some bitmap types have multiple possible internal representations of bitmaps. + -- For these bitmap types, it is often more efficient when performing operations on multiple bitmaps for them be stored in the + -- same format. Instances might even always convert the bitmaps if their formats differ. + -- + -- Implementations are not required to define this function + -- to store the second bitmap in another format, or even in the same + -- format as the first bitmap; this is only used for efficiency. They + -- should, however, return a bitmap that represents the same bitmap as + -- what the main bitmap (passed as the second argument) represents. + -- The default behaviour of this function is to return the main bitmap + -- (passed second) verbatim. + -- + -- As an example application of this function, consider a program that + -- regularly captures the screen and searches for any of several + -- bitmaps which are read from the filesystem. The programmer + -- chooses the type that is most efficient for the format that + -- the screen capture is in, and uses it as the main type. + -- As the screen is expected to change, it would be inefficient + -- to convert each capture into another internal format each time, + -- especially since screen dumps can be very large. The bitmaps, however, + -- are generally static (and much smaller), so they could be converted + -- once using this function, 'convertInternalFormat', to the format that + -- screen captures are represented in, and reused. If the formats would + -- otherwise differ, this is much more efficient than converting the format + -- of every sub-bitmap every time a search or operation is needed. + -- + -- NB: again, the format of the first argument is used along with + -- the image of the second argument to return (possibly) a bitmap + -- with the image of the second argument and with the format of the + -- first argument. + + completeEncoders :: [(CompleteBitmapFormat, CompleteEncoder bmp)] + -- ^ Bitmap encoders; default definition is based on 'defaultCompleteEncoders' + -- + -- As the head of the list might be best suited for writing to files + -- or generating text strings but not both, it is suggested that this + -- function is used only when it does not matter whether the result + -- is writable to a file or is generally "human readable". + completeDecoders :: [(CompleteBitmapFormat, CompleteDecoder bmp)] + -- ^ Bitmap decodes; extra bytes after the end should be ignored by them; default definition is based on 'defaultCompleteDecoders' + imageEncoders :: [(ImageBitmapFormat, ImageEncoder bmp)] + -- ^ Bitmap encoders; the meta-information is lost; default definition is based on 'defaultImageEncoders' + imageDecoders :: [(ImageBitmapFormat, ImageDecoder bmp)] + -- ^ Decode the bitmap; the meta-information from the given bitmap is used (see 'ImageDecoder'); default definition is based on 'defaultImageDecoders' + + convertInternalFormat = const + + completeEncoders = map (second unwrapGenericBitmapSerializer) defaultCompleteEncoders + completeDecoders = map (second unwrapGenericBitmapSerializer) defaultCompleteDecoders + imageEncoders = map (second unwrapGenericBitmapSerializer) defaultImageEncoders + imageDecoders = map (second unwrapGenericBitmapSerializer) defaultImageDecoders + +-- | Convert one bitmap type to another +convertBitmap :: (Bitmap a, Bitmap b) => a -> b +convertBitmap b = constructPixels (\(row, column) -> fromPixel $ getPixel b (fromIntegral row, fromIntegral column)) (let (width, height) = dimensions b in (fromIntegral width, fromIntegral height)) + +newtype CompleteEncoder bmp = CompleteEncoder {unwrapCompleteEncoder :: (S.StringCells s) => bmp -> s} +newtype CompleteDecoder bmp = CompleteDecoder {unwrapCompleteDecoder :: (S.StringCells s) => s -> Either String bmp} +newtype ImageEncoder bmp = ImageEncoder {unwrapImageEncoder :: (S.StringCells s) => bmp -> s} +newtype ImageDecoder bmp = ImageDecoder {unwrapImageDecoder :: (S.StringCells s) => bmp -> s -> Either String bmp} + +newtype GenericBitmapSerializer s = GenericBitmapSerializer {unwrapGenericBitmapSerializer :: (Bitmap bmp) => s bmp} + +-- | Update identifiable elements +-- +-- 'updateIdentifiableElements' @orig new@ returns @orig@ with each matching +-- pair updated; extraneous replacements in @new@ are ignored. +updateIdentifiableElements :: (Eq k) => [(k, v)] -> [(k, v)] -> [(k, v)] +updateIdentifiableElements orig new = map (\(k, v) -> (k, maybe v id $ lookup k new)) orig + +defaultCompleteEncoders :: [(CompleteBitmapFormat, GenericBitmapSerializer CompleteEncoder)] +defaultCompleteEncoders = + [ (CBF_BMPIUZ64, GenericBitmapSerializer $ CompleteEncoder $ encodeCBF_BMPIUZ64) + , (CBF_BMPIU64, GenericBitmapSerializer $ CompleteEncoder $ encodeCBF_BMPIU64) + , (CBF_BMPIU, GenericBitmapSerializer $ CompleteEncoder $ encodeCBF_BMPIU) + , (CBF_BMPIUU, GenericBitmapSerializer $ CompleteEncoder $ encodeCBF_BMPIUU) + ] + +encodeCBF_BMPIU :: (S.StringCells s, Bitmap bmp) => bmp -> s +encodeCBF_BMPIU b = + let (width, height) = dimensions b + header = S.fromLazyByteString . runPut $ do + -- Magic sequence + putWord8 (0x42 :: Word8) + putWord8 (0x4D :: Word8) + + -- File size + putWord32le (fromIntegral $ 3 * width * height + padding * height + 0x0E + 40 :: Word32) + + -- Reserved + putWord16le 0x0000 + putWord16le 0x0000 + + -- Offset + putWord32le (0x0E + 40 :: Word32) + + -- Bitmap information header; BITMAPINFOHEADER + -- header size + putWord32le (40 :: Word32) + -- width + putWord32le (fromIntegral width :: Word32) + -- height + putWord32le (fromIntegral height :: Word32) + -- number of color planes + putWord16le (1 :: Word16) + -- bits per pixel / depth + putWord16le (24 :: Word16) + -- compression + putWord32le (0 :: Word32) -- no compression + -- image size + putWord32le (fromIntegral $ 3 * width * height + padding * height :: Word32) + -- horizontal resolution; pixel per meter + putWord32le (3000 :: Word32) + -- vertical resolution; pixel per meter + putWord32le (3000 :: Word32) + -- number of colors + putWord32le (0 :: Word32) + -- number of important colors + putWord32le (0 :: Word32) + image = encodeImageFmt IBF_BGR24A4VR b + padding = case 4 - ((3 * width) `mod` 4) of + 4 -> 0 + n -> n + in header `S.append` image + +encodeCBF_BMPIUU :: (S.StringCells s, Bitmap bmp) => bmp -> s +encodeCBF_BMPIUU b = + let (width, height) = dimensions b + header = S.fromLazyByteString . runPut $ do + -- Magic sequence + putWord8 (0x42 :: Word8) + putWord8 (0x4D :: Word8) + + -- File size + putWord32le (fromIntegral $ 4 * width * height + 0x0E + 40 :: Word32) + + -- Reserved + putWord16le 0x0000 + putWord16le 0x0000 + + -- Offset + putWord32le (0x0E + 40 :: Word32) + + -- Bitmap information header; BITMAPINFOHEADER + -- header size + putWord32le (40 :: Word32) + -- width + putWord32le (fromIntegral width :: Word32) + -- height + putWord32le (fromIntegral height :: Word32) + -- number of color planes + putWord16le (1 :: Word16) + -- bits per pixel / depth + putWord16le (32 :: Word16) + -- compression + putWord32le (0 :: Word32) -- no compression + -- image size + putWord32le (fromIntegral $ 4 * width * height :: Word32) + -- horizontal resolution; pixel per meter + putWord32le (3000 :: Word32) + -- vertical resolution; pixel per meter + putWord32le (3000 :: Word32) + -- number of colors + putWord32le (0 :: Word32) + -- number of important colors + putWord32le (0 :: Word32) + image = encodeImageFmt IBF_BGRU32VR b + in header `S.append` image + +encodeCBF_BMPIU64 :: (S.StringCells s, Bitmap bmp) => bmp -> s +encodeCBF_BMPIU64 = encode64 . encodeCompleteFmt CBF_BMPIU + +encodeCBF_BMPIUZ64 :: (S.StringCells s, Bitmap bmp) => bmp -> s +encodeCBF_BMPIUZ64 = encode64 . S.fromStringCells . compress . encodeCompleteFmt CBF_BMPIU + +defaultCompleteDecoders :: [(CompleteBitmapFormat, GenericBitmapSerializer CompleteDecoder)] +defaultCompleteDecoders = + [ (CBF_BMPIUZ64, GenericBitmapSerializer $ CompleteDecoder $ tryCBF_BMPIUZ64) + , (CBF_BMPIU64, GenericBitmapSerializer $ CompleteDecoder $ tryCBF_BMPIU64) + , (CBF_BMPIU, GenericBitmapSerializer $ CompleteDecoder $ tryCBF_BMPIU) + , (CBF_BMPIUU, GenericBitmapSerializer $ CompleteDecoder $ tryCBF_BMPIUU) + ] + +tryCBF_BMPIU :: (S.StringCells s, Bitmap bmp) => s -> Either String bmp +tryCBF_BMPIU s = do + let getImgInfo = do + m0 <- getWord8 + m1 <- getWord8 + + when (m0 /= 0x42 || m1 /= 0x4D) $ do + fail "magic sequence is not that of BMP format" + + -- skip filesize 4, reserved 2, reserved, 2 + skip 8 + + offset <- getWord32le + + -- get offset to image data + let offset' = offset - 0x0E - 40 + + when (offset' < 0) $ do + fail $ printf "rewinding to image data at offset %d not supported" offset + + -- read DIB header + headerSize <- getWord32le + when (headerSize /= 40) $ do + fail $ printf "header with size '%d' which is other than 40 is not supported" headerSize + + width <- getWord32le + height <- getWord32le + numColorPlanes <- getWord16le + when (numColorPlanes /= 1) $ do + fail $ printf "numColorPlanes with value '%d' which is other than 1 is not supported" numColorPlanes + bitsPerPixel <- getWord16le + when (bitsPerPixel /= 24) $ do + fail $ printf "bitsPerPixel with value '%d' which is other than 24 is not supported" bitsPerPixel + compression <- getWord32le + when (compression /= 0) $ do + fail $ printf "compression with value '%d' which is other than 0 is not supported; needs to be uncompressed RGB" compression + imageSize <- getWord32le + let shouldBeImageSize = (3 * width + padding) * height + padding = case (3 * width) `mod` 4 of + 0 -> 0 + n -> 4 - n + when (imageSize /= shouldBeImageSize) $ do + fail $ printf "imageSize was read to be '%d', but it should be '%d' since the dimensions of the bitmap are (%d, %d)" imageSize shouldBeImageSize width height + -- skip horRes 4, verRes 4, usedColors 4, importantColors 4 + skip 16 + + -- skip to image data + when (offset' > 0) $ do + skip $ fromIntegral offset' + + -- get image data + imgData <- getLazyByteString (fromIntegral imageSize) + + return (width, height, imgData) + + (width, height, imgData) <- tablespoon . flip runGet (S.toLazyByteString s) $ getImgInfo + let metaBitmap = constructPixels (const leastIntensity) (fromIntegral width, fromIntegral height) + decodeImageFmt IBF_BGR24A4VR metaBitmap $ imgData + +tryCBF_BMPIUU :: (S.StringCells s, Bitmap bmp) => s -> Either String bmp +tryCBF_BMPIUU s = do + let getImgInfo = do + m0 <- getWord8 + m1 <- getWord8 + + when (m0 /= 0x42 || m1 /= 0x4D) $ do + fail "magic sequence is not that of BMP format" + + -- skip filesize 4, reserved 2, reserved, 2 + skip 8 + + offset <- getWord32le + + -- get offset to image data + let offset' = offset - 0x0E - 40 + + when (offset' < 0) $ do + fail $ printf "rewinding to image data at offset %d not supported" offset + + -- read DIB header + headerSize <- getWord32le + when (headerSize /= 40) $ do + fail $ printf "header with size '%d' which is other than 40 is not supported" headerSize + + width <- getWord32le + height <- getWord32le + numColorPlanes <- getWord16le + when (numColorPlanes /= 1) $ do + fail $ printf "numColorPlanes with value '%d' which is other than 1 is not supported" numColorPlanes + bitsPerPixel <- getWord16le + when (bitsPerPixel /= 32) $ do + fail $ printf "bitsPerPixel with value '%d' which is other than 32 is not supported" bitsPerPixel + compression <- getWord32le + when (compression /= 0) $ do + fail $ printf "compression with value '%d' which is other than 0 is not supported; needs to be uncompressed RGB" compression + imageSize <- getWord32le + let shouldBeImageSize = 4 * width * height + when (imageSize /= shouldBeImageSize) $ do + fail $ printf "imageSize was read to be '%d', but it should be '%d' since the dimensions of the bitmap are (%d, %d)" imageSize shouldBeImageSize width height + -- skip horRes 4, verRes 4, usedColors 4, importantColors 4 + skip 16 + + -- skip to image data + when (offset' > 0) $ do + skip $ fromIntegral offset' + + -- get image data + imgData <- getLazyByteString (fromIntegral imageSize) + + return (width, height, imgData) + + (width, height, imgData) <- tablespoon . flip runGet (S.toLazyByteString s) $ getImgInfo + let metaBitmap = constructPixels (const leastIntensity) (fromIntegral width, fromIntegral height) + decodeImageFmt IBF_BGRU32VR metaBitmap $ imgData + +tryCBF_BMPIU64 :: (S.StringCells s, Bitmap bmp) => s -> Either String bmp +tryCBF_BMPIU64 s = decodeCompleteFmt CBF_BMPIU =<< (maybe (Left "Data.Bitmap.Class.tryCBF_BMPIU64: not a valid sequence of characters representing a base-64 encoded string") Right $ decode64 s) + +tryCBF_BMPIUZ64 :: (S.StringCells s, Bitmap bmp) => s -> Either String bmp +tryCBF_BMPIUZ64 s = decodeCompleteFmt CBF_BMPIU =<< tablespoon . decompress . S.toStringCells =<< (maybe (Left "Data.Bitmap.Class.tryCBF_BMPIUZ64: not a valid sequence of characters representing a base-64 encoded string") Right $ decode64 s) + +defaultImageEncoders :: [(ImageBitmapFormat, GenericBitmapSerializer ImageEncoder)] +defaultImageEncoders = + [ (IBF_IDRGB32Z64, GenericBitmapSerializer $ ImageEncoder $ encodeIBF_IDRGB32Z64) + , (IBF_IDRGB24Z64, GenericBitmapSerializer $ ImageEncoder $ encodeIBF_IDRGB24Z64) + , (IBF_IDBGR24R2RZ64, GenericBitmapSerializer $ ImageEncoder $ encodeIBF_IDBGR24R2RZ64) + , (IBF_IDBGR24HZH, GenericBitmapSerializer $ ImageEncoder $ encodeIBF_IDBGR24HZH) + , (IBF_BGR24H, GenericBitmapSerializer $ ImageEncoder $ encodeIBF_BGR24H) + , (IBF_BGR24A4VR, GenericBitmapSerializer $ ImageEncoder $ encodeIBF_BGR24A4VR) + , (IBF_BGRU32VR, GenericBitmapSerializer $ ImageEncoder $ encodeIBF_BGRU32VR) + , (IBF_BGRU32, GenericBitmapSerializer $ ImageEncoder $ encodeIBF_BGRU32) + , (IBF_RGB24A4VR, GenericBitmapSerializer $ ImageEncoder $ encodeIBF_RGB24A4VR) + , (IBF_RGB24A4, GenericBitmapSerializer $ ImageEncoder $ encodeIBF_RGB24A4) + , (IBF_RGB32, GenericBitmapSerializer $ ImageEncoder $ encodeIBF_RGB32) + , (IBF_RGB32Z64, GenericBitmapSerializer $ ImageEncoder $ encodeIBF_RGB32Z64) + ] + +encodeIBF_IDRGB24Z64 :: forall s bmp. (S.StringCells s, Bitmap bmp) => bmp -> s +encodeIBF_IDRGB24Z64 b = ((untag' . S.toMainChar $ 'm') `S.cons`) . encode64 . S.fromStringCells . compress + $ S.unfoldrN (fromIntegral $ 3 * width * height) getComponent (0, 0, 0 :: Int) + where getComponent (row, column, orgb) + | orgb > 2 = + getComponent (row, succ column, 0) + | column > maxColumn = + getComponent (succ row, 0, 0) + | row > maxRow = + Nothing + | otherwise = + let pixel = pixelf (row, column) + componentGetter = + case orgb of + 0 -> untagBS . S.toMainChar . (red <:) + 1 -> untagBS . S.toMainChar . (green <:) + 2 -> untagBS . S.toMainChar . (blue <:) + _ -> undefined + in Just (componentGetter pixel, (row, column, succ orgb)) + pixelf = (b `getPixel`) + (width_, height_) = dimensions b + (width, height) = (fromIntegral width_, fromIntegral height_) + maxRow = abs . pred $ height + maxColumn = abs . pred $ width + untag' = untag :: Tagged s a -> a + untagBS = untag :: Tagged B.ByteString a -> a + +encodeIBF_IDBGR24R2RZ64 :: forall s bmp. (S.StringCells s, Bitmap bmp) => bmp -> s +encodeIBF_IDBGR24R2RZ64 b = ((untag' . S.toMainChar $ 'b') `S.cons`) . encode64 . S.fromStringCells . compress + $ S.unfoldrN (fromIntegral $ 3 * width * height) getComponent (0, 0, 0 :: Int) + where getComponent (row, column, orgb) + | orgb > 2 = + getComponent (row, succ column, 0) + | column > maxColumn = + getComponent (succ row, 0, 0) + | row > maxRow = + Nothing + | otherwise = + let pixel = pixelf (row, column) + componentGetter = + case orgb of + 2 -> untagBS . S.toMainChar . (red <:) + 1 -> untagBS . S.toMainChar . (green <:) + 0 -> untagBS . S.toMainChar . (blue <:) + _ -> undefined + in Just (componentGetter pixel, (row, column, succ orgb)) + pixelf = (b `getPixel`) + (width_, height_) = dimensions b + (width, height) = (fromIntegral width_, fromIntegral height_) + maxRow = abs . pred $ height + maxColumn = abs . pred $ width + untag' = untag :: Tagged s a -> a + untagBS = untag :: Tagged B.ByteString a -> a + +encodeIBF_IDBGR24HZH :: forall s bmp. (S.StringCells s, Bitmap bmp) => bmp -> s +encodeIBF_IDBGR24HZH = ((untag' . S.toMainChar $ 'z') `S.cons`) . encodeHex . S.fromStringCells . compress . encodeImageFmt IBF_BGR24H + where untag' = untag :: Tagged s a -> a + +encodeIBF_IDRGB32Z64 :: forall s bmp. (S.StringCells s, Bitmap bmp) => bmp -> s +encodeIBF_IDRGB32Z64 = ((untag' . S.toMainChar $ 'l') `S.cons`) . encodeImageFmt IBF_RGB32Z64 + where untag' = untag :: Tagged s a -> a + +encodeIBF_BGR24H :: forall s bmp. (S.StringCells s, Bitmap bmp) => bmp -> s +encodeIBF_BGR24H b = + encodeHex $ S.unfoldrN (fromIntegral $ 4 * width * height) getComponent (0, 0, 0 :: Int) + where getComponent (row, column, orgb) + | orgb > 2 = + getComponent (row, succ column, 0) + | column > maxColumn = + getComponent (succ row, 0, 0) + | row > maxRow = + Nothing + | otherwise = + let pixel = pixelf (row, column) + componentGetter = + case orgb of + 2 -> untag' . S.toMainChar . (red <:) + 1 -> untag' . S.toMainChar . (green <:) + 0 -> untag' . S.toMainChar . (blue <:) + _ -> undefined + in Just (componentGetter pixel, (row, column, succ orgb)) + pixelf = (b `getPixel`) + (width_, height_) = dimensions b + (width, height) = (fromIntegral width_, fromIntegral height_) + maxRow = abs . pred $ height + maxColumn = abs . pred $ width + untag' = untag :: Tagged s a -> a + +encodeIBF_RGB24A4 :: forall s bmp. (S.StringCells s, Bitmap bmp) => bmp -> s +encodeIBF_RGB24A4 b = + S.unfoldrN (fromIntegral $ (3 * width + paddingSize) * height) getComponent (0, 0, 0 :: Int, 0) + 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 = pixelf (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)) + pixelf = (b `getPixel`) + (width_, height_) = dimensions b + (width, height) = (fromIntegral width_, fromIntegral height_) + maxRow = abs . pred $ height + maxColumn = abs . pred $ width + paddingSize = case 4 - ((3 * width) `mod` 4) of + 4 -> 0 + n -> n + padCell = untag' . S.toMainChar $ padByte + untag' = untag :: Tagged s a -> a + +encodeIBF_BGR24A4VR :: forall s bmp. (S.StringCells s, Bitmap bmp) => bmp -> s +encodeIBF_BGR24A4VR b = + S.unfoldrN (fromIntegral $ (3 * width + paddingSize) * height) getComponent (0, 0, 0 :: Int, 0) + 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 = pixelf (maxRow - row, column) + componentGetter = + case orgb of + 2 -> untag' . S.toMainChar . (red <:) + 1 -> untag' . S.toMainChar . (green <:) + 0 -> untag' . S.toMainChar . (blue <:) + _ -> undefined + in Just (componentGetter pixel, (row, column, succ orgb, 0)) + pixelf = (b `getPixel`) + (width_, height_) = dimensions b + (width, height) = (fromIntegral width_, fromIntegral height_) + maxRow = abs . pred $ height + maxColumn = abs . pred $ width + paddingSize = case 4 - ((3 * width) `mod` 4) of + 4 -> 0 + n -> n + padCell = untag' . S.toMainChar $ padByte + untag' = untag :: Tagged s a -> a + +encodeIBF_BGRU32VR :: forall s bmp. (S.StringCells s, Bitmap bmp) => bmp -> s +encodeIBF_BGRU32VR b = + S.unfoldrN (fromIntegral $ 4 * width * height) getComponent (0, 0, 0 :: Int) + where getComponent (row, column, orgb) + | orgb > 3 = + getComponent (row, succ column, 0) + | column > maxColumn = + getComponent (succ row, 0, 0) + | row > maxRow = + Nothing + | otherwise = + let pixel = pixelf (maxRow - row, column) + componentGetter = + case orgb of + 3 -> const padCell + 2 -> untag' . S.toMainChar . (red <:) + 1 -> untag' . S.toMainChar . (green <:) + 0 -> untag' . S.toMainChar . (blue <:) + _ -> undefined + in Just (componentGetter pixel, (row, column, succ orgb)) + pixelf = (b `getPixel`) + (width_, height_) = dimensions b + (width, height) = (fromIntegral width_, fromIntegral height_) + maxRow = abs . pred $ height + maxColumn = abs . pred $ width + padCell = untag' . S.toMainChar $ padByte + untag' = untag :: Tagged s a -> a + +encodeIBF_BGRU32 :: forall s bmp. (S.StringCells s, Bitmap bmp) => bmp -> s +encodeIBF_BGRU32 b = + S.unfoldrN (fromIntegral $ 4 * width * height) getComponent (0, 0, 0 :: Int) + where getComponent (row, column, orgb) + | orgb > 3 = + getComponent (row, succ column, 0) + | column > maxColumn = + getComponent (succ row, 0, 0) + | row > maxRow = + Nothing + | otherwise = + let pixel = pixelf (row, column) + componentGetter = + case orgb of + 3 -> const padCell + 2 -> untag' . S.toMainChar . (red <:) + 1 -> untag' . S.toMainChar . (green <:) + 0 -> untag' . S.toMainChar . (blue <:) + _ -> undefined + in Just (componentGetter pixel, (row, column, succ orgb)) + pixelf = (b `getPixel`) + (width_, height_) = dimensions b + (width, height) = (fromIntegral width_, fromIntegral height_) + maxRow = abs . pred $ height + maxColumn = abs . pred $ width + padCell = untag' . S.toMainChar $ padByte + untag' = untag :: Tagged s a -> a + +encodeIBF_RGB24A4VR :: forall s bmp. (S.StringCells s, Bitmap bmp) => bmp -> s +encodeIBF_RGB24A4VR b = + S.unfoldrN (fromIntegral $ (3 * width + paddingSize) * height) getComponent (0, 0, 0 :: Int, 0) + 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 = pixelf (maxRow - 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)) + pixelf = (b `getPixel`) + (width_, height_) = dimensions b + (width, height) = (fromIntegral width_, fromIntegral height_) + maxRow = abs . pred $ height + maxColumn = abs . pred $ width + paddingSize = case 4 - ((3 * width) `mod` 4) of + 4 -> 0 + n -> n + padCell = untag' . S.toMainChar $ padByte + untag' = untag :: Tagged s a -> a + +encodeIBF_RGB32 :: forall s bmp. (S.StringCells s, Bitmap bmp) => bmp -> s +encodeIBF_RGB32 b = + S.unfoldrN (fromIntegral $ 4 * width * height) getComponent (0, 0, 0 :: Int) + where getComponent (row, column, orgb) + | orgb > 3 = + getComponent (row, succ column, 0) + | column > maxColumn = + getComponent (succ row, 0, 0) + | row > maxRow = + Nothing + | otherwise = + let pixel = pixelf (row, column) + componentGetter = + case orgb of + 0 -> const padCell + 1 -> untag' . S.toMainChar . (red <:) + 2 -> untag' . S.toMainChar . (green <:) + 3 -> untag' . S.toMainChar . (blue <:) + _ -> undefined + in Just (componentGetter pixel, (row, column, succ orgb)) + pixelf = (b `getPixel`) + (width_, height_) = dimensions b + (width, height) = (fromIntegral width_, fromIntegral height_) + maxRow = abs . pred $ height + maxColumn = abs . pred $ width + padCell = untag' . S.toMainChar $ padByte + untag' = untag :: Tagged s a -> a + +encodeIBF_RGB32Z64 :: forall s bmp. (S.StringCells s, Bitmap bmp) => bmp -> s +encodeIBF_RGB32Z64 = encode64 . S.fromStringCells . compress . encodeImageFmt IBF_RGB32 + +defaultImageDecoders :: [(ImageBitmapFormat, GenericBitmapSerializer ImageDecoder)] +defaultImageDecoders = + [ (IBF_IDRGB32Z64, GenericBitmapSerializer $ ImageDecoder $ tryIBF_IDRGB32Z64) + , (IBF_IDRGB24Z64, GenericBitmapSerializer $ ImageDecoder $ tryIBF_IDRGB24Z64) + , (IBF_IDBGR24R2RZ64, GenericBitmapSerializer $ ImageDecoder $ tryIBF_IDBGR24R2RZ64) + , (IBF_IDBGR24HZH, GenericBitmapSerializer $ ImageDecoder $ tryIBF_IDBGR24HZH) + , (IBF_BGR24H, GenericBitmapSerializer $ ImageDecoder $ tryIBF_BGR24H) + , (IBF_BGR24A4VR, GenericBitmapSerializer $ ImageDecoder $ tryIBF_BGR24A4VR) + , (IBF_BGRU32VR, GenericBitmapSerializer $ ImageDecoder $ tryIBF_BGRU32VR) + , (IBF_BGRU32, GenericBitmapSerializer $ ImageDecoder $ tryIBF_BGRU32) + , (IBF_RGB24A4VR, GenericBitmapSerializer $ ImageDecoder $ tryIBF_RGB24A4VR) + , (IBF_RGB24A4, GenericBitmapSerializer $ ImageDecoder $ tryIBF_RGB24A4) + , (IBF_RGB32, GenericBitmapSerializer $ ImageDecoder $ tryIBF_RGB32) + , (IBF_RGB32Z64, GenericBitmapSerializer $ ImageDecoder $ tryIBF_RGB32Z64) + ] + +tryIBF_IDRGB24Z64 :: forall s bmp. (S.StringCells s, Bitmap bmp) => bmp -> s -> Either String bmp +tryIBF_IDRGB24Z64 metaBitmap s_ + | (Just ('m', s')) <- (first S.toChar) <$> S.safeUncons s_ + = tryIBF_IDRGB24Z64' =<< tablespoon . decompress . S.toStringCells =<< (maybe (Left "Data.Bitmap.Class.tryIBF_IDRGB24Z64: not a valid sequence of characters representing a base-64 encoded string") Right $ decode64 s') + | otherwise + = Left "Data.Bitmap.Class.tryIBF_IDRGB24Z64: string does not begin with identifying 'b' character" + where tryIBF_IDRGB24Z64' :: (S.StringCells s2) => s2 -> Either String bmp + tryIBF_IDRGB24Z64' s + | S.length s < minLength = Left $ printf "Data.Bitmap.Class.tryIBF_IDRGB24Z64: 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 $ + constructPixels pixelf dms + where (width, height) = dimensions metaBitmap + dms = (fromIntegral width, fromIntegral height) + bytesPerPixel = 3 + bytesPerRow = bytesPerPixel * width + minLength = fromIntegral $ bytesPerRow * height + pixelf (row, column) = let offset = fromIntegral $ bytesPerRow * (fromIntegral row) + bytesPerPixel * (fromIntegral column) + in (red =: (S.toWord8 $ s `S.index` (offset + 0))) + . (green =: (S.toWord8 $ s `S.index` (offset + 1))) + . (blue =: (S.toWord8 $ s `S.index` (offset + 2))) + $ leastIntensity + +tryIBF_IDBGR24R2RZ64 :: forall s bmp. (S.StringCells s, Bitmap bmp) => bmp -> s -> Either String bmp +tryIBF_IDBGR24R2RZ64 metaBitmap s_ + | (Just ('b', s')) <- (first S.toChar) <$> S.safeUncons s_ + = tryIBF_IDBGR24R2RZ64' =<< tablespoon . decompress . S.toStringCells =<< (maybe (Left "Data.Bitmap.Class.tryIBF_IDBGR24R2RZ64: not a valid sequence of characters representing a base-64 encoded string") Right $ decode64 s') + | otherwise + = Left "Data.Bitmap.Class.tryIBF_IDBGR24R2RZ64: string does not begin with identifying 'b' character" + where tryIBF_IDBGR24R2RZ64' :: (S.StringCells s2) => s2 -> Either String bmp + tryIBF_IDBGR24R2RZ64' s + | S.length s < minLength = Left $ printf "Data.Bitmap.Class.tryIBF_IDBGR24R2RZ64: 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 $ + constructPixels pixelf dms + where (width, height) = dimensions metaBitmap + dms = (fromIntegral width, fromIntegral height) + maxRow = abs . pred $ height + maxColumn = abs . pred $ width + bytesPerPixel = 3 + bytesPerRow = bytesPerPixel * width + minLength = fromIntegral $ bytesPerRow * height + pixelf (row, column) + | (row, column) == (maxRow, maxColumn) + = (red =: (S.toWord8 $ s `S.index` 1)) + . (green =: (S.toWord8 $ s `S.index` 0)) + . (blue =: (S.toWord8 . S.last $ s)) + $ leastIntensity + | otherwise + = let offset = fromIntegral $ bytesPerRow * (fromIntegral row) + bytesPerPixel * (fromIntegral column) + 2 + in (red =: (S.toWord8 $ s `S.index` (offset + 2))) + . (green =: (S.toWord8 $ s `S.index` (offset + 1))) + . (blue =: (S.toWord8 $ s `S.index` (offset + 0))) + $ leastIntensity + +tryIBF_IDBGR24HZH :: forall s bmp. (S.StringCells s, Bitmap bmp) => bmp -> s -> Either String bmp +tryIBF_IDBGR24HZH metaBitmap s_ + | (Just ('z', s')) <- (first S.toChar) <$> S.safeUncons s_ + = decodeImageFmt IBF_BGR24H metaBitmap =<< tablespoon . decompress . S.toStringCells =<< (maybe (Left "Data.Bitmap.Class.tryIBF_IDBGR24HZH: not a valid sequence of characters representing a base-16 encoded string") Right $ decodeHex s') + | otherwise + = Left "Data.Bitmap.Class.tryIBF_IDBGR24HZH: string does not begin with identifying 'z' character" + +tryIBF_IDRGB32Z64 :: forall s bmp. (S.StringCells s, Bitmap bmp) => bmp -> s -> Either String bmp +tryIBF_IDRGB32Z64 metaBitmap s_ + | (Just ('l', s')) <- (first S.toChar) <$> S.safeUncons s_ + = decodeImageFmt IBF_RGB32Z64 metaBitmap s' + | otherwise + = Left "Data.Bitmap.Class.tryIBF_IDRGB32Z64: string does not begin with identifying 'l' character" + +tryIBF_BGR24H :: forall s bmp. (S.StringCells s, Bitmap bmp) => bmp -> s -> Either String bmp +tryIBF_BGR24H metaBitmap s_ + | S.length s_ < minLength = Left $ printf "Data.Bitmap.Class.tryIBF_BGR24H: 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 = tryIBF_BGR24H' =<< (maybe (Left "Data.Bitmap.Class.tryIBF_BGR24H: not a valid sequence of characters representing a base-16 encoded string") Right $ decodeHex s_) + where tryIBF_BGR24H' :: (S.StringCells s2) => s2 -> Either String bmp + tryIBF_BGR24H' s + | S.length s < minLengthDecoded = Left $ printf "Data.Bitmap.Class.tryIBF_BGR24H: the size of the encoded string, %d, is correct because it is at least %d, but after it was hex decoded, its size was incorrect; it was %d and it should have been at least %d; most likely there is a non-hex character too early in the string" (S.length s_) minLength (S.length s) minLengthDecoded + | otherwise = Right $ constructPixels pixelf dms + where pixelf (row, column) = let offset = fromIntegral $ bytesPerRow * (fromIntegral row) + bytesPerPixel * (fromIntegral column) + in (red =: (S.toWord8 $ s `S.index` (offset + 2))) + . (green =: (S.toWord8 $ s `S.index` (offset + 1))) + . (blue =: (S.toWord8 $ s `S.index` (offset + 0))) + $ leastIntensity + dms = (fromIntegral width, fromIntegral height) + (width, height) = dimensions metaBitmap + bytesPerPixel = 3 + bytesPerRow = bytesPerPixel * width + minLength = fromIntegral $ 2 * 3 * width * height + minLengthDecoded = fromIntegral $ bytesPerRow * height + +tryIBF_RGB24A4 :: (S.StringCells s, Bitmap bmp) => bmp -> s -> Either String bmp +tryIBF_RGB24A4 metaBitmap s + | S.length s < minLength = Left $ printf "Data.Bitmap.Class.tryIBF_RGB24A4: 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 $ + constructPixels pixelf dms + where (width, height) = dimensions metaBitmap + dms = (fromIntegral width, fromIntegral height) + padding = case 4 - ((3 * width) `mod` 4) of + 4 -> 0 + n -> n + bytesPerPixel = 3 + bytesPerRow = bytesPerPixel * width + padding + minLength = fromIntegral $ bytesPerRow * height + pixelf (row, column) = let offset = fromIntegral $ bytesPerRow * (fromIntegral row) + bytesPerPixel * (fromIntegral column) + in (red =: (S.toWord8 $ s `S.index` (offset + 0))) + . (green =: (S.toWord8 $ s `S.index` (offset + 1))) + . (blue =: (S.toWord8 $ s `S.index` (offset + 2))) + $ leastIntensity + +tryIBF_BGR24A4VR :: (S.StringCells s, Bitmap bmp) => bmp -> s -> Either String bmp +tryIBF_BGR24A4VR metaBitmap s + | S.length s < minLength = Left $ printf "Data.Bitmap.Class.tryIBF_BGR24A4VR: 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 $ + constructPixels pixelf dms + where (width, height) = dimensions metaBitmap + dms = (fromIntegral width, fromIntegral height) + padding = case 4 - ((3 * width) `mod` 4) of + 4 -> 0 + n -> n + bytesPerPixel = 3 + bytesPerRow = bytesPerPixel * width + padding + minLength = fromIntegral $ bytesPerRow * height + maxRow = abs . pred $ height + pixelf (row, column) = let offset = fromIntegral $ bytesPerRow * (fromIntegral $ maxRow - row) + bytesPerPixel * (fromIntegral column) + in (red =: (S.toWord8 $ s `S.index` (offset + 2))) + . (green =: (S.toWord8 $ s `S.index` (offset + 1))) + . (blue =: (S.toWord8 $ s `S.index` (offset + 0))) + $ leastIntensity + +tryIBF_BGRU32VR :: (S.StringCells s, Bitmap bmp) => bmp -> s -> Either String bmp +tryIBF_BGRU32VR metaBitmap s + | S.length s < minLength = Left $ printf "Data.Bitmap.Class.tryIBF_BGRU32VR: 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 $ + constructPixels pixelf dms + where (width, height) = dimensions metaBitmap + dms = (fromIntegral width, fromIntegral height) + bytesPerPixel = 4 + bytesPerRow = bytesPerPixel * width + minLength = fromIntegral $ bytesPerRow * height + maxRow = abs . pred $ height + pixelf (row, column) = let offset = fromIntegral $ bytesPerRow * (fromIntegral $ maxRow - row) + bytesPerPixel * (fromIntegral column) + in (red =: (S.toWord8 $ s `S.index` (offset + 2))) + . (green =: (S.toWord8 $ s `S.index` (offset + 1))) + . (blue =: (S.toWord8 $ s `S.index` (offset + 0))) + $ leastIntensity + +tryIBF_BGRU32 :: (S.StringCells s, Bitmap bmp) => bmp -> s -> Either String bmp +tryIBF_BGRU32 metaBitmap s + | S.length s < minLength = Left $ printf "Data.Bitmap.Class.tryIBF_BGRU32: 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 $ + constructPixels pixelf dms + where (width, height) = dimensions metaBitmap + dms = (fromIntegral width, fromIntegral height) + bytesPerPixel = 4 + bytesPerRow = bytesPerPixel * width + minLength = fromIntegral $ bytesPerRow * height + pixelf (row, column) = let offset = fromIntegral $ bytesPerRow * (fromIntegral row) + bytesPerPixel * (fromIntegral column) + in (red =: (S.toWord8 $ s `S.index` (offset + 2))) + . (green =: (S.toWord8 $ s `S.index` (offset + 1))) + . (blue =: (S.toWord8 $ s `S.index` (offset + 0))) + $ leastIntensity + +tryIBF_RGB24A4VR :: (S.StringCells s, Bitmap bmp) => bmp -> s -> Either String bmp +tryIBF_RGB24A4VR metaBitmap s + | S.length s < minLength = Left $ printf "Data.Bitmap.Class.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 $ + constructPixels pixelf dms + where (width, height) = dimensions metaBitmap + dms = (fromIntegral width, fromIntegral height) + padding = case 4 - ((3 * width) `mod` 4) of + 4 -> 0 + n -> n + bytesPerPixel = 3 + bytesPerRow = bytesPerPixel * width + padding + minLength = fromIntegral $ bytesPerRow * height + maxRow = abs . pred $ height + pixelf (row, column) = let offset = fromIntegral $ bytesPerRow * (fromIntegral $ maxRow - row) + bytesPerPixel * (fromIntegral column) + in (red =: (S.toWord8 $ s `S.index` (offset + 0))) + . (green =: (S.toWord8 $ s `S.index` (offset + 1))) + . (blue =: (S.toWord8 $ s `S.index` (offset + 2))) + $ leastIntensity + +tryIBF_RGB32 :: (S.StringCells s, Bitmap bmp) => bmp -> s -> Either String bmp +tryIBF_RGB32 metaBitmap s + | S.length s < minLength = Left $ printf "Data.Bitmap.Class.tryIBF_RGB32: 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 $ + constructPixels pixelf dms + where (width, height) = dimensions metaBitmap + dms = (fromIntegral width, fromIntegral height) + bytesPerPixel = 4 + bytesPerRow = bytesPerPixel * width + minLength = fromIntegral $ bytesPerRow * height + pixelf (row, column) = let offset = fromIntegral $ bytesPerRow * (fromIntegral row) + bytesPerPixel * (fromIntegral column) + in (red =: (S.toWord8 $ s `S.index` (offset + 1))) + . (green =: (S.toWord8 $ s `S.index` (offset + 2))) + . (blue =: (S.toWord8 $ s `S.index` (offset + 3))) + $ leastIntensity + +tryIBF_RGB32Z64 :: (S.StringCells s, Bitmap bmp) => bmp -> s -> Either String bmp +tryIBF_RGB32Z64 metaBitmap s = decodeImageFmt IBF_RGB32 metaBitmap =<< tablespoon . decompress . S.toStringCells =<< (maybe (Left "Data.Bitmap.Class.tryIBF_RGB32Z64: not a valid sequence of characters representing a base-64 encoded string") Right $ decode64 s) + +-- | Encode a bitmap +-- +-- An implementation can choose the most efficient or appropriate +-- format by placing its encoder first in its list of encoders. +encodeComplete :: (S.StringCells s, Bitmap bmp) => bmp -> s +encodeComplete + | null encoders = error $ printf "encodeComplete: implementation defines no encoders" + | otherwise = unwrapCompleteEncoder . snd . head $ encoders + where encoders = completeEncoders + +-- | Decode a bitmap +-- +-- The result of first decoder of the implementation that succeeds +-- will be returned. If none succeed, 'Nothing' is returned. +decodeComplete :: (S.StringCells s, Bitmap bmp) => s -> Maybe (CompleteBitmapFormat, bmp) +decodeComplete s = listToMaybe . catMaybes . map (\(fmt, decoder) -> either (const Nothing) (Just . (fmt, )) $ unwrapCompleteDecoder decoder s) $ completeDecoders + +-- | Encode the pixels of a bitmap +-- +-- An implementation can choose the most efficient or appropriate +-- format by placing its encoder first in its list of encoders. +encodeImage :: (S.StringCells s, Bitmap bmp) => bmp -> s +encodeImage + | null encoders = error $ printf "encodeImage: implementation defines no encoders" + | otherwise = unwrapImageEncoder . snd . head $ encoders + where encoders = imageEncoders + +-- | Decode the pixels of a bitmap +-- +-- The result of first decoder of the implementation that succeeds +-- will be returned. If none succeed, 'Nothing' is returned. +decodeImage :: (S.StringCells s, Bitmap bmp) => bmp -> s -> Maybe (ImageBitmapFormat, bmp) +decodeImage bmp s = listToMaybe . catMaybes . map (\(fmt, decoder) -> either (const Nothing) (Just . (fmt, )) $ unwrapImageDecoder decoder bmp s) $ imageDecoders + +serializeFmt :: (Eq a, Show a) => [(a, b)] -> String -> (a -> b) +serializeFmt serializers noHandlerErrorFmtStr = \fmt -> case lookup fmt serializers of + (Just f) -> f + (Nothing) -> error $ + printf + noHandlerErrorFmtStr + (show fmt) + +-- | Encode a bitmap in a particular format +encodeCompleteFmt :: (S.StringCells s, Bitmap bmp) => CompleteBitmapFormat -> bmp -> s +encodeCompleteFmt = unwrapCompleteEncoder . serializeFmt completeEncoders + "encodeCompleteFmt: Bitmap instance did not define handler for encoding format '%s'; does it use 'updateIdentifiableElements' with 'defaultCompleteEncoders' properly?" + +-- | Decode a bitmap in a particular format +decodeCompleteFmt :: (S.StringCells s, Bitmap bmp) => CompleteBitmapFormat -> s -> Either String bmp +decodeCompleteFmt = unwrapCompleteDecoder . serializeFmt completeDecoders + "decodeCompleteFmt: Bitmap instance did not define handler for decoding '%s'; does it use 'updateIdentifiableElements' with 'defaultCompleteDecoders' properly?" + +-- | Encode the pixels of a bitmap in a particular format +encodeImageFmt :: (S.StringCells s, Bitmap bmp) => ImageBitmapFormat -> bmp -> s +encodeImageFmt = unwrapImageEncoder . serializeFmt imageEncoders + "encodeImageFmt: Bitmap instance did not define handler for encoding format '%s'; does it use 'updateIdentifiableElements' with 'defaultImageEncoders' properly?" + +-- | Decode the pixels of a bitmap in a particular format +decodeImageFmt :: (S.StringCells s, Bitmap bmp) => ImageBitmapFormat -> bmp -> s -> Either String bmp +decodeImageFmt = unwrapImageDecoder . serializeFmt imageDecoders + "decodeImageFmt: Bitmap instance did not define handler for decoding format '%s'; does it use 'updateIdentifiableElements' with 'defaultImageDecoders' properly?" + +-- | Decode an image with the given dimensions +-- +-- This is only guaranteed to work on implementations and formats that only +-- need dimensions in addition to the raw pixel data. This is convenient +-- because most often the dimensions are all that is needed. +-- +-- Currently, this function works by constructing a bitmap with the given dimensions +-- and with each pixel set to the least intensity. Thus it is significantly more efficient +-- if this is used with a bitmap that doesn't strictly evaluate the entire pixel data when the structure +-- is first constructed (not necessarily when any pixel is accessed) (currently +-- none of the bitmap types exported in this library are so strict), as the +-- bitmap will not need to be fully evaluated; only the dimensions will be used. +decodeImageDimensions :: (S.StringCells s, Bitmap bmp) => Dimensions (BIndexType bmp) -> s -> Maybe (ImageBitmapFormat, bmp) +decodeImageDimensions dms = decodeImage (constructPixels (const leastIntensity) dms) + +-- | Decode an image with the given dimensions as 'decodeImageDimensions' does it, but in a specific format +decodeImageDimensionsFmt :: (S.StringCells s, Bitmap bmp) => ImageBitmapFormat -> Dimensions (BIndexType bmp) -> s -> Either String bmp +decodeImageDimensionsFmt fmt dms = decodeImageFmt fmt (constructPixels (const leastIntensity) dms) + +-- | Determine whether the seconds dimensions passed can fit within the first dimensions passed +-- +-- If the width or height of the second dimensions exceeds those of first +-- dimensions, 'False' is returned. +dimensionsFit :: (Integral a) => Dimensions a -> Dimensions a -> Bool +dimensionsFit (widthSuper, heightSuper) (widthSub, heightSub) + | widthSub > widthSuper = False + | heightSub > heightSuper = False + | otherwise = True + +-- | Returns the width of a bitmap +bitmapWidth :: (Bitmap bmp) => bmp -> BIndexType bmp +bitmapWidth bmp = let (width, _) = dimensions bmp in width + +-- | Returns the height of a bitmap +bitmapHeight :: (Bitmap bmp) => bmp -> BIndexType bmp +bitmapHeight bmp = let (_, height) = dimensions bmp in height diff --git a/src/Data/Bitmap/Croppable.hs b/src/Data/Bitmap/Croppable.hs new file mode 100644 --- /dev/null +++ b/src/Data/Bitmap/Croppable.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE FlexibleInstances, OverlappingInstances, UndecidableInstances #-} + +module Data.Bitmap.Croppable + ( BitmapCroppable(..) + ) where + +import Data.Bitmap.Class +import Data.Bitmap.Types + +-- | Class for bitmaps that can be rectangularly cropped into (possibly) smaller sizes +-- +-- Using the functions of the 'Bitmap' class, +-- default functions are be defined for each of +-- these; of course, implementations are free +-- to write more efficient versions. +class (Bitmap bmp) => BitmapCroppable bmp where + crop :: bmp -> Coordinates (BIndexType bmp) -> Dimensions (BIndexType bmp) -> bmp + -- ^ Crop a bitmap with the given dimensions (third argument) from a position (second argument) + -- + -- Implementations can but are not required to assume that the result will be a (not necessarily proper) subset of the super bitmap only. Implementations should properly handle the case where the result is as large as the passed super bitmap. + + crop super (cropRow, cropColumn) = constructPixels (\(row, column) -> getPixel super (row + cropRow, column + cropColumn)) + +instance (Bitmap a) => BitmapCroppable a diff --git a/src/Data/Bitmap/Foreign.hs b/src/Data/Bitmap/Foreign.hs new file mode 100644 --- /dev/null +++ b/src/Data/Bitmap/Foreign.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE TypeFamilies, ScopedTypeVariables #-} + +-- | Wrapping interface for bitmaps as defined by the 'bitmap' package + +module Data.Bitmap.Foreign + ( FBBitmapBase + , BitmapForeign(..) + ) where + +import Control.Monad.Record +import qualified Data.Bitmap as FB +import qualified Data.Bitmap.IO as FB +import Data.Bitmap.Class +import Data.Bitmap.Pixel +import Data.Bitmap.Types +import Foreign (unsafePerformIO) +import Foreign.Storable +import Text.Printf + +type FBBitmapBase = FB.Bitmap + +-- | The foreign bitmap as defined by the "bitmap" package +-- +-- For more information see documentation of the "bitmap" package. +-- +-- NB: this type is actually a reference to a memory location; thus the +-- possible issues with concurrency and referential transparency are introduced. +newtype BitmapForeign = BitmapForeign {unwrapBitmapForeign :: FBBitmapBase PixelComponent} + +instance Bitmap BitmapForeign where + type BIndexType BitmapForeign = Int + type BPixelType BitmapForeign = PixelRGB + + depth (BitmapForeign b) = unsafePerformIO . FB.withBitmap b $ \_ numComponents _ _ -> case numComponents of + 3 -> return Depth24RGB + 4 -> return Depth32RGBA + _ -> return $ error $ printf "Bitmap.ForeignBitmap.depth: invalid numConponents value: %d" numComponents + + dimensions (BitmapForeign b) = unsafePerformIO . FB.withBitmap b $ \dms _ _ _ -> return dms + + getPixel (BitmapForeign b) (row, column) = unsafePerformIO . FB.withBitmap b $ \(w, _) numComponents padding ptr -> do + let bytesPixel = numComponents + bytesRow = bytesPixel * w + padding + offset = bytesRow * row + bytesPixel * column + (thisRed :: PixelComponent) <- peekByteOff ptr offset + (thisGreen :: PixelComponent) <- peekByteOff ptr (offset + 1) + (thisBlue :: PixelComponent) <- peekByteOff ptr (offset + 2) + return . (red =: thisRed) . (green =: thisGreen) . (blue =: thisBlue) $ leastIntensity + constructPixels f dms@(w, _) = unsafePerformIO $ do + let bytesPixel = 3 + fbBitmap <- FB.newBitmap dms bytesPixel (Just 4) + FB.withBitmap fbBitmap $ \(width, height) _ padding ptr -> do + let bytesRow = bytesPixel * w + padding + maxRow = abs . pred $ height + maxColumn = abs . pred $ width + m i@(row, column) = do + let offset = bytesRow * row + bytesPixel * column + pixel = f i + pokeByteOff ptr offset $ red <: pixel + pokeByteOff ptr (offset + 1) $ green <: pixel + pokeByteOff ptr (offset + 2) $ blue <: pixel + if column == maxColumn + then do + if row == maxRow + then do + return () + else do + m (succ row, 0) + else do + m (row, succ column) + m (0, 0) + return $ BitmapForeign fbBitmap diff --git a/src/Data/Bitmap/Function.hs b/src/Data/Bitmap/Function.hs new file mode 100644 --- /dev/null +++ b/src/Data/Bitmap/Function.hs @@ -0,0 +1,7 @@ +-- | Bitmaps defined by functions + +module Data.Bitmap.Function + ( BitmapFunction + ) where + +import Data.Bitmap.Function.Internal diff --git a/src/Data/Bitmap/Function/Internal.hs b/src/Data/Bitmap/Function/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/Bitmap/Function/Internal.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE TemplateHaskell, TypeFamilies #-} + +module Data.Bitmap.Function.Internal + ( BitmapFunction(..), bmpf_dimensions, bmpf_getPixel + ) where + +import Control.Monad.Record +import Data.Bitmap.Class +import Data.Bitmap.Pixel +import Data.Bitmap.Types + +data BitmapFunction = BitmapFunction + { _bmpf_dimensions :: Dimensions Integer + , _bmpf_getPixel :: Coordinates Integer -> PixelRGBA + } + +mkLabels [''BitmapFunction] + +instance Bitmap BitmapFunction where + type BIndexType BitmapFunction = Integer + type BPixelType BitmapFunction = PixelRGBA + + depth = const Depth32RGBA + + dimensions = (bmpf_dimensions <:) + + getPixel = (bmpf_getPixel <:) + + constructPixels = flip BitmapFunction diff --git a/src/Data/Bitmap/Pixel.hs b/src/Data/Bitmap/Pixel.hs new file mode 100644 --- /dev/null +++ b/src/Data/Bitmap/Pixel.hs @@ -0,0 +1,377 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving, TypeOperators, DeriveDataTypeable #-} + +-- | Support for pixels with a colour depth of 24 or 32, either lacking or containing an alpha component +-- +-- Greater precision and color depth are not yet supported. Support for +-- floating point representations of components is planned for the +-- future. + +module Data.Bitmap.Pixel + ( Pixel(..) + , convertPixelValue + , PixelStorage + , PixelComponent + , leastIntensityComponent + , greatestIntensityComponent + , PixelRGB(..) + , PixelBGR(..) + , PixelRGBA(..) + , PixelBGRA(..) + , ConvPixelRGB(..) + , ConvPixelBGR(..) + , ConvPixelRGBA(..) + , ConvPixelBGRA(..) + + , GenPixel(..) + , eqGenPixelValue, neqGenPixelValue + , genRed, genGreen, genBlue, genAlpha + , toGenPixelRGB, toGenPixelBGR, toGenPixelRGBA, toGenPixelBGRA + , GenPixelStorage + , GenPixelComponent + , leastIntensityGenComponent + , greatestIntensityGenComponent + , leastIntensityGen + , greatestIntensityGen + + , bigEndian + + , colorString + ) where + +import Codec.String.Base16 +import Control.Applicative +import Control.Monad.Record +import Data.Bits +import Data.Data +import Data.Maybe +import qualified Data.String.Class as S +import Data.Word +import Foreign (unsafePerformIO) +import Foreign.C.Types +import Foreign.Ptr +import Foreign.Marshal.Utils +import Foreign.Storable + +class (Integral a, ConvPixelRGB a, ConvPixelRGBA a, ConvPixelBGR a, ConvPixelBGRA a) => Pixel a where + red :: a :-> PixelComponent + green :: a :-> PixelComponent + blue :: a :-> PixelComponent + alpha :: Maybe (a :-> PixelComponent) + leastIntensity :: a + greatestIntensity :: a + toPixel :: (Pixel p) => a -> p + fromPixel :: (Pixel p) => p -> a + + leastIntensity = case alpha of + (Just alpha') -> (red =: leastIntensityComponent) + . (green =: leastIntensityComponent) + . (blue =: leastIntensityComponent) + . (alpha' =: leastIntensityComponent) + $ fromIntegral (0 :: Integer) + (Nothing) -> (red =: leastIntensityComponent) + . (green =: leastIntensityComponent) + . (blue =: leastIntensityComponent) + $ fromIntegral (0 :: Integer) + greatestIntensity = case alpha of + (Just alpha') -> (red =: greatestIntensityComponent) + . (green =: greatestIntensityComponent) + . (blue =: greatestIntensityComponent) + . (alpha' =: greatestIntensityComponent) + $ leastIntensity + (Nothing) -> (red =: greatestIntensityComponent) + . (green =: greatestIntensityComponent) + . (blue =: greatestIntensityComponent) + $ leastIntensity + + toPixel = convertPixelValue + fromPixel = convertPixelValue + +-- | A less efficient way of converting pixels by their components +convertPixelValue :: (Pixel a, Pixel b) => a -> b +convertPixelValue p = + case alpha of + (Just alphaB) -> + case alpha of + (Just alphaA) -> + (red =: red <: p) + . (green =: green <: p) + . (blue =: blue <: p) + . (alphaB =: alphaA <: p) + $ leastIntensity + (Nothing) -> + (red =: red <: p) + . (green =: green <: p) + . (blue =: blue <: p) + . (alphaB =: greatestIntensityComponent) + $ leastIntensity + (Nothing) -> + (red =: red <: p) + . (green =: green <: p) + . (blue =: blue <: p) + $ leastIntensity + +type PixelStorage = Word32 +type PixelComponent = Word8 + +leastIntensityComponent :: PixelComponent +leastIntensityComponent = 0x00 +greatestIntensityComponent :: PixelComponent +greatestIntensityComponent = 0xFF + +newtype PixelRGB = PixelRGB {unwrapPixelRGB :: PixelStorage} + deriving (Eq, Bounded, Enum, Ord, Real, Integral, Bits, Num, Show, Data, Typeable) +newtype PixelBGR = PixelBGR {unwrapPixelBGR :: PixelStorage} + deriving (Eq, Bounded, Enum, Ord, Real, Integral, Bits, Num, Show, Data, Typeable) +newtype PixelRGBA = PixelRGBA {unwrapPixelRGBA :: PixelStorage} + deriving (Eq, Bounded, Enum, Ord, Real, Integral, Bits, Num, Show, Data, Typeable) +newtype PixelBGRA = PixelBGRA {unwrapPixelBGRA :: PixelStorage} + deriving (Eq, Bounded, Enum, Ord, Real, Integral, Bits, Num, Show, Data, Typeable) + +byteLens :: (Integral p, Bits p) => Integer -> (p :-> Word8) +byteLens 0 = lens (fromIntegral) (\w p -> (p .&. complement 0xFF) .|. fromIntegral w) +byteLens i = let i' = fromIntegral i + in lens (fromIntegral . (`shiftR` i')) (\w p -> (p .&. complement (0xFF `shiftL` i')) .|. fromIntegral w `shiftL` i') + +instance Pixel PixelRGB where + red = byteLens 16 + green = byteLens 8 + blue = byteLens 0 + alpha = Nothing + toPixel = fromPixelRGB + fromPixel = toPixelRGB + +instance Pixel PixelBGR where + red = byteLens 0 + green = byteLens 8 + blue = byteLens 16 + alpha = Nothing + toPixel = fromPixelBGR + fromPixel = toPixelBGR + +instance Pixel PixelRGBA where + red = byteLens 24 + green = byteLens 16 + blue = byteLens 8 + alpha = Just $ byteLens 0 + toPixel = fromPixelRGBA + fromPixel = toPixelRGBA + +instance Pixel PixelBGRA where + red = byteLens 8 + green = byteLens 16 + blue = byteLens 24 + alpha = Just $ byteLens 0 + toPixel = fromPixelBGRA + fromPixel = toPixelBGRA + +class ConvPixelRGB p where + toPixelRGB :: p -> PixelRGB + fromPixelRGB :: PixelRGB -> p + +class ConvPixelBGR p where + toPixelBGR :: p -> PixelBGR + fromPixelBGR :: PixelBGR -> p + +class ConvPixelRGBA p where + toPixelRGBA :: p -> PixelRGBA + fromPixelRGBA :: PixelRGBA -> p + +class ConvPixelBGRA p where + toPixelBGRA :: p -> PixelBGRA + fromPixelBGRA :: PixelBGRA -> p + + +instance ConvPixelRGB PixelRGB where + toPixelRGB = id + fromPixelRGB = id + +instance ConvPixelRGB PixelBGR where + toPixelRGB b = (red =: red <: b) . (green =: green <: b) . (blue =: blue <: b) $ leastIntensity + fromPixelRGB = toPixelBGR + +instance ConvPixelRGB PixelRGBA where + toPixelRGB b = (red =: red <: b) . (green =: green <: b) . (blue =: blue <: b) $ leastIntensity + fromPixelRGB = toPixelRGBA + +instance ConvPixelRGB PixelBGRA where + toPixelRGB b = (red =: red <: b) . (green =: green <: b) . (blue =: blue <: b) $ leastIntensity + fromPixelRGB = toPixelBGRA + + +instance ConvPixelBGR PixelRGB where + toPixelBGR b = (red =: red <: b) . (green =: green <: b) . (blue =: blue <: b) $ leastIntensity + fromPixelBGR = toPixelRGB + +instance ConvPixelBGR PixelBGR where + toPixelBGR = id + fromPixelBGR = id + +instance ConvPixelBGR PixelRGBA where + toPixelBGR b = (red =: red <: b) . (green =: green <: b) . (blue =: blue <: b) $ leastIntensity + fromPixelBGR = toPixelRGBA + +instance ConvPixelBGR PixelBGRA where + toPixelBGR b = (red =: red <: b) . (green =: green <: b) . (blue =: blue <: b) $ leastIntensity + fromPixelBGR = toPixelBGRA + + +instance ConvPixelRGBA PixelRGB where + toPixelRGBA b = (red =: red <: b) . (green =: green <: b) . (blue =: blue <: b) . (fromJust alpha =: greatestIntensityComponent) $ leastIntensity + fromPixelRGBA = toPixelRGB + +instance ConvPixelRGBA PixelBGR where + toPixelRGBA b = (red =: red <: b) . (green =: green <: b) . (blue =: blue <: b) . (fromJust alpha =: greatestIntensityComponent) $ leastIntensity + fromPixelRGBA = toPixelBGR + +instance ConvPixelRGBA PixelRGBA where + toPixelRGBA = id + fromPixelRGBA = id + +instance ConvPixelRGBA PixelBGRA where + toPixelRGBA b = (red =: red <: b) . (green =: green <: b) . (blue =: blue <: b) . (fromJust alpha =: fromJust alpha <: b) $ leastIntensity + fromPixelRGBA = toPixelBGRA + + +instance ConvPixelBGRA PixelRGB where + toPixelBGRA b = (red =: red <: b) . (green =: green <: b) . (blue =: blue <: b) . (fromJust alpha =: greatestIntensityComponent) $ leastIntensity + fromPixelBGRA = toPixelRGB + +instance ConvPixelBGRA PixelBGR where + toPixelBGRA b = (red =: red <: b) . (green =: green <: b) . (blue =: blue <: b) . (fromJust alpha =: greatestIntensityComponent) $ leastIntensity + fromPixelBGRA = toPixelBGR + +instance ConvPixelBGRA PixelRGBA where + toPixelBGRA b = (red =: red <: b) . (green =: green <: b) . (blue =: blue <: b) . (fromJust alpha =: fromJust alpha <: b) $ leastIntensity + fromPixelBGRA = toPixelRGBA + +instance ConvPixelBGRA PixelBGRA where + toPixelBGRA = id + fromPixelBGRA = id + +-- | Generic pixel type which has not be efficient enough when used with bitmaps in practice +data GenPixel = + GenPixelRGB {unwrapPixelStorage :: GenPixelStorage} -- ^ The most significant byte is unused + | GenPixelBGR {unwrapPixelStorage :: GenPixelStorage} -- ^ The most significant byte is unused + | GenPixelRGBA {unwrapPixelStorage :: GenPixelStorage} + | GenPixelBGRA {unwrapPixelStorage :: GenPixelStorage} + deriving (Eq, Show, Data, Typeable) + +-- | If the Genpixel types differ, they can still be determined to be equivalent if their components are equal +-- +-- Unlike the default derived instance of Eq, +eqGenPixelValue, neqGenPixelValue :: GenPixel -> GenPixel -> Bool +a `eqGenPixelValue` b = genRed <: a == genRed <: b && genGreen <: a == genGreen <: b && genBlue <: a == genBlue <: b +a `neqGenPixelValue` b = genRed <: a /= genRed <: b || genGreen <: a /= genGreen <: b || genBlue <: a /= genBlue <: b + +lgetter :: Integer -> (GenPixelStorage -> GenPixelComponent) +lgetter 0 = fromIntegral +lgetter i = \storage -> (fromIntegral :: GenPixelStorage -> GenPixelComponent) $ storage `shiftR` fromIntegral i + +lsetter :: Integer -> (GenPixelComponent -> GenPixelStorage -> GenPixelStorage) +lsetter 0 = \component storage -> storage .|. fromIntegral component +lsetter i = \component storage -> storage .|. (((fromIntegral (component :: GenPixelComponent)) :: GenPixelStorage) `shiftL` (fromIntegral i)) + +genRed :: GenPixel :-> GenPixelComponent +genRed = lens getter setter + where getter (GenPixelRGB storage) = lgetter 16 storage + getter (GenPixelBGR storage) = lgetter 0 storage + getter (GenPixelRGBA storage) = lgetter 24 storage + getter (GenPixelBGRA storage) = lgetter 8 storage + setter component (GenPixelRGB storage) = GenPixelRGB $ lsetter 16 component storage + setter component (GenPixelBGR storage) = GenPixelBGR $ lsetter 0 component storage + setter component (GenPixelRGBA storage) = GenPixelRGBA $ lsetter 24 component storage + setter component (GenPixelBGRA storage) = GenPixelBGRA $ lsetter 8 component storage + +genGreen :: GenPixel :-> GenPixelComponent +genGreen = lens getter setter + where getter (GenPixelRGB storage) = lgetter 8 storage + getter (GenPixelBGR storage) = lgetter 8 storage + getter (GenPixelRGBA storage) = lgetter 16 storage + getter (GenPixelBGRA storage) = lgetter 16 storage + setter component (GenPixelRGB storage) = GenPixelRGB $ lsetter 8 component storage + setter component (GenPixelBGR storage) = GenPixelBGR $ lsetter 8 component storage + setter component (GenPixelRGBA storage) = GenPixelRGBA $ lsetter 16 component storage + setter component (GenPixelBGRA storage) = GenPixelBGRA $ lsetter 16 component storage + +genBlue :: GenPixel :-> GenPixelComponent +genBlue = lens getter setter + where getter (GenPixelRGB storage) = lgetter 0 storage + getter (GenPixelBGR storage) = lgetter 16 storage + getter (GenPixelRGBA storage) = lgetter 8 storage + getter (GenPixelBGRA storage) = lgetter 24 storage + setter component (GenPixelRGB storage) = GenPixelRGB $ lsetter 0 component storage + setter component (GenPixelBGR storage) = GenPixelBGR $ lsetter 16 component storage + setter component (GenPixelRGBA storage) = GenPixelRGBA $ lsetter 8 component storage + setter component (GenPixelBGRA storage) = GenPixelBGRA $ lsetter 24 component storage + +genAlpha :: GenPixel :-> GenPixelComponent +genAlpha = lens getter setter + where getter (GenPixelRGB _) = greatestIntensityComponent + getter (GenPixelBGR _) = greatestIntensityComponent + getter (GenPixelRGBA storage) = lgetter 0 storage + getter (GenPixelBGRA storage) = lgetter 0 storage + setter _ b@(GenPixelRGB _) = b + setter _ b@(GenPixelBGR _) = b + setter component (GenPixelRGBA storage) = GenPixelRGBA $ lsetter 0 component storage + setter component (GenPixelBGRA storage) = GenPixelBGRA $ lsetter 0 component storage + +toGenPixelRGB :: GenPixel -> GenPixel +toGenPixelRGB b@(GenPixelRGB _) = b +toGenPixelRGB b@(GenPixelBGR _) = (genRed =: genRed <: b) . (genGreen =: genGreen <: b) . (genBlue =: genBlue <: b) . (genAlpha =: genAlpha <: b) $ GenPixelRGB 0 +toGenPixelRGB b@(GenPixelRGBA _) = (genRed =: genRed <: b) . (genGreen =: genGreen <: b) . (genBlue =: genBlue <: b) . (genAlpha =: genAlpha <: b) $ GenPixelRGB 0 +toGenPixelRGB b@(GenPixelBGRA _) = (genRed =: genRed <: b) . (genGreen =: genGreen <: b) . (genBlue =: genBlue <: b) . (genAlpha =: genAlpha <: b) $ GenPixelRGB 0 + +toGenPixelBGR :: GenPixel -> GenPixel +toGenPixelBGR b@(GenPixelRGB _) = (genRed =: genRed <: b) . (genGreen =: genGreen <: b) . (genBlue =: genBlue <: b) . (genAlpha =: genAlpha <: b) $ GenPixelBGR 0 +toGenPixelBGR b@(GenPixelBGR _) = b +toGenPixelBGR b@(GenPixelRGBA _) = (genRed =: genRed <: b) . (genGreen =: genGreen <: b) . (genBlue =: genBlue <: b) . (genAlpha =: genAlpha <: b) $ GenPixelBGR 0 +toGenPixelBGR b@(GenPixelBGRA _) = (genRed =: genRed <: b) . (genGreen =: genGreen <: b) . (genBlue =: genBlue <: b) . (genAlpha =: genAlpha <: b) $ GenPixelBGR 0 + +toGenPixelRGBA :: GenPixel -> GenPixel +toGenPixelRGBA b@(GenPixelRGB _) = (genRed =: genRed <: b) . (genGreen =: genGreen <: b) . (genBlue =: genBlue <: b) . (genAlpha =: genAlpha <: b) $ GenPixelRGBA 0 +toGenPixelRGBA b@(GenPixelBGR _) = (genRed =: genRed <: b) . (genGreen =: genGreen <: b) . (genBlue =: genBlue <: b) . (genAlpha =: genAlpha <: b) $ GenPixelRGBA 0 +toGenPixelRGBA b@(GenPixelRGBA _) = b +toGenPixelRGBA b@(GenPixelBGRA _) = (genRed =: genRed <: b) . (genGreen =: genGreen <: b) . (genBlue =: genBlue <: b) . (genAlpha =: genAlpha <: b) $ GenPixelRGBA 0 + +toGenPixelBGRA :: GenPixel -> GenPixel +toGenPixelBGRA b@(GenPixelRGB _) = (genRed =: genRed <: b) . (genGreen =: genGreen <: b) . (genBlue =: genBlue <: b) . (genAlpha =: genAlpha <: b) $ GenPixelBGRA 0 +toGenPixelBGRA b@(GenPixelBGR _) = (genRed =: genRed <: b) . (genGreen =: genGreen <: b) . (genBlue =: genBlue <: b) . (genAlpha =: genAlpha <: b) $ GenPixelBGRA 0 +toGenPixelBGRA b@(GenPixelRGBA _) = (genRed =: genRed <: b) . (genGreen =: genGreen <: b) . (genBlue =: genBlue <: b) . (genAlpha =: genAlpha <: b) $ GenPixelBGRA 0 +toGenPixelBGRA b@(GenPixelBGRA _) = b + +type GenPixelStorage = Word32 +type GenPixelComponent = Word8 + +leastIntensityGenComponent :: GenPixelComponent +leastIntensityGenComponent = 0x00 +greatestIntensityGenComponent :: GenPixelComponent +greatestIntensityGenComponent = 0xFF + +leastIntensityGen :: GenPixel +leastIntensityGen = (genRed =: leastIntensityGenComponent) + . (genGreen =: leastIntensityGenComponent) + . (genBlue =: leastIntensityGenComponent) + . (genAlpha =: leastIntensityGenComponent) + $ GenPixelRGBA 0 +greatestIntensityGen :: GenPixel +greatestIntensityGen = (genRed =: greatestIntensityGenComponent) + . (genGreen =: greatestIntensityGenComponent) + . (genBlue =: greatestIntensityGenComponent) + . (genAlpha =: greatestIntensityGenComponent) + $ GenPixelRGBA 0 + +bigEndian :: Bool +bigEndian = unsafePerformIO $ with (1 :: CInt) $ \p -> (0 ==) <$> (peek (castPtr p :: Ptr CChar)) + +-- | Return a color from the first 6-bytes of a string representing the red, green, and blue components of the color +-- +-- > (colorString "FF0000" :: Maybe PixelRGBA) == Just $ (red =: 0xFF) . (green =: 0x00) . (blue =: 0x00) $ greatestIntensity +colorString :: (S.StringCells s, Pixel p) => s -> Maybe p +colorString s = + case S.safeUncons3 =<< decodeHex s of + (Just (byteRed, byteGreen, byteBlue, _)) -> Just $ + (red =: S.toWord8 byteRed) + . (green =: S.toWord8 byteGreen) + . (blue =: S.toWord8 byteBlue) + $ greatestIntensity + (Nothing) -> Nothing diff --git a/src/Data/Bitmap/Reflectable.hs b/src/Data/Bitmap/Reflectable.hs new file mode 100644 --- /dev/null +++ b/src/Data/Bitmap/Reflectable.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE FlexibleInstances, OverlappingInstances, UndecidableInstances #-} + +module Data.Bitmap.Reflectable + ( BitmapReflectable(..) + ) where + +import Data.Bitmap.Class + +-- | Class for reflectable bitmaps +-- +-- Using the functions of the 'Bitmap' class, +-- default functions are be defined for each of +-- these; of course, implementations are free +-- to write more efficient versions. +class (Bitmap bmp) => BitmapReflectable bmp where + reflectVertically :: bmp -> bmp + reflectHorizontally :: bmp -> bmp + + reflectVertically b = constructPixels f dms + where dms@(_, height) = dimensions b + maxRow = abs . pred $ height + f (r, c) = getPixel b (maxRow - r, c) + reflectHorizontally b = constructPixels f dms + where dms@(width, _) = dimensions b + maxColumn = abs . pred $ width + f (r, c) = getPixel b (r, maxColumn - c) + +instance (Bitmap a) => BitmapReflectable a diff --git a/src/Data/Bitmap/Searchable.hs b/src/Data/Bitmap/Searchable.hs new file mode 100644 --- /dev/null +++ b/src/Data/Bitmap/Searchable.hs @@ -0,0 +1,513 @@ +{-# LANGUAGE FlexibleInstances, OverlappingInstances, UndecidableInstances, ScopedTypeVariables #-} + +module Data.Bitmap.Searchable + ( BitmapSearchable(..) + , areColorsSimilar + , colorDifferenceCIE94 + , defaultTransparentPixel + , matchPixelAny + , matchPixelSame + , matchPixelSameThreshold + , matchPixelDif + , matchPixelDifThreshold + ) where + +import Control.Monad.Record +import Data.Bitmap.Class +import Data.Bitmap.Pixel +import Data.Bitmap.Types +import Data.List (nub) + +-- | Class for searchable bitmaps +-- +-- Using the functions of the 'Bitmap' class, +-- default functions are be defined for each of +-- these; of course, implementations are free +-- to define more efficient versions. +class (Bitmap bmp) => BitmapSearchable bmp where + -- | Recursively call a function with the coordinates, row by row from the left, from + -- the minimum, upper-left coordinates to the maximum, lower-right coordinates + foldrCoords :: + (Coordinates (BIndexType bmp) -> a -> a) + -> a -- ^ Starting value + -> Coordinates (BIndexType bmp) -- ^ Minimum, upper-left coordinates + -> Coordinates (BIndexType bmp) -- ^ Maximum, lower-right coordinates + -> bmp -- ^ The bitmap in which to scan coordinates + -> a + + -- | Scan each pixel until a match is found in no particular order + -- + -- Implementations are free to choose an efficient implementation that + -- searches in a different direction from that of 'findPixelOrder'. + -- This function is often, but not necessarily always, the same as + -- 'findPixelOrder'. + findPixel :: + (BPixelType bmp -> Bool) + -> bmp + -> Maybe (Coordinates (BIndexType bmp)) + -- | Scan each pixel, row by row from the left, starting at the given offset, until a match is found + findPixelOrder :: + (BPixelType bmp -> Bool) + -> bmp + -> Coordinates (BIndexType bmp) + -> Maybe (Coordinates (BIndexType bmp)) + -- | A more restricted version of 'findPixelEqual' that is usually more efficient when exact equality is desired + findPixelEqual :: + BPixelType bmp + -> bmp + -> Coordinates (BIndexType bmp) + -> Maybe (Coordinates (BIndexType bmp)) + findPixels :: + (BPixelType bmp -> Bool) + -> bmp + -> Coordinates (BIndexType bmp) + -> [Coordinates (BIndexType bmp)] + findPixelsEqual :: + BPixelType bmp + -> bmp + -> Coordinates (BIndexType bmp) + -> [Coordinates (BIndexType bmp)] + + -- | Search for coordinates where a sub-bitmap would match + -- + -- Each coordinate, representing the upper-left-most corner, + -- for which the sub-bitmap would fit is tried for a match until + -- the function returns 'True' for every pixel that is compared. + -- The function is passed the pixel of the super bitmap which is searched + -- as the first parameter, and the pixel of the sub bitmap is passed + -- as the second parameter. Likewise, the super bitmap is then given + -- to this function as the second parameter, and then the sub bitmap. + -- Normally, the order in which the bitmap is checked in the same order + -- as 'findPixelOrder', but implementation are free to implement this + -- in whatever order is convenient or efficient; implementation should, + -- however, assume that callers usually expect this order to be the most + -- efficient one. + findSubBitmap :: + (BPixelType bmp -> BPixelType bmp -> Bool) + -> bmp -- ^ Super bitmap + -> bmp -- ^ Sub bitmap + -> Maybe (Coordinates (BIndexType bmp)) + findSubBitmapOrder :: + (BPixelType bmp -> BPixelType bmp -> Bool) + -> bmp -- ^ Super bitmap + -> bmp -- ^ Sub bitmap + -> Coordinates (BIndexType bmp) + -> Maybe (Coordinates (BIndexType bmp)) + + -- | A more restricted version of 'findSubBitmapEqual' that is usually more efficient when exact equality is desired + findSubBitmapEqual :: + bmp -- ^ Super bitmap + -> bmp -- ^ Sub bitmap + -> Coordinates (BIndexType bmp) + -> Maybe (Coordinates (BIndexType bmp)) + findSubBitmaps :: + (BPixelType bmp -> BPixelType bmp -> Bool) + -> bmp -- ^ Super bitmap + -> bmp -- ^ Sub bitmap + -> Coordinates (BIndexType bmp) + -> [(Coordinates (BIndexType bmp))] + findSubBitmapsEqual :: + bmp -- ^ Super bitmap + -> bmp -- ^ Sub bitmap + -> Coordinates (BIndexType bmp) + -> [(Coordinates (BIndexType bmp))] + + -- | Find the first bitmap from the list that matches with + -- the area of the same size from the given coordinate in + -- the "super" bitmap (passed as the second argument) + -- down-right (the coordinate is the first pixel which is + -- the top-left most of the area to check). The match + -- sub-bitmap and its index in the list are passed in + -- the opposite order given in this description to the + -- function, and the result is returned; if one is found. + -- If no match is found, 'Nothing' is returned. + -- + -- The "sub" bitmaps are tested in order until a match is + -- found, and if one is, its index in the list is + -- returned. Each pixel in every "sub" bitmap is specially + -- colored to represent a particular function. These + -- colors are recognized: + -- + -- - black / greatest intensity: the corresponding pixel in + -- the "super" bitmap based on position can be any color. + -- - white / least intensity: the corresponding pixel in the + -- super bitmap must be the same color as every other pixel + -- in the super bitmap that also corresponds to a white pixel. + -- + -- - red / FF0000 / completely red: if there are white + -- pixels in the sub bitmap, the corresponding pixel of the + -- red pixel should be different from the color that + -- corresponds to the white pixels. + -- + -- - green / 00FF00 / complete green: if there are white pixels + -- in the sub bitmap, the corresponding pixel of the + -- green pixel should not be similar from the color + -- that corresponds to the white pixels. See + -- + -- - yellow / FFFF00 / complete yellow: if there are white pixels, + -- this matches iff the color is similar to the colors that + -- correspond to the white pixels. + -- + -- 'areColorsSimilar' to see whether two colors are + -- considered to be "similar". + -- + -- The behaviour when any other pixel is encountered is + -- undefined. + -- + -- When the dimensions of a sub bitmap are too large for the + -- super bitmap offset by the coordinates, where otherwise + -- some pixels of the sub bitmap would not have any + -- corresponding pixels in the super bitmap; then the sub + -- bitmap simply does not match. + -- + -- This function makes OCR with a known and static font + -- more convenient to implement. + findEmbeddedBitmap :: + (Integral i) + => [bmp] + -> bmp -- ^ Super bitmap + -> Coordinates (BIndexType bmp) -- ^ Coordinates relative to super bitmap + -> Maybe (i, bmp) + + -- | 'foldr' equivalent of 'findEmbeddedBitmap' for a horizontal string of embedded bitmaps + -- + -- This is particularly convenient for OCR with a static and known font with multiple characters. + findEmbeddedBitmapString :: + (Integral i) + => ((i, bmp) -> a -> a) + -> a + -> [bmp] + -> bmp -- ^ Super bitmap + -> Coordinates (BIndexType bmp) + -> a + + -- | Scan for the given string of horizontally embedded bitmaps as in 'findEmbeddedBitmap' + -- + -- As with 'findEmbeddedBitmapString', each bitmap must be adjacent to match. + -- If the integer is passed for a dimension ("(width, height)"), then + -- no more than "the value" extra rows or columns will be checked. + -- For example, if 'Just' @0@ is passed for the row value, then no + -- additional rows will be checked. + findFixedEmbeddedBitmapString :: + Dimensions (Maybe (BIndexType bmp)) + -> [bmp] + -> bmp -- ^ Super bitmap + -> Coordinates (BIndexType bmp) + -> Maybe (Coordinates (BIndexType bmp)) + + foldrCoords f z base_i@(baseRow, _) (maxRow, maxColumn) bmp = go base_i + where maxRow' = min maxRow $ pred (bitmapHeight bmp) + maxColumn' = min maxColumn $ pred (bitmapWidth bmp) + go i@(row, column) + | column > maxColumn' + = go (succ row, baseRow) + | row > maxRow' + = z + | otherwise + = i `f` go (row, succ column) + + findPixel f b = findPixelOrder f b (0, 0) + + findPixelOrder f bmp startCoords = foldrCoords step Nothing startCoords (dimensions bmp) bmp + where step coords + | f $ getPixel bmp coords + = const $ Just coords + | otherwise + = id + + findPixelEqual p = findPixelOrder (== p) + + findPixels f b = r' + where (width, height) = dimensions b + maxColumn = abs . pred $ width + maxRow = abs . pred $ height + nextCoordinate (row, column) + | column >= maxColumn = (succ row, 0) + | otherwise = (row, succ column) + r' i = + case findPixelOrder f b i of + (Just i'@(row, column)) -> + if row < maxRow || column < maxColumn + then i' : findPixels f b (nextCoordinate i') + else i' : [] + (Nothing) -> + [] + + findPixelsEqual p b = r' + where (width, height) = dimensions b + maxColumn = abs . pred $ width + maxRow = abs . pred $ height + nextCoordinate (row, column) + | column >= maxColumn = (succ row, 0) + | otherwise = (row, succ column) + r' i = + case findPixelEqual p b i of + (Just i'@(row, column)) -> + if row < maxRow || column < maxColumn + then i' : findPixelsEqual p b (nextCoordinate i') + else i' : [] + (Nothing) -> + [] + + findSubBitmap f super sub = findSubBitmapOrder f super sub (0, 0) + + findSubBitmapOrder f super sub = r' + where r' i@(row, column) + | column > maxColumn = + r' (succ row, 0) + | row > maxRow = + Nothing + | matches (0, 0) = + Just i + | otherwise = + r' (row, succ column) + where matches offi@(offRow, offColumn) + | offColumn > maxOffColumn = + matches (succ offRow, 0) + | offRow > maxOffRow = + True + | not $ f (getPixel super (row + offRow, column + offColumn)) (getPixel sub offi) = + False + | otherwise = + matches (offRow, succ offColumn) + + (widthSuper, heightSuper) = dimensions super + (widthSub, heightSub) = dimensions sub + (maxRow, maxColumn) = (heightSuper - heightSub, widthSuper - widthSub) + (maxOffRow, maxOffColumn) = (abs . pred $ heightSub, abs . pred $ widthSub) + + findSubBitmapEqual = findSubBitmapOrder (==) + + findSubBitmaps f super sub = r' + where (widthSuper, heightSuper) = dimensions super + (widthSub, heightSub) = dimensions sub + (maxRow, maxColumn) = (heightSuper - heightSub, widthSuper - widthSub) + nextCoordinate (row, column) + | column >= maxColumn = (succ row, 0) + | otherwise = (row, succ column) + r' i = + case findSubBitmapOrder f super sub i of + (Just i'@(row, column)) -> + if row < maxRow || column < maxColumn + then i' : findSubBitmaps f super sub (nextCoordinate i') + else i' : [] + (Nothing) -> + [] + + findSubBitmapsEqual super sub = r' + where (widthSuper, heightSuper) = dimensions super + (widthSub, heightSub) = dimensions sub + (maxRow, maxColumn) = (heightSuper - heightSub, widthSuper - widthSub) + nextCoordinate (row, column) + | column >= maxColumn = (succ row, 0) + | otherwise = (row, succ column) + r' i = + case findSubBitmapEqual super sub i of + (Just i'@(row, column)) -> + if row < maxRow || column < maxColumn + then i' : findSubBitmapsEqual super sub (nextCoordinate i') + else i' : [] + (Nothing) -> + [] + + findEmbeddedBitmap allEmbs super (row, column) = r' 0 allEmbs + where pixAny = matchPixelAny + pixSame = matchPixelSame + pixThrs = matchPixelSameThreshold + pixDif = matchPixelDif + pixDft = matchPixelDifThreshold + dimensionsSuper = dimensions super + r' _ [] = Nothing + r' n (e:es) + | True <- dimensionsFit dimensionsSuper (widthSub + column, heightSub + row) + , True <- matches Nothing [] [] [] (0, 0) + = Just $ (n, e) + | otherwise + = r' (succ n) es + -- difColors is necessary because red pixels could be encountered first, so we keep track of every color of every red pixel until we encounter a white pixel, and then we can empty the list after we check whether the first color is part of the list; for efficiency we always eliminate duplicates + where matches matchColor difColors dftColors thrsColors offi@(offRow, offColumn) + | offColumn > maxOffColumn + = matches matchColor difColors dftColors thrsColors (succ offRow, 0) + | offRow > maxOffRow + = True + | (False, _, _, _, _) <- posCondition + = False + | (_, matchColor', difColors', dftColors', thrsColors') <- posCondition + = matches matchColor' difColors' dftColors' thrsColors' (offRow, succ offColumn) + where posCondition + | subPixel == pixAny + -- Any pixel (black in sub) + = (True, matchColor, difColors, dftColors, thrsColors) + | True <- subPixel == pixSame + , (Just matchColor') <- matchColor + -- Match pixel (white in sub); matching color already set + = (superPixel == matchColor', matchColor, difColors, dftColors, thrsColors) -- difColors + dftColors should already be empty + | True <- subPixel == pixSame + -- First match pixel (white in sub); record matching color + = ((not $ superPixel `elem` difColors) && (not $ any (`areColorsSimilar` superPixel) dftColors) && (all (`areColorsSimilar` superPixel) thrsColors), Just superPixel, [], [], []) + | True <- subPixel == pixDif + , (Just matchColor') <- matchColor + -- Dif pixel (completely red in sub); matching color found + = (superPixel /= matchColor', matchColor, difColors, dftColors, thrsColors) -- difColors + dftColors should already be empty + | True <- subPixel == pixDif + -- Dif pixel (completely red in sub); matching color not yet found + = (True, matchColor, nub $ superPixel : difColors, dftColors, thrsColors) + | True <- subPixel == pixDft + , (Just matchColor') <- matchColor + -- Dft pixel (completely green in sub); matching color found + = (not $ superPixel `areColorsSimilar` matchColor', matchColor, difColors, dftColors, thrsColors) -- difColors + dftColors should already be empty + | True <- subPixel == pixDft + -- Dft pixel (completely green in sub); matching color not yet found + = (True, matchColor, difColors, nub $ superPixel : dftColors, thrsColors) + | True <- subPixel == pixThrs + , (Just matchColor') <- matchColor + -- Thrs pixel (completely yellow in sub); matching color found + = (superPixel `areColorsSimilar` matchColor', matchColor, difColors, dftColors, thrsColors) -- difColors + dftColors should already be empty + | True <- subPixel == pixThrs + -- Thrs pixel (completely yellow in sub); matching color not yet found + = (True, matchColor, difColors, dftColors, nub $ superPixel : thrsColors) + | otherwise + -- undefined pixel in sub bitmap + = (False, matchColor, difColors, dftColors, thrsColors) + where superPixel = getPixel super (row + offRow, column + offColumn) + subPixel = getPixel e offi + + (widthSub, heightSub) = dimensions e + (maxOffRow, maxOffColumn) = (abs . pred $ heightSub, abs . pred $ widthSub) + + findEmbeddedBitmapString f z allEmbs super = go + where go pos@(row, column) = + case findEmbeddedBitmap allEmbs super pos of + (Nothing) -> z + (Just r@(_, bmp)) -> r `f` go (row, column + (max 1 $ bitmapWidth bmp)) + + findFixedEmbeddedBitmapString (extraRowsW, extraColumnsW) allEmbs super base_i@(base_row, base_column) = + foldrCoords step zero base_i (base_row + extraRows, base_column + extraColumns) super + where maxRow = abs . pred $ bitmapHeight super + maxColumn = abs . pred $ bitmapWidth super + maxExtraRows = maxRow - base_row + maxExtraColumns = maxColumn - base_column + extraRows = maybe maxExtraRows (max 0 . min maxExtraRows) extraRowsW + extraColumns = maybe maxExtraColumns (max 0 . min maxExtraColumns) extraColumnsW + zero = Nothing + step i a + | textFound i = Just i + | otherwise = a + textFound = go allEmbs + go [] _ = True + go (e:es) i@(row, column) + | (Just (_ :: Int, _)) <- findEmbeddedBitmap [e] super i + = go es (row, column + bitmapWidth e) + | otherwise + = False + +instance (Bitmap a) => BitmapSearchable a + +-- | Binary similarity comparison +-- +-- This function considers two colors to be "similar" if their difference +-- according to the CIE94 algorithm (see 'colorDifferenceCIE94') is less than +-- 23. +areColorsSimilar :: (Pixel p) => p -> p -> Bool +areColorsSimilar a b = + let d :: Double + d = colorDifferenceCIE94 a b + in d <= 23 + +-- | Approximate difference in color according to the CIE94 algorithm +colorDifferenceCIE94 :: (Pixel p, RealFloat n, Ord n) => p -> p -> n +colorDifferenceCIE94 pa pb = + let sq x = x * x + + rgb_ra = (fromIntegral $ red <: pa) / 255.0 + rgb_rb = (fromIntegral $ red <: pb) / 255.0 + rgb_ga = (fromIntegral $ green <: pa) / 255.0 + rgb_gb = (fromIntegral $ green <: pb) / 255.0 + rgb_ba = (fromIntegral $ blue <: pa) / 255.0 + rgb_bb = (fromIntegral $ blue <: pb) / 255.0 + + f x + | x > 0.04045 = 100 * ((x + 0.055) / 1.055) ** 2.4 + | otherwise = 100 * x / 12.92 + + rgb_ra' = f rgb_ra + rgb_rb' = f rgb_rb + rgb_ga' = f rgb_ga + rgb_gb' = f rgb_gb + rgb_ba' = f rgb_ba + rgb_bb' = f rgb_bb + + xa = 0.4124 * rgb_ra' + 0.3576 * rgb_ga' + 0.1805 * rgb_ba' + xb = 0.4124 * rgb_rb' + 0.3576 * rgb_gb' + 0.1805 * rgb_bb' + ya = 0.2126 * rgb_ra' + 0.7152 * rgb_ga' + 0.0722 * rgb_ba' + yb = 0.2126 * rgb_rb' + 0.7152 * rgb_gb' + 0.0722 * rgb_bb' + za = 0.0193 * rgb_ra' + 0.1192 * rgb_ga' + 0.9505 * rgb_ba' + zb = 0.0193 * rgb_rb' + 0.1192 * rgb_gb' + 0.9505 * rgb_bb' + + + g x + | x > 0.008856 = x ** (1/3) + | otherwise = 7.787 * x + 16 / 116 + + xa' = g $ xa / 95.047 + xb' = g $ xb / 95.047 + ya' = g $ ya / 100 + yb' = g $ yb / 100 + za' = g $ za / 108.883 + zb' = g $ zb / 108.883 + + la = (116 * ya') - 16 + lb = (116 * yb') - 16 + aa = 500 * (xa' - ya') + ab = 500 * (xb' - yb') + ba = 200 * (ya' - za') + bb = 200 * (yb' - zb') + + kl = 1 + k1 = 0.045 + k2 = 0.015 + + h r + | r >= 0 = r + | otherwise = 2 * pi - (min 0 $ abs r) + + ca = sqrt (sq aa + sq ba) + cb = sqrt (sq ab + sq bb) + ha = h $ atan2 ba aa + hb = h $ atan2 bb ab + in sqrt $ (sq $ (lb - la) / kl) + (sq $ (cb - ca) / (1 + k1 * ca)) + (sq $ (ha - hb) / (1 + k2 * ca)) + +-- | Default transparent pixel value; FF007E +defaultTransparentPixel :: (Pixel p) => p +defaultTransparentPixel = + (red =: 0xFF) + . (green =: 0x00) + . (blue =: 0x7E) + $ leastIntensity + +matchPixelAny :: (Pixel p) => p +matchPixelAny = leastIntensity + +matchPixelSame :: (Pixel p) => p +matchPixelSame = greatestIntensity + +matchPixelSameThreshold :: (Pixel p) => p +matchPixelSameThreshold = + (red =: 0xFF) + . (green =: 0xFF) + . (blue =: 0x00) + $ leastIntensity + +matchPixelDif :: (Pixel p) => p +matchPixelDif = + (red =: 0xFF) + . (green =: 0x00) + . (blue =: 0x00) + $ leastIntensity + +matchPixelDifThreshold :: (Pixel p) => p +matchPixelDifThreshold = + (red =: 0x00) + . (green =: 0xFF) + . (blue =: 0x00) + $ leastIntensity diff --git a/src/Data/Bitmap/String.hs b/src/Data/Bitmap/String.hs new file mode 100644 --- /dev/null +++ b/src/Data/Bitmap/String.hs @@ -0,0 +1,10 @@ +-- | Bitmaps represented as strings +-- +-- The module provides polymorphic support for representation of bitmaps as strings. +-- This module is designed to be most efficient with lazy bytestrings. + +module Data.Bitmap.String + ( BitmapString + ) where + +import Data.Bitmap.String.Internal diff --git a/src/Data/Bitmap/String/Internal.hs b/src/Data/Bitmap/String/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/Bitmap/String/Internal.hs @@ -0,0 +1,504 @@ +{-# LANGUAGE TemplateHaskell, TypeFamilies #-} + +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.Arrow -- See serializers part of 'BitmapString's 'Bitmap' instance +import Control.Monad.Record +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.Searchable +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 + +-- | A bitmap represented as a string or stored as bytes +-- +-- By default, the RGB32 format (where the most significant byte, the +-- head-most one, is unused) is used. +-- +-- The bitmap must be stored by pixels not separated by component. Each +-- pixel must contain at least the red, blue, and green component, each one +-- byte wide (bytes are assumed to be octets), either in that order or +-- reversed. There may be an alpha component either immediately before the +-- other three components or immediately after. Thus there are four possible +-- arrangements of components for each pixel, which must be consistent for +-- every pixel. Any amount of padding or unused bytes is permitted before each +-- pixel, but the amount must be fixed. The same is true also after each +-- pixel. +-- +-- This type is most efficient with lazy bytestrings. +data BitmapString = BitmapString + { _bmps_data :: S.GenString -- ^ Bitmap data; it is assumed to be large enough + , _bmps_dimensions :: Dimensions (BIndexType BitmapString) -- ^ Width and height of the data; 'bmps_rowFromBeg', etc. need to be taken account for the dimensions of the bitmap + + , _bmps_rowAlignment :: Int -- ^ Each row is aligned to this many bytes; when necessary, null bytes are added to each row + , _bmps_redHead :: Bool -- ^ Whether the red component is first; if 'True', the order of the components is red, green, blue; otherwise, it is blue, green, red + , _bmps_alphaHead :: Maybe Bool -- ^ If 'Nothing', then there is no alpha component; otherwise, if 'True', it is before the other three components (towards the head) / most significant / first, otherwise, it is after the other three components / towards the tail / least significant / last of the four components + , _bmps_paddingHead :: Int -- ^ Number of unused bytes before each pixel + , _bmps_paddingTail :: Int -- ^ Number of unused bytes after each pixel + , _bmps_rowFromTop :: Bool -- ^ Is the first row at the top? + , _bmps_columnFromLeft :: Bool -- ^ Is the first column in each row at the left? + , _bmps_rowFromBeg :: Int -- ^ How many rows of data to skip from the beginning (from *first* row); used in cropping + , _bmps_rowFromEnd :: Int -- ^ How many rows of data to skip from the end; used in cropping + , _bmps_columnFromBeg :: Int + , _bmps_columnFromEnd :: Int + } + +mkLabels [''BitmapString] + +-- The data is serialized as a lazy bytestring +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 + +-- The data is serialized as a lazy bytestring +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 + +-- | Default 'BitmapString' format +-- +-- This is equivalent to 'IBF_BGRU32' +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 + } + +-- | Return (rowSize, paddingSize) based on width, bytes per pixel, and alignment +-- +-- Be careful when using the results of this function that you're actually using the right value. +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 + +-- | Return (rowSize, paddingSize) +-- +-- Be careful when using the results of this function that you're actually using the right value. +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 + +-- | Get part of a pixel as a cell of 'GenStringDefault' +-- +-- The bitmap passed is only used for its format; its dimensions and data are not used. +-- This function doesn't return any alpha parts; for those it returns pad bytes, which are +-- zero. +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) + +-- | Construct a bitmap in the format of the meta bitmap passed +-- +-- Only the format fields of the bitmap is used, so the data and dimensions of it can be 'undefined'. +-- +-- The data in the new bitmap is what 'GenStringDefault' is aliased to. +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) + + -- FIXME: sometimes the bitmaps are upside-down + {- + imageEncoders = updateIdentifiableElements (map (second unwrapGenericBitmapSerializer) defaultImageEncoders) $ + [ (IBF_BGR24A4VR, ImageEncoder $ encodeIBF_BGR24A4VR') + , (IBF_RGB24A4VR, ImageEncoder $ encodeIBF_RGB24A4VR') + , (IBF_RGB24A4, ImageEncoder $ encodeIBF_RGB24A4') + , (IBF_RGB32, ImageEncoder $ encodeIBF_RGB32') + ] + + imageDecoders = updateIdentifiableElements (map (second unwrapGenericBitmapSerializer) defaultImageDecoders) $ + [ (IBF_BGR24A4VR, ImageDecoder $ tryIBF_BGR24A4VR') + , (IBF_RGB24A4VR, ImageDecoder $ tryIBF_RGB24A4VR') + , (IBF_RGB24A4, ImageDecoder $ tryIBF_RGB24A4') + , (IBF_RGB32, ImageDecoder $ tryIBF_RGB32') + ] + -} + +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 + } + +-- | Used by the encoders +encodeBSFormat :: (S.StringCells s) => BitmapString -> (BitmapString -> s) +encodeBSFormat bsFmt = S.toStringCells . (bmps_data <:) . convertInternalFormat bsFmt + +encodeIBF_BGR24A4VR' :: (S.StringCells s) => BitmapString -> s +encodeIBF_BGR24A4VR' = encodeBSFormat bitmapFmtBGR24A4VR + +encodeIBF_RGB24A4VR' :: (S.StringCells s) => BitmapString -> s +encodeIBF_RGB24A4VR' = encodeBSFormat bitmapFmtRGB24A4VR + +encodeIBF_RGB24A4' :: (S.StringCells s) => BitmapString -> s +encodeIBF_RGB24A4' = encodeBSFormat bitmapFmtRGB24A4 + +encodeIBF_RGB32' :: (S.StringCells s) => BitmapString -> s +encodeIBF_RGB32' = encodeBSFormat bitmapFmtRGB32 + +-- | Used by the decoders +tryBSFormat :: (S.StringCells 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.StringCells s) => BitmapString -> s -> Either String BitmapString +tryIBF_BGR24A4VR' = tryBSFormat "tryIBF_BGR24A4VR'" bitmapFmtBGR24A4VR + +tryIBF_RGB24A4VR' :: (S.StringCells s) => BitmapString -> s -> Either String BitmapString +tryIBF_RGB24A4VR' = tryBSFormat "tryIBF_RGB24A4VR'" bitmapFmtRGB24A4VR + +tryIBF_RGB24A4' :: (S.StringCells s) => BitmapString -> s -> Either String BitmapString +tryIBF_RGB24A4' = tryBSFormat "tryIBF_RGB24A4'" bitmapFmtRGB24A4 + +tryIBF_RGB32' :: (S.StringCells s) => BitmapString -> s -> Either String BitmapString +tryIBF_RGB32' = tryBSFormat "tryIBF_RGB32'" bitmapFmtRGB32 + +{- +-- TODO: work with crop as well +instance BitmapSearchable BitmapString where + findSubBitmapEqual super sub_unformatted = + let sub = convertInternalFormat super sub_unformatted + (widthSuper, heightSuper) = bmps_dimensions <: super + (widthSub, heightSub) = bmps_dimensions <: sub + dataSuper = bmps_data <: super + dataSub = bmps_data <: sub + superRowSize = fst $ rowPaddingBS super + subRowSize = fst $ rowPaddingBS sub + superPixelSize = bytesPerPixel super + maxSuperRow = heightSuper - heightSub + maxSuperColumn = widthSuper - widthSub + maxOffRow = abs . pred $ heightSub + offRowSize = subRowSize - (snd $ rowPaddingBS 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 * superRowSize + superPixelSize * column + matches offRow + | offRow > maxOffRow + = True + | subStr (superBaseIndex + offRow * superRowSize) offRowSize dataSuper /= + subStr (offRow * subRowSize) offRowSize dataSub + = False + | otherwise + = matches (succ offRow) + in r' +-} + +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 diff --git a/src/Data/Bitmap/StringRGB24A4VR.hs b/src/Data/Bitmap/StringRGB24A4VR.hs new file mode 100644 --- /dev/null +++ b/src/Data/Bitmap/StringRGB24A4VR.hs @@ -0,0 +1,12 @@ +-- | This bitmap type is deprecated; use 'Data.Bitmap.String' instead +-- +-- Bitmaps represented as strings +-- +-- The module provides polymorphic support for representation of bitmaps as strings. +-- This module is designed to be most efficient with lazy bytestrings. + +module Data.Bitmap.StringRGB24A4VR {-# DEPRECATED "Use Data.Bitmap.String instead" #-} + ( BitmapStringRGB24A4VR + ) where + +import Data.Bitmap.StringRGB24A4VR.Internal diff --git a/src/Data/Bitmap/StringRGB24A4VR/Internal.hs b/src/Data/Bitmap/StringRGB24A4VR/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/Bitmap/StringRGB24A4VR/Internal.hs @@ -0,0 +1,182 @@ +{-# 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 +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 diff --git a/src/Data/Bitmap/StringRGB32.hs b/src/Data/Bitmap/StringRGB32.hs new file mode 100644 --- /dev/null +++ b/src/Data/Bitmap/StringRGB32.hs @@ -0,0 +1,12 @@ +-- | This bitmap type is deprecated; use 'Data.Bitmap.String' instead +-- +-- | Bitmaps represented as strings +-- +-- The module provides polymorphic support for representation of bitmaps as strings. +-- This module is designed to be most efficient with lazy bytestrings. + +module Data.Bitmap.StringRGB32 {-# DEPRECATED "Use Data.Bitmap.String instead" #-} + ( BitmapStringRGB32 + ) where + +import Data.Bitmap.StringRGB32.Internal diff --git a/src/Data/Bitmap/StringRGB32/Internal.hs b/src/Data/Bitmap/StringRGB32/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/Bitmap/StringRGB32/Internal.hs @@ -0,0 +1,146 @@ +{-# LANGUAGE TemplateHaskell, TypeFamilies, ExistentialQuantification, TypeOperators, ScopedTypeVariables, TupleSections #-} + +module Data.Bitmap.StringRGB32.Internal + ( BitmapImageString(..) + , BitmapStringRGB32(..), bmps_dimensions, bmps_data + , encodeIBF_RGB32' + , tryIBF_RGB32' + , padByte + ) 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 + +-- | Polymorphic container of a string +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, which contains a series of aligned rows, which themselves consist of a series of pixels stored in 4 bytes in which the most significant byte is unused (thus the rows are always aligned to a four-byte boundary) +data BitmapStringRGB32 = BitmapStringRGB32 + { _bmps_dimensions :: (Int, Int) -- ^ Width and height of the bitmap + , _bmps_data :: BitmapImageString -- ^ Data stored in a string + } + +mkLabels [''BitmapStringRGB32] + +instance Binary BitmapStringRGB32 where + get = pure BitmapStringRGB32 <*> 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 BitmapStringRGB32 where + get = pure BitmapStringRGB32 <*> 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 BitmapStringRGB32 where + type BIndexType BitmapStringRGB32 = Int + type BPixelType BitmapStringRGB32 = PixelRGB + + depth = const Depth24RGB + + dimensions = (bmps_dimensions <:) + + getPixel b (row, column) = + let (width, _) = bmps_dimensions <: b + bytesPixel = 4 + bytesRow = 4 * width + offset = bytesRow * row + bytesPixel * column + in case bmps_data <: b of + (BitmapImageString s) -> + PixelRGB $ ((fromIntegral . S.toWord8 $ s `S.index` (offset + 1)) `shiftL` 16) .|. + ((fromIntegral . S.toWord8 $ s `S.index` (offset + 2)) `shiftL` 8) .|. + ((fromIntegral . S.toWord8 $ s `S.index` (offset + 3))) + + constructPixels f dms@(width, height) = BitmapStringRGB32 dms . (BitmapImageString :: B.ByteString -> BitmapImageString) $ + S.unfoldrN (4 * width * height) getComponent (0 :: Int, 0 :: Int, 0 :: Int) + where getComponent (row, column, orgb) + | orgb > 3 = + getComponent (row, succ column, 0) + | column > maxColumn = + getComponent (succ row, 0, 0) + | row > maxRow = + Nothing + | otherwise = + let pixel = f (row, column) + componentGetter = + case orgb of + 0 -> const padCell + 1 -> untag' . S.toMainChar . (red <:) + 2 -> untag' . S.toMainChar . (green <:) + 3 -> untag' . S.toMainChar . (blue <:) + _ -> undefined + in Just (componentGetter pixel, (row, column, succ orgb)) + maxRow = abs . pred $ height + maxColumn = abs . pred $ width + padCell = untag' . S.toMainChar $ padByte + untag' = untag :: Tagged B.ByteString a -> a + + imageEncoders = updateIdentifiableElements (map (second unwrapGenericBitmapSerializer) defaultImageEncoders) $ + [ (IBF_RGB32, ImageEncoder $ encodeIBF_RGB32') + ] + + imageDecoders = updateIdentifiableElements (map (second unwrapGenericBitmapSerializer) defaultImageDecoders) $ + [ (IBF_RGB32, ImageDecoder $ tryIBF_RGB32') + ] + +encodeIBF_RGB32' :: (S.StringCells s) => BitmapStringRGB32 -> s +encodeIBF_RGB32' b = case (bmps_data <: b) of (BitmapImageString s) -> S.fromStringCells s + +tryIBF_RGB32' :: (S.StringCells s) => BitmapStringRGB32 -> s -> Either String BitmapStringRGB32 +tryIBF_RGB32' bmp s + | S.length s < minLength = Left $ printf "Data.Bitmap.StringRGB32.Internal.tryIBF_RGB32': 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 = 4 * width * height + +padByte :: Word8 +padByte = 0x00 + +instance BitmapSearchable BitmapStringRGB32 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 = 4 * widthSuper + subBytesPerRow = 4 * widthSub + maxSuperRow = heightSuper - heightSub + maxSuperColumn = widthSuper - widthSub + maxOffRow = abs . pred $ heightSub + + r' i@(row, column) + | column > maxSuperColumn = + r' (succ row, 0) + | row > maxSuperRow = + Nothing + | matches 0 = + Just i + | otherwise = + r' (row, succ column) + where superBaseIndex = row * superBytesPerRow + 4 * column + matches offRow + | offRow > maxOffRow = True + | (S.toStringCells :: S.StringCells s => s -> B.ByteString) (subStr (superBaseIndex + offRow * superBytesPerRow) subBytesPerRow dataSuper) /= (S.toStringCells :: (S.StringCells s) => s -> B.ByteString) (subStr (offRow * subBytesPerRow) subBytesPerRow dataSub) = + False + | otherwise = matches (succ offRow) + in r' + +instance BitmapReflectable BitmapStringRGB32 diff --git a/src/Data/Bitmap/Types.hs b/src/Data/Bitmap/Types.hs new file mode 100644 --- /dev/null +++ b/src/Data/Bitmap/Types.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE DeriveDataTypeable #-} + +module Data.Bitmap.Types + ( Dimensions + , Coordinates + , Depth(..) + , CompleteBitmapFormat(..) + , ImageBitmapFormat(..) + ) where + +import Data.Data + +type Dimensions i = (i, i) +type Coordinates i = (i, i) + +-- | These are the color depths that the bitmap class supports +-- +-- The depth does not necessarily indicate any particular order; instead the +-- components listed in the name indicate which components are contained in +-- each pixel. +-- +-- The order in which the constructors are defined is significant; it determines +-- which match 'mostLikelyMatchCBF' will choose. +data Depth = + Depth24RGB -- ^ 24 bit pixel consisting of one pixel per component and lacking an alpha component + -- + -- Each pixel of this type thus requires three bytes to be fully represented. Implementations + -- are not required to pack the image data, however; they are free, for instance, to store each pixel + -- in 32-bit (4-byte) integers. + | Depth32RGBA -- ^ 32 bit pixel also consisting of one pixel per component but contains the alpha component + -- + -- Four bytes are needed for pixels of this type to be fully represented. + deriving (Eq, Ord, Enum, Bounded, Show, Read, Typeable, Data) + +-- | Formats that bitmaps that are instances of the 'Bitmap' class need to support; these formats include the necessary meta-information +data CompleteBitmapFormat = + CBF_BMPIU -- ^ Uncompressed BITMAPINFOHEADER BMP format (CompleteBitmapFormat_BitMaPInfoheaderUncompressed) + -- + -- The image format of this format is 'IBF_BGR24A4VR' + -- + -- Due to being uncompressed, strings encoded in this format can grow large quite quickly. + -- This format is standard and widely supported, and can be written directly to a file, the extension + -- of which is typically ".bmp" + -- + -- This format is one possible format for "bmp" files. + | CBF_BMPIU64 -- ^ Same as 'CBF_BMPIU' except that that final result is base-64 encoded and is thus suitable for human-readable strings defining a small bitmap (CompleteBitmapFormat_BitMaPInfoheaderUncompressed) + -- + -- Like 'CBF_BMPIU', strings encoded in this format can become large quick quickly, and even about a third more so, due to the more restrictive range of values. + | CBF_BMPIUZ64 -- Similar to CBF_BMPIU except that the encoded string is compressed before it is base-64 encoded + | CBF_BMPIUU -- ^ Similar to CBF_BMPIU, but internally the pixel data is stored in the 'IBF_BGRU32VR' format instead of 'IBF_BGR24A4VR' + -- + -- This format is another common format of "bmp" files. + deriving (Eq, Ord, Enum, Bounded, Show, Read, Typeable, Data) + +-- | Formats for raw image data that don't include information such as dimensions +data ImageBitmapFormat = + IBF_IDRGB24Z64 -- ^ Series of red, green, and blue; the string is compressed and then base-64 encoded; the encoded string is prepended with an 'm' for simpler identification + | IBF_IDBGR24R2RZ64 -- ^ Series of blue, green, and red, that is rotated two bytes right; the string is compressed and then base-64 encoded; the encoded string is prepended with a 'b' for simpler identification + | IBF_IDBGR24HZH -- ^ Series of red, green, and blue; the string is hex encoded, then compressed, then hex encoded again; the encoded string is prepended with with 'z' + | IBF_IDRGB32Z64 -- ^ Series of unused byte, red, green, and blue; the string is compressed and then base-64 encoded; identified by an 'l' character + | IBF_BGR24H -- ^ Series of red, green, and blue, represented as a series of hexadecimal pairs + | IBF_BGR24A4VR -- ^ Series of blue, green, red, blue, etc. with a row alignment of 4, stored upside-down + | IBF_BGRU32VR -- ^ Series of blue, green, red, unused, blue, etc. stored upside-down (already aligned to a 4-byte boundary) + | IBF_BGRU32 -- ^ Series of blue, green, red, unused, blue, etc. (already aligned to a 4-byte boundary) + | IBF_RGB24A4VR -- ^ Series of red, green, blue, red, etc. with a row alignment of 4, stored upside-down + | IBF_RGB24A4 -- ^ Series of red, green, blue, red, etc. with a row alignment of 4 + | IBF_RGB32 -- ^ Series of unused byte, red, green, and blue + | IBF_RGB32Z64 -- ^ Series of unused byte, red, green, and blue; the string is compressed and then base-64 encoded + deriving (Eq, Ord, Enum, Bounded, Show, Read, Typeable, Data) diff --git a/src/Data/Bitmap/Util.hs b/src/Data/Bitmap/Util.hs new file mode 100644 --- /dev/null +++ b/src/Data/Bitmap/Util.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +-- | This module is unstable; functions are not guaranteed to be the same or even to exist in future versions +-- +-- It is intended primarily for use by this library itself. +module Data.Bitmap.Util + ( tablespoon + , subStr + , padByte + ) where + +import Control.Exception +import qualified Data.String.Class as S +import Data.Word +import System.IO.Unsafe (unsafePerformIO) + +handlers :: [Handler (Either String a)] +handlers = [ Handler $ \(e :: ArithException) -> return . Left . show $ e + , Handler $ \(e :: ArrayException) -> return . Left . show $ e + , Handler $ \(e :: ErrorCall) -> return . Left . show $ e + , Handler $ \(e :: PatternMatchFail) -> return . Left . show $ e + , Handler $ \(e :: SomeException) -> throwIO e + ] + +-- | Hack to catch "pureish" asynchronous errors +-- +-- This is only used as a workaround to the binary library's shortcoming of +-- using asynchronous errors instead of pure error handling, and also zlib's +-- same shortcoming. +-- +-- This function is similar to the @spoon@ package's @teaspoon@ function, +-- except that it can return more information when an exception is caught. +tablespoon :: a -> Either String a +tablespoon x = unsafePerformIO $ (Right `fmap` evaluate x) `catches` handlers + +-- | Return a substring +-- +-- 'subStr' @index@ @length@ returns @length@ characters from the string +-- starting at @index@, which starts at 0. +-- +-- > subStr 1 2 "abcd" == "bc" +subStr :: (S.StringCells s) => Int -> Int -> s -> s +subStr index length_ = S.take length_ . S.drop index + +padByte :: Word8 +padByte = 0x00