perceptual-hash 0.1.4.6 → 0.1.4.7
raw patch · 8 files changed
+258/−206 lines, 8 filesPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
API changes (from Hackage documentation)
- ForeignHash: foreignFileHash :: FilePath -> IO Word64
Files
- CHANGELOG.md +4/−0
- app/Parallel.cpphs +57/−0
- app/Parallel.hs +0/−53
- perceptual-hash.cabal +31/−4
- src/PerceptualHash.cpphs +131/−0
- src/PerceptualHash.hs +0/−118
- test/Spec.cpphs +35/−0
- test/Spec.hs +0/−31
CHANGELOG.md view
@@ -1,5 +1,9 @@ # phash +## 0.1.4.7++ * Reinstate `disable-webp` flag, add `disable-avif` flag+ ## 0.1.4.6 * Add support for `.avif` images
+ app/Parallel.cpphs view
@@ -0,0 +1,57 @@+{-# 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+#ifdef AVIF+imgExtension ".avif" = 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,53 +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 ".avif" = 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,6 +1,6 @@ cabal-version: 2.0 name: perceptual-hash-version: 0.1.4.6+version: 0.1.4.7 license: BSD3 license-file: LICENSE copyright: Copyright: (c) 2019-2021 Vanessa McHale@@ -39,6 +39,10 @@ description: Don't depend on webp FFI bindings default: False +flag disable-avif+ description: Don't depend on avif FFI bindings+ default: False+ flag llvm description: Use LLVM backend to GHC rather than NCG default: False@@ -51,6 +55,7 @@ default-language: Haskell2010 other-extensions: FlexibleContexts TypeFamilies ghc-options: -Wall -O2+ build-tool-depends: cpphs:cpphs build-depends: base >=4.10 && <5, hip,@@ -58,10 +63,16 @@ vector, primitive, bytestring,- JuicyPixels,- avif,- webp >=0.1.0.3+ JuicyPixels + if !flag(disable-webp)+ build-depends: webp >=0.1.0.3+ cpp-options: -DWEBP++ if !flag(disable-avif)+ build-depends: avif+ cpp-options: -DAVIF+ if flag(llvm) ghc-options: -fllvm @@ -122,6 +133,14 @@ default-language: Haskell2010 other-extensions: ScopedTypeVariables ghc-options: -Wall -threaded -rtsopts "-with-rtsopts=-N -qg"++ if !flag(disable-webp)+ cpp-options: -DWEBP++ if !flag(disable-avif)+ cpp-options: -DAVIF++ build-tool-depends: cpphs:cpphs build-depends: base >=4.9 && <5, perceptual-hash,@@ -151,6 +170,14 @@ hs-source-dirs: test default-language: Haskell2010 ghc-options: -Wall -threaded -rtsopts "-with-rtsopts=-N -K1K"+ build-tool-depends: cpphs:cpphs++ if !flag(disable-webp)+ cpp-options: -DWEBP++ if !flag(disable-avif)+ cpp-options: -DAVIF+ build-depends: base, perceptual-hash,
+ src/PerceptualHash.cpphs view
@@ -0,0 +1,131 @@+{-# OPTIONS_GHC -fspecialize-aggressively #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}++module PerceptualHash ( imgHash+ , fileHash+ , hammingDistance+ ) where++#ifdef AVIF+import Codec.Avif (decode)+#endif+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, 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)++-- | 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 (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 #-}+-- | 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 (n, m) $ 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+#endif++fileHash :: FilePath -> IO (Either String Word64)+fileHash fp+#ifdef WEBP+ | ".webp" `isSuffixOf` fp = pure <$> fileHashWebp fp+#endif+#ifdef AVIF+ | ".avif" `isSuffixOf` fp = pure <$> fileHashAvif fp+#endif+ | otherwise = fileHashHip fp++#ifdef AVIF+{-# INLINE readAvif #-}+readAvif :: FilePath -> IO (Image VS Y Double)+readAvif = fmap convert . fileAvif++fileHashAvif :: FilePath -> IO Word64+fileHashAvif = fmap (imgHash . convRepa) . readAvif+ where convRepa = fromRepaArrayS . toRepaArray++{-# INLINE fileAvif #-}+fileAvif :: FilePath -> IO (Image VS RGBA Word8)+fileAvif fp = do+ (JuicyPixels.Image m n pixels) <- decode <$> BS.readFile fp+ pure $ fromVector (n, m) $ VS.unsafeCast pixels+#endif++fileHashHip :: FilePath -> IO (Either String Word64)+fileHashHip = fmap (fmap (imgHash :: Image RSU Y Double -> Word64)) . readImage
− src/PerceptualHash.hs
@@ -1,118 +0,0 @@-{-# OPTIONS_GHC -fspecialize-aggressively #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeFamilies #-}--module PerceptualHash ( imgHash- , fileHash- , hammingDistance- ) where--import Codec.Avif (decode)-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, 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)---- | 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 (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 #-}--- | 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--{-# 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 (n, m) $ 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- | ".avif" `isSuffixOf` fp = pure <$> fileHashAvif fp- | otherwise = fileHashHip fp--{-# INLINE readAvif #-}-readAvif :: FilePath -> IO (Image VS Y Double)-readAvif = fmap convert . fileAvif--fileHashAvif :: FilePath -> IO Word64-fileHashAvif = fmap (imgHash . convRepa) . readAvif- where convRepa = fromRepaArrayS . toRepaArray--{-# INLINE fileAvif #-}-fileAvif :: FilePath -> IO (Image VS RGBA Word8)-fileAvif fp = do- (JuicyPixels.Image m n pixels) <- decode <$> BS.readFile fp- pure $ fromVector (n, m) $ VS.unsafeCast pixels--fileHashHip :: FilePath -> IO (Either String Word64)-fileHashHip = fmap (fmap (imgHash :: Image RSU Y Double -> Word64)) . readImage
+ test/Spec.cpphs view
@@ -0,0 +1,35 @@+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 AVIF+ parallel $ it "should match when same" $ do+ actual <- fileHash "demo-data/fashion.avif"+ expected <- fileHash "demo-data/fashion.png"+ actual `shouldBe` expected+#endif++#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,31 +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/fashion.avif"- expected <- fileHash "demo-data/fashion.png"- actual `shouldBe` 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