perceptual-hash 0.1.4.2 → 0.1.4.3
raw patch · 9 files changed
+228/−199 lines, 9 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- CHANGELOG.md +5/−0
- LICENSE +1/−1
- app/Parallel.cpphs +54/−0
- app/Parallel.hs +0/−52
- perceptual-hash.cabal +32/−20
- src/PerceptualHash.cpphs +108/−0
- src/PerceptualHash.hs +0/−100
- test/Spec.cpphs +28/−0
- test/Spec.hs +0/−26
CHANGELOG.md view
@@ -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
LICENSE view
@@ -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:
+ app/Parallel.cpphs view
@@ -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
− app/Parallel.hs
@@ -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
perceptual-hash.cabal view
@@ -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,
+ src/PerceptualHash.cpphs view
@@ -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 (<med) v++#ifdef WEBP+{-# INLINE fileWebp #-}+fileWebp :: FilePath -> 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
− src/PerceptualHash.hs
@@ -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 (<med) v--fileWebp :: FilePath -> 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
+ test/Spec.cpphs view
@@ -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
− test/Spec.hs
@@ -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