perceptual-hash 0.1.0.2 → 0.1.1.0

raw patch · 7 files changed

+92/−37 lines, 7 filesdep +repadep ~hipPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: repa

Dependency ranges changed: hip

API changes (from Hackage documentation)

Files

• CHANGELOG.md +7/−0
• README.md +2/−1
• bench/Bench.cpphs +18/−0
• bench/Bench.hs +0/−14
• perceptual-hash.cabal +23/−7
• src/ForeignHash.hs +23/−0
• src/PerceptualHash.hs +19/−15

@@ -1,5 +1,12 @@ # phash +## 0.1.1.0++  * Add `with-phash` flag to enable `ForeignHash` module and benchmarks+    against pHash+  * Significant performance improvements+  * Generalized signature for `imgHash`+ ## 0.1.0.2    * Performance improvements

@@ -6,7 +6,8 @@ [![Hackage](https://img.shields.io/hackage/v/perceptual-hash.svg)](http://hackage.haskell.org/package/perceptual-hash) [![Dependencies of latest version on Hackage](https://img.shields.io/hackage-deps/v/perceptual-hash.svg)](https://hackage.haskell.org/package/perceptual-hash) -This is a command-line tool to detect (potential) duplicate images.+This is a command-line tool to detect (potential) duplicate images. It also+contains a Haskell [library](http://hackage.haskell.org/package/perceptual-hash).  ## Use 

@@ -0,0 +1,18 @@+module Main (main) where++import           Criterion.Main+#ifdef FOREIGN_PHASH+import           ForeignHash    (foreignFileHash)+#endif+import           PerceptualHash (fileHash)++main :: IO ()+main =+    defaultMain [ bgroup "fileHash"+                      [ bench "cat.png" $ nfIO (fileHash catPath) ]+#ifdef FOREIGN_PHASH+                , bgroup "foreignHash"+                      [ bench "cat.png" $ nfIO (foreignFileHash catPath) ]+#endif+                ]+    where catPath = "demo-data/cat.png"

@@ -1,14 +0,0 @@-module Main (main) where--import           Criterion.Main-import           Graphics.Image (VU (..), readImageY)-import           PerceptualHash (imgHash)--main :: IO ()-main =-    defaultMain [ env img $ \ f ->-                  bgroup "imgHash"-                      [ bench "cat.png" $ nf imgHash f ]-                ]-    where img = readImageY VU catPath-          catPath = "demo-data/cat.png"

@@ -1,6 +1,6 @@ cabal-version: 2.0 name: perceptual-hash-version: 0.1.0.2+version: 0.1.1.0 license: BSD3 license-file: LICENSE copyright: Copyright: (c) 2019 Vanessa McHale@@ -18,6 +18,10 @@     type: git     location: https://github.com/vmchale/phash +flag with-phash+    description:+        Use FFI bindings to pHash+ library     exposed-modules:         PerceptualHash@@ -32,8 +36,13 @@         hip -any,         vector-algorithms -any,         vector -any,-        primitive -any+        primitive -any,+        repa -any +    if flag(with-phash)+        exposed-modules:+            ForeignHash+     if impl(ghc >=8.0)         ghc-options: -Wincomplete-uni-patterns -Wincomplete-record-updates                      -Wredundant-constraints -Widentities@@ -51,7 +60,7 @@     autogen-modules:         Paths_perceptual_hash     default-language: Haskell2010-    ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall+    ghc-options: -Wall -threaded -rtsopts "-with-rtsopts=-N -qg"     build-depends:         base >=4.9 && <5,         perceptual-hash -any,@@ -71,15 +80,22 @@ benchmark phash-bench     type: exitcode-stdio-1.0     main-is: Bench.hs+    build-tools: cpphs -any     hs-source-dirs: bench     default-language: Haskell2010-    ghc-options: -Wall -Wincomplete-uni-patterns-                 -Wincomplete-record-updates -Wredundant-constraints+    ghc-options: -threaded -rtsopts "-with-rtsopts=-N -qg" -Wall+                 -Wincomplete-uni-patterns -Wincomplete-record-updates+                 -Wredundant-constraints     build-depends:         base -any,         perceptual-hash -any,-        criterion -any,-        hip -any+        criterion -any++    if flag(with-phash)+        pkgconfig-depends: pHash -any++    if flag(with-phash)+        cpp-options: -DFOREIGN_PHASH      if impl(ghc >=8.4)         ghc-options: -Wmissing-export-lists

@@ -0,0 +1,23 @@+-- N.B. this is a good deal faster than the Haskell code+module ForeignHash ( foreignFileHash ) where++import           Data.Word             (Word64)+import           Foreign.C.String      (CString, withCString)+import           Foreign.C.Types       (CInt (..), CULLong)+import           Foreign.Marshal.Alloc (alloca)+import           Foreign.Ptr           (Ptr)+import           Foreign.Storable      (peek)++foreign import ccall ph_dct_imagehash :: CString -> Ptr CULLong -> IO CInt++-- | Doesn't work with @.gif@ files+foreignFileHash :: FilePath -> IO Word64+foreignFileHash fp = withCString fp $ \cstr ->+    alloca $ \hashPtr -> do+        res <- ph_dct_imagehash cstr hashPtr+        check res+        fromIntegral <$> peek hashPtr++    where check (-1) = error ("Hash of file " ++ fp ++ " failed.")+          check 0    = pure ()+          check _    = error "This should never happen."

@@ -1,20 +1,21 @@ {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies     #-}  module PerceptualHash ( imgHash                       , fileHash                       ) where -import           Control.Applicative      (pure) import           Control.Monad.ST         (runST)+import           Data.Array.Repa.Eval     (Elt) import           Data.Bits                (shiftL, (.|.)) import qualified Data.Vector.Unboxed      as V import           Data.Word                (Word64) import           Graphics.Image           (Array, Bilinear (..), Border (Edge),                                            Image, Pixel (PixelX, PixelY),-                                           VU (..), X, Y, convolve, crop,+                                           RSU (..), X, Y, convolve, crop,                                            makeImage, readImageY, resize,                                            transpose, (|*|))-import           Graphics.Image.Interface (toVector)+import           Graphics.Image.Interface (Elevator, toVector) import           Median                   (median)  dct32 :: (Floating e, Array arr Y e) => Image arr Y e@@ -26,10 +27,12 @@ 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 = convolve Edge idMat {-# SCC meanFilter #-} +{-# INLINE size32 #-} size32 :: Array arr cs e => Image arr cs e -> Image arr cs e size32 = resize Bilinear Edge (32,32) @@ -39,24 +42,25 @@ medianImmut :: (Ord e, V.Unbox e, Fractional e) => V.Vector e -> e medianImmut v = runST $     median =<< V.thaw v-{-# SCC medianImmut #-}  dct :: (Floating e, Array arr Y e) => Image arr Y e -> Image arr Y e dct img = dct32 |*| img |*| transpose dct32-{-# SCC dct #-} -imgHash :: Image VU Y Double -> Word64+{-# INLINE imgHash #-}+{-# SPECIALIZE imgHash :: Image RSU Y Double -> Word64 #-}+imgHash :: (Elevator e, Ord e, Floating e, Elt e) => Image RSU Y e -> Word64 imgHash = asWord64 . aboveMed . V.map (\(PixelY x) -> x) . toVector . crop8 . dct . size32 . meanFilter -    where asWord64 :: V.Vector Bool -> Word64-          asWord64 = V.foldl' (\acc x -> (acc `shiftL` 1) .|. boolToWord64 x) 0-            where boolToWord64 :: Bool -> Word64-                  boolToWord64 False = 0-                  boolToWord64 True  = 1+asWord64 :: V.Vector Bool -> Word64+asWord64 = V.foldl' (\acc x -> (acc `shiftL` 1) .|. boolToWord64 x) 0+    where boolToWord64 :: Bool -> Word64+          boolToWord64 False = 0+          boolToWord64 True  = 1 -          aboveMed v =-            let med = medianImmut v-            in V.map (<med) v+aboveMed :: (Fractional e, V.Unbox e, Ord e) => V.Vector e -> V.Vector Bool+aboveMed v =+    let med = medianImmut v+    in V.map (<med) v  fileHash :: FilePath -> IO Word64-fileHash = fmap imgHash . readImageY VU+fileHash = fmap imgHash . readImageY RSU