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 (Bitmap bmp) => BitmapSearchable bmp where
foldrCoords ::
(Coordinates (BIndexType bmp) -> a -> a)
-> a
-> Coordinates (BIndexType bmp)
-> Coordinates (BIndexType bmp)
-> bmp
-> a
findPixel ::
(BPixelType bmp -> Bool)
-> bmp
-> Maybe (Coordinates (BIndexType bmp))
findPixelOrder ::
(BPixelType bmp -> Bool)
-> bmp
-> Coordinates (BIndexType bmp)
-> Maybe (Coordinates (BIndexType bmp))
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)]
findSubBitmap ::
(BPixelType bmp -> BPixelType bmp -> Bool)
-> bmp
-> bmp
-> Maybe (Coordinates (BIndexType bmp))
findSubBitmapOrder ::
(BPixelType bmp -> BPixelType bmp -> Bool)
-> bmp
-> bmp
-> Coordinates (BIndexType bmp)
-> Maybe (Coordinates (BIndexType bmp))
findSubBitmapEqual ::
bmp
-> bmp
-> Coordinates (BIndexType bmp)
-> Maybe (Coordinates (BIndexType bmp))
findSubBitmaps ::
(BPixelType bmp -> BPixelType bmp -> Bool)
-> bmp
-> bmp
-> Coordinates (BIndexType bmp)
-> [(Coordinates (BIndexType bmp))]
findSubBitmapsEqual ::
bmp
-> bmp
-> Coordinates (BIndexType bmp)
-> [(Coordinates (BIndexType bmp))]
findEmbeddedBitmap ::
(Integral i)
=> [bmp]
-> bmp
-> Coordinates (BIndexType bmp)
-> Maybe (i, bmp)
findEmbeddedBitmapString ::
(Integral i)
=> ((i, bmp) -> a -> a)
-> a
-> [bmp]
-> bmp
-> Coordinates (BIndexType bmp)
-> a
findFixedEmbeddedBitmapString ::
Dimensions (Maybe (BIndexType bmp))
-> [bmp]
-> bmp
-> 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
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
= (True, matchColor, difColors, dftColors, thrsColors)
| True <- subPixel == pixSame
, (Just matchColor') <- matchColor
= (superPixel == matchColor', matchColor, difColors, dftColors, thrsColors)
| True <- subPixel == pixSame
= ((not $ superPixel `elem` difColors) && (not $ any (`areColorsSimilar` superPixel) dftColors) && (all (`areColorsSimilar` superPixel) thrsColors), Just superPixel, [], [], [])
| True <- subPixel == pixDif
, (Just matchColor') <- matchColor
= (superPixel /= matchColor', matchColor, difColors, dftColors, thrsColors)
| True <- subPixel == pixDif
= (True, matchColor, nub $ superPixel : difColors, dftColors, thrsColors)
| True <- subPixel == pixDft
, (Just matchColor') <- matchColor
= (not $ superPixel `areColorsSimilar` matchColor', matchColor, difColors, dftColors, thrsColors)
| True <- subPixel == pixDft
= (True, matchColor, difColors, nub $ superPixel : dftColors, thrsColors)
| True <- subPixel == pixThrs
, (Just matchColor') <- matchColor
= (superPixel `areColorsSimilar` matchColor', matchColor, difColors, dftColors, thrsColors)
| True <- subPixel == pixThrs
= (True, matchColor, difColors, dftColors, nub $ superPixel : thrsColors)
| otherwise
= (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
areColorsSimilar :: (Pixel p) => p -> p -> Bool
areColorsSimilar a b =
let d :: Double
d = colorDifferenceCIE94 a b
in d <= 23
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))
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