bitmaps-0.2.5.1: src/Data/Bitmap/Searchable.hs
{-# 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