43 lines
1.5 KiB
Haskell
43 lines
1.5 KiB
Haskell
{-# LANGUAGE RankNTypes #-}
|
|
{-# LANGUAGE LambdaCase #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
module Image.Fingerprint where
|
|
import Data.Word (Word64)
|
|
import Codec.Picture.Types
|
|
import qualified Data.Foldable as F
|
|
import qualified Data.Vector as V
|
|
import Data.Bits (Bits(..))
|
|
import Data.Bool (bool)
|
|
import Codec.Picture.Extra (scaleBilinear)
|
|
import Data.Maybe (fromMaybe)
|
|
import Codec.Picture (convertRGB16, readImage)
|
|
|
|
dhash :: FilePath -> IO (Either String Word64)
|
|
dhash path = fmap (dynamicMap' process) <$> readImage path
|
|
|
|
process :: (LumaPlaneExtractable a, Pixel a, Bounded (PixelBaseComponent a), Integral (PixelBaseComponent a)) => Image a -> Word64
|
|
process img = hash
|
|
where
|
|
hash = F.foldl' (\acc x -> (acc `shiftL` 1) .|. bool 0 1 x) 0 bits
|
|
bits = V.concat [V.generate 8 (\x -> pixelAt scaled x y < pixelAt scaled (x+1) y) | y <- [0..7]]
|
|
scaled = extractLumaPlane . scaleBilinear 9 8 $ img
|
|
|
|
dynamicMap' :: (forall x. (Bounded (PixelBaseComponent x), Integral (PixelBaseComponent x), LumaPlaneExtractable x) => Image x -> a) -> DynamicImage -> a
|
|
dynamicMap' f d = fromMaybe (f (convertRGB16 d)) (go d)
|
|
where
|
|
go = \case
|
|
ImageY8 i -> Just $ f i
|
|
ImageY16 i -> Just $ f i
|
|
ImageY32 i -> Just $ f i
|
|
ImageYF _ -> Nothing
|
|
ImageYA8 i -> Just $ f i
|
|
ImageYA16 _ -> Nothing
|
|
ImageRGB8 i -> Just $ f i
|
|
ImageRGB16 i -> Just $ f i
|
|
ImageRGBF _ -> Nothing
|
|
ImageRGBA8 i -> Just $ f i
|
|
ImageRGBA16 _ -> Nothing
|
|
ImageYCbCr8 i -> Just $ f i
|
|
ImageCMYK8 _ -> Nothing
|
|
ImageCMYK16 _ -> Nothing
|