diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,10 @@ # phash +## 0.1.4.3 + + * Add `disable-webp` flag + * Better performance on `.webp` images + ## 0.1.4.2 * Detect `.webp` on the command-line diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright Vanessa McHale (c) 2019-2020 +Copyright Vanessa McHale (c) 2019-2021 Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: diff --git a/app/Parallel.cpphs b/app/Parallel.cpphs new file mode 100644 --- /dev/null +++ b/app/Parallel.cpphs @@ -0,0 +1,54 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +module Parallel ( pathMaps ) where + +import Control.Concurrent.STM (atomically) +import Control.Concurrent.STM.TVar (TVar, modifyTVar', newTVarIO, readTVarIO) +import Data.Functor (($>)) +import Data.List.NonEmpty (NonEmpty (..), (<|)) +import qualified Data.Map as M +import Data.Word (Word64) +import PerceptualHash (fileHash) +import System.Directory.Parallel (parTraverseAll) +import System.FilePath (takeExtension) + +imgExtension :: String -> Bool +imgExtension ".jpg" = True +imgExtension ".jpeg" = True +imgExtension ".png" = True +imgExtension ".gif" = True +imgExtension ".hdr" = True +imgExtension ".pic" = True +imgExtension ".bmp" = True +imgExtension ".TGA" = True +imgExtension ".tga" = True +imgExtension ".tif" = True +imgExtension ".tiff" = True +#ifdef WEBP +imgExtension ".webp" = True +#endif +imgExtension _ = False + +insertHash :: FilePath -> IO (M.Map Word64 (NonEmpty FilePath) -> M.Map Word64 (NonEmpty FilePath)) +insertHash fp = do + hash <- fileHash fp + case hash of + Right x -> + pure $ \hashes -> + let go (Just others) = Just (fp <| others) + go Nothing = Just (fp :| []) + in M.alter go x hashes + Left err -> putStrLn ("WARNING: skipping " ++ fp ++ "\n" ++ err) $> id + +stepMap :: TVar (M.Map Word64 (NonEmpty FilePath)) -> FilePath -> IO () +stepMap var fp = do + mod' <- insertHash fp + atomically $ modifyTVar' var mod' + +pathMaps :: [FilePath] -> IO (M.Map Word64 (NonEmpty FilePath)) +pathMaps fps = do + total <- newTVarIO mempty + parTraverseAll (stepMap total) fileFilter (\_ -> pure True) fps + readTVarIO total + + where fileFilter = pure . imgExtension . takeExtension diff --git a/app/Parallel.hs b/app/Parallel.hs deleted file mode 100644 --- a/app/Parallel.hs +++ /dev/null @@ -1,52 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} - -module Parallel ( pathMaps ) where - -import Control.Concurrent.STM (atomically) -import Control.Concurrent.STM.TVar (TVar, modifyTVar', newTVarIO, readTVarIO) -import Data.Functor (($>)) -import Data.List.NonEmpty (NonEmpty (..), (<|)) -import qualified Data.Map as M -import Data.Word (Word64) -import PerceptualHash (fileHash) -import System.Directory.Parallel (parTraverseAll) -import System.FilePath (takeExtension) - -imgExtension :: String -> Bool -imgExtension ".jpg" = True -imgExtension ".jpeg" = True -imgExtension ".png" = True -imgExtension ".gif" = True -imgExtension ".hdr" = True -imgExtension ".pic" = True -imgExtension ".bmp" = True -imgExtension ".TGA" = True -imgExtension ".tga" = True -imgExtension ".tif" = True -imgExtension ".tiff" = True -imgExtension ".webp" = True -imgExtension _ = False - -insertHash :: FilePath -> IO (M.Map Word64 (NonEmpty FilePath) -> M.Map Word64 (NonEmpty FilePath)) -insertHash fp = do - hash <- fileHash fp - case hash of - Right x -> - pure $ \hashes -> - let go (Just others) = Just (fp <| others) - go Nothing = Just (fp :| []) - in M.alter go x hashes - Left err -> putStrLn ("WARNING: skipping " ++ fp ++ "\n" ++ err) $> id - -stepMap :: TVar (M.Map Word64 (NonEmpty FilePath)) -> FilePath -> IO () -stepMap var fp = do - mod' <- insertHash fp - atomically $ modifyTVar' var mod' - -pathMaps :: [FilePath] -> IO (M.Map Word64 (NonEmpty FilePath)) -pathMaps fps = do - total <- newTVarIO mempty - parTraverseAll (stepMap total) fileFilter (\_ -> pure True) fps - readTVarIO total - - where fileFilter = pure . imgExtension . takeExtension diff --git a/perceptual-hash.cabal b/perceptual-hash.cabal --- a/perceptual-hash.cabal +++ b/perceptual-hash.cabal @@ -1,9 +1,9 @@ cabal-version: 2.0 name: perceptual-hash -version: 0.1.4.2 +version: 0.1.4.3 license: BSD3 license-file: LICENSE -copyright: Copyright: (c) 2019-2020 Vanessa McHale +copyright: Copyright: (c) 2019-2021 Vanessa McHale maintainer: vamchale@gmail.com author: Vanessa McHale synopsis: Find duplicate images @@ -33,28 +33,38 @@ default: False manual: True +flag disable-webp + description: Don't depend on webp FFI bindings + default: False + flag llvm description: Use LLVM backend to GHC rather than NCG default: False manual: True library - exposed-modules: PerceptualHash - hs-source-dirs: src - other-modules: Median - default-language: Haskell2010 - other-extensions: FlexibleContexts TypeFamilies - ghc-options: -Wall -O2 + exposed-modules: PerceptualHash + build-tool-depends: cpphs:cpphs + hs-source-dirs: src + other-modules: Median + default-language: Haskell2010 + other-extensions: FlexibleContexts TypeFamilies + ghc-options: -Wall -O2 build-depends: base >=4.8 && <5, hip, vector-algorithms, vector, primitive, - webp, bytestring, JuicyPixels + if !flag(disable-webp) + build-depends: webp + + if !flag(disable-webp) + cpp-options: -DWEBP + if flag(llvm) ghc-options: -fllvm @@ -104,17 +114,18 @@ ghc-options: -Wunused-packages executable phash - main-is: Main.hs - hs-source-dirs: app + main-is: Main.hs + build-tool-depends: cpphs:cpphs + hs-source-dirs: app other-modules: Paths_perceptual_hash Parser Parallel - autogen-modules: Paths_perceptual_hash - default-language: Haskell2010 - other-extensions: ScopedTypeVariables - ghc-options: -Wall -threaded -rtsopts "-with-rtsopts=-N -qg" + autogen-modules: Paths_perceptual_hash + default-language: Haskell2010 + other-extensions: ScopedTypeVariables + ghc-options: -Wall -threaded -rtsopts "-with-rtsopts=-N -qg" build-depends: base >=4.9 && <5, perceptual-hash, @@ -139,11 +150,12 @@ ghc-options: -Wunused-packages test-suite perceptual-hash-test - type: exitcode-stdio-1.0 - main-is: Spec.hs - hs-source-dirs: test - default-language: Haskell2010 - ghc-options: -Wall -threaded -rtsopts "-with-rtsopts=-N -K1K" + type: exitcode-stdio-1.0 + main-is: Spec.hs + build-tool-depends: cpphs:cpphs + hs-source-dirs: test + default-language: Haskell2010 + ghc-options: -Wall -threaded -rtsopts "-with-rtsopts=-N -K1K" build-depends: base, perceptual-hash, diff --git a/src/PerceptualHash.cpphs b/src/PerceptualHash.cpphs new file mode 100644 --- /dev/null +++ b/src/PerceptualHash.cpphs @@ -0,0 +1,108 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} + +module PerceptualHash ( imgHash + , fileHash + , hammingDistance + ) where + +import qualified Codec.Picture as JuicyPixels +#ifdef WEBP +import Codec.Picture.WebP (decodeRgb8) +#endif +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, 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) + +-- | See +-- [wiki](https://en.wikipedia.org/wiki/Hamming_distance#Algorithm_example). +-- +-- @since 0.1.4.0 +{-# 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 ((2*i) * (j-1)) * pi)/(2*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 #-} +-- | DCT based hash. See +-- [Zauner](https://www.phash.org/docs/pubs/thesis_zauner.pdf). +-- +-- It is suggested that you use this with the Repa backend. +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 ( IO (Image VS RGB Word8) +fileWebp fp = do + contents <- BS.readFile fp + let (JuicyPixels.Image m n pixels) = decodeRgb8 contents + pure $ fromVector (m, n) $ VS.unsafeCast pixels + +{-# INLINE readWebp #-} +readWebp :: FilePath -> IO (Image VS Y Double) +readWebp = fmap convert . fileWebp + +fileHashWebp :: FilePath -> IO Word64 +fileHashWebp = fmap (imgHash . convRepa) . readWebp + -- faster + where convRepa = fromRepaArrayS . toRepaArray + +fileHash :: FilePath -> IO (Either String Word64) +fileHash fp | ".webp" `isSuffixOf` fp = pure <$> fileHashWebp fp + | otherwise = fileHashHip fp +#else +fileHash :: FilePath -> IO (Either String Word64) +fileHash = fileHashHip +#endif + +fileHashHip :: FilePath -> IO (Either String Word64) +fileHashHip = fmap (fmap (imgHash :: Image RSU Y Double -> Word64)) . readImage diff --git a/src/PerceptualHash.hs b/src/PerceptualHash.hs deleted file mode 100644 --- a/src/PerceptualHash.hs +++ /dev/null @@ -1,100 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} - -module PerceptualHash ( imgHash - , fileHash - , hammingDistance - ) where - -import qualified Codec.Picture as JuicyPixels -import Codec.Picture.WebP (decodeRgb8) -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, 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) - --- | See --- [wiki](https://en.wikipedia.org/wiki/Hamming_distance#Algorithm_example). --- --- @since 0.1.4.0 -{-# 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 ((2*i) * (j-1)) * pi)/(2*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 #-} --- | DCT based hash. See --- [Zauner](https://www.phash.org/docs/pubs/thesis_zauner.pdf). --- --- It is suggested that you use this with the Repa backend. -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 ( IO (Image VS RGB Word8) -fileWebp fp = do - contents <- BS.readFile fp - let (JuicyPixels.Image m n pixels) = decodeRgb8 contents - pure $ fromVector (m, n) $ VS.unsafeCast pixels - -readWebp :: FilePath -> IO (Image VS Y Double) -readWebp = fmap convert . fileWebp - --- | @since 0.1.5.0 -fileHashWebp :: FilePath -> IO Word64 -fileHashWebp = fmap (imgHash . convRepa) . readWebp - -- faster - where convRepa = fromRepaArrayS . toRepaArray - -fileHash :: FilePath -> IO (Either String Word64) -fileHash fp | ".webp" `isSuffixOf` fp = pure <$> fileHashWebp fp - | otherwise = fileHashHip fp - -fileHashHip :: FilePath -> IO (Either String Word64) -fileHashHip = fmap (fmap (imgHash :: Image RSU Y Double -> Word64)) . readImage diff --git a/test/Spec.cpphs b/test/Spec.cpphs new file mode 100644 --- /dev/null +++ b/test/Spec.cpphs @@ -0,0 +1,28 @@ +import PerceptualHash (fileHash) +import Test.Hspec + +main :: IO () +main = hspec $ + describe "fileHash" $ do + + parallel $ it "should match when same" $ do + actual <- fileHash "demo-data/frog.jpeg" + expected <- fileHash "demo-data/frog.png" + actual `shouldBe` expected + + parallel $ it "should match when same" $ do + actual <- fileHash "demo-data/meme-watermark.jpg" + expected <- fileHash "demo-data/meme.png" + actual `shouldBe` expected + + parallel $ it "should not match when different" $ do + actual <- fileHash "demo-data/cat.png" + expected <- fileHash "demo-data/frog.png" + actual `shouldSatisfy` (/= expected) + +#ifdef WEBP + parallel $ it "should match when same" $ do + actual <- fileHash "demo-data/liz-taylor.webp" + expected <- fileHash "demo-data/liz-taylor.png" + actual `shouldBe` expected +#endif diff --git a/test/Spec.hs b/test/Spec.hs deleted file mode 100644 --- a/test/Spec.hs +++ /dev/null @@ -1,26 +0,0 @@ -import PerceptualHash (fileHash) -import Test.Hspec - -main :: IO () -main = hspec $ - describe "fileHash" $ do - - parallel $ it "should match when same" $ do - actual <- fileHash "demo-data/frog.jpeg" - expected <- fileHash "demo-data/frog.png" - actual `shouldBe` expected - - parallel $ it "should match when same" $ do - actual <- fileHash "demo-data/meme-watermark.jpg" - expected <- fileHash "demo-data/meme.png" - actual `shouldBe` expected - - parallel $ it "should not match when different" $ do - actual <- fileHash "demo-data/cat.png" - expected <- fileHash "demo-data/frog.png" - actual `shouldSatisfy` (/= expected) - - parallel $ it "should match when same" $ do - actual <- fileHash "demo-data/liz-taylor.webp" - expected <- fileHash "demo-data/liz-taylor.png" - actual `shouldBe` expected