diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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 diff --git a/bench/Bench.cpphs b/bench/Bench.cpphs new file mode 100644 --- /dev/null +++ b/bench/Bench.cpphs @@ -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" diff --git a/bench/Bench.hs b/bench/Bench.hs deleted file mode 100644 --- a/bench/Bench.hs +++ /dev/null @@ -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" diff --git a/perceptual-hash.cabal b/perceptual-hash.cabal --- a/perceptual-hash.cabal +++ b/perceptual-hash.cabal @@ -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 diff --git a/src/ForeignHash.hs b/src/ForeignHash.hs new file mode 100644 --- /dev/null +++ b/src/ForeignHash.hs @@ -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." diff --git a/src/PerceptualHash.hs b/src/PerceptualHash.hs --- a/src/PerceptualHash.hs +++ b/src/PerceptualHash.hs @@ -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 ( V.Vector e -> V.Vector Bool +aboveMed v = + let med = medianImmut v + in V.map ( IO Word64 -fileHash = fmap imgHash . readImageY VU +fileHash = fmap imgHash . readImageY RSU