{-# 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