{-# LINE 1 "src/PerceptualHash.cpphs" #-}
# 1 "src/PerceptualHash.cpphs"
# 1 "<built-in>"
# 1 "<command-line>"
# 13 "<command-line>"
# 1 "/usr/include/stdc-predef.h" 1 3 4
# 17 "/usr/include/stdc-predef.h" 3 4
# 13 "<command-line>" 2
# 1 "./dist/build/autogen/cabal_macros.h" 1
# 13 "./dist/build/autogen/cabal_macros.h"
# 23 "./dist/build/autogen/cabal_macros.h"
# 33 "./dist/build/autogen/cabal_macros.h"
# 43 "./dist/build/autogen/cabal_macros.h"
# 53 "./dist/build/autogen/cabal_macros.h"
# 63 "./dist/build/autogen/cabal_macros.h"
# 73 "./dist/build/autogen/cabal_macros.h"
# 83 "./dist/build/autogen/cabal_macros.h"
# 94 "./dist/build/autogen/cabal_macros.h"
# 104 "./dist/build/autogen/cabal_macros.h"
# 114 "./dist/build/autogen/cabal_macros.h"
# 124 "./dist/build/autogen/cabal_macros.h"
# 134 "./dist/build/autogen/cabal_macros.h"
# 144 "./dist/build/autogen/cabal_macros.h"
# 154 "./dist/build/autogen/cabal_macros.h"
# 164 "./dist/build/autogen/cabal_macros.h"
# 174 "./dist/build/autogen/cabal_macros.h"
# 184 "./dist/build/autogen/cabal_macros.h"
# 194 "./dist/build/autogen/cabal_macros.h"
# 204 "./dist/build/autogen/cabal_macros.h"
# 214 "./dist/build/autogen/cabal_macros.h"
# 13 "<command-line>" 2
# 1 "/home/builder/.ghcup/ghc/9.2.4/lib/ghc-9.2.4/include/ghcversion.h" 1
# 13 "<command-line>" 2
# 1 "/tmp/ghc3952244_0/ghc_2.h" 1
# 13 "<command-line>" 2
# 1 "src/PerceptualHash.cpphs"
{-# OPTIONS_GHC -fspecialize-aggressively #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
module PerceptualHash ( imgHash
, fileHash
, hammingDistance
) where
import qualified Codec.Picture as JuicyPixels
import Control.Monad.ST (runST)
import Data.Bits (Bits, popCount, shiftL, xor, (.|.))
import qualified Data.ByteString as BS
import Data.List (isSuffixOf)
import qualified Data.Vector.Generic as V
import qualified Data.Vector.Storable as VS
import Data.Word (Word64, Word8)
import Graphics.Image (Array, Bilinear (..), Border (Edge, Reflect), Image,
Pixel (PixelX, PixelY), RGB, RGBA, RSU (..), VS, X,
Y, convert, convolve, crop, makeImage, readImage,
resize, transpose, (|*|))
import Graphics.Image.Interface (fromVector, toVector)
import qualified Graphics.Image.Interface as Hip
import Graphics.Image.Interface.Repa (fromRepaArrayS, toRepaArray)
import Median (median)
{-# SPECIALIZE hammingDistance :: Word64 -> Word64 -> Int #-}
hammingDistance :: Bits a => a -> a -> Int
hammingDistance x y = popCount (x `xor` y)
dct32 :: (Floating e, Array arr Y e) => Image arr Y e
dct32 = makeImage (32,32) gen
where gen (i,j) = PixelY $ sqrt(2/n) * cos((fromIntegral (i * (j-1)) * pi)/n)
n = 32
idMat :: (Fractional e, Array arr X e) => Image arr X e
idMat = makeImage (7,7) (\_ -> PixelX (1/49))
{-# INLINE meanFilter #-}
meanFilter :: (Fractional e, Array arr X e, Array arr cs e) => Image arr cs e -> Image arr cs e
meanFilter = {-# SCC "meanFilter" #-} convolve Reflect idMat
{-# INLINE size32 #-}
size32 :: Array arr cs e => Image arr cs e -> Image arr cs e
size32 = resize Bilinear Edge (32,32)
crop8 :: Array arr cs e => Image arr cs e -> Image arr cs e
crop8 = crop (0,0) (8,8)
medianImmut :: (Ord e, Fractional e, V.Vector v e) => v e -> e
medianImmut v = runST $
median =<< V.thaw v
dct :: (Floating e, Array arr Y e) => Image arr Y e -> Image arr Y e
dct img = dct32 |*| img |*| transpose dct32
{-# INLINE imgHash #-}
imgHash :: (Ord e, Floating e, Array arr Y e, Array arr X e, V.Vector (Hip.Vector arr) Bool, V.Vector (Hip.Vector arr) e) => Image arr Y e -> Word64
imgHash = asWord64 . aboveMed . V.map (\(PixelY x) -> x) . toVector . crop8 . dct . size32 . meanFilter
asWord64 :: V.Vector v Bool => v Bool -> Word64
asWord64 = V.foldl' (\acc x -> (acc `shiftL` 1) .|. boolToWord64 x) 0
where boolToWord64 :: Bool -> Word64
boolToWord64 False = 0
boolToWord64 True = 1
aboveMed :: (Fractional e, V.Vector v e, V.Vector v Bool, Ord e) => v e -> v Bool
aboveMed v =
let med = medianImmut v
in V.map (<med) v
# 103 "src/PerceptualHash.cpphs"
fileHash :: FilePath -> IO (Either String Word64)
fileHash fp
| otherwise = fileHashHip fp
# 129 "src/PerceptualHash.cpphs"
fileHashHip :: FilePath -> IO (Either String Word64)
fileHashHip = fmap (fmap (imgHash :: Image RSU Y Double -> Word64)) . readImage