packages feed

bitmaps (empty) → 0.2.5.1

raw patch · 24 files changed

+3365/−0 lines, 24 filesdep +arraydep +basedep +binarysetup-changed

Dependencies added: array, base, binary, bitmap, bytestring, cereal, containers, monad-state, stb-image, string-class, tagged, zlib

Files

+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ bitmaps.cabal view
@@ -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
+ src/Codec/String/Base16.hs view
@@ -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
+ src/Codec/String/Base64.hs view
@@ -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
+ src/Data/Bitmap/Array.hs view
@@ -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
+ src/Data/Bitmap/Array/Internal.hs view
@@ -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)]
+ src/Data/Bitmap/BMP.hs view
@@ -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
+ src/Data/Bitmap/Class.hs view
@@ -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
+ src/Data/Bitmap/Croppable.hs view
@@ -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
+ src/Data/Bitmap/Foreign.hs view
@@ -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
+ src/Data/Bitmap/Function.hs view
@@ -0,0 +1,7 @@+-- | Bitmaps defined by functions++module Data.Bitmap.Function+    ( BitmapFunction+    ) where++import Data.Bitmap.Function.Internal
+ src/Data/Bitmap/Function/Internal.hs view
@@ -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
+ src/Data/Bitmap/Pixel.hs view
@@ -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
+ src/Data/Bitmap/Reflectable.hs view
@@ -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
+ src/Data/Bitmap/Searchable.hs view
@@ -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
+ src/Data/Bitmap/String.hs view
@@ -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
+ src/Data/Bitmap/String/Internal.hs view
@@ -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
+ src/Data/Bitmap/StringRGB24A4VR.hs view
@@ -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
+ src/Data/Bitmap/StringRGB24A4VR/Internal.hs view
@@ -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
+ src/Data/Bitmap/StringRGB32.hs view
@@ -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
+ src/Data/Bitmap/StringRGB32/Internal.hs view
@@ -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
+ src/Data/Bitmap/Types.hs view
@@ -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)
+ src/Data/Bitmap/Util.hs view
@@ -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