diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,10 @@ # phash +## 0.1.2.0 + + * Add `demo-data` field so tests don't fail + * Generalize `imgHash` signature + ## 0.1.1.1 * Use mirror for convolutions diff --git a/app/Parallel.hs b/app/Parallel.hs --- a/app/Parallel.hs +++ b/app/Parallel.hs @@ -1,8 +1,7 @@ module Parallel ( pathMaps ) where import Control.Concurrent.STM (atomically) -import Control.Concurrent.STM.TVar (TVar, modifyTVar', newTVarIO, - readTVarIO) +import Control.Concurrent.STM.TVar (TVar, modifyTVar', newTVarIO, readTVarIO) import Data.List.NonEmpty (NonEmpty (..), (<|)) import qualified Data.Map as M import Data.Word (Word64) @@ -36,4 +35,3 @@ readTVarIO total where fileFilter = pure . imgExtension . takeExtension - diff --git a/bench/Bench.cpphs b/bench/Bench.cpphs --- a/bench/Bench.cpphs +++ b/bench/Bench.cpphs @@ -1,18 +1,25 @@ module Main (main) where import Criterion.Main +import Data.Word (Word64) #ifdef FOREIGN_PHASH -import ForeignHash (foreignFileHash) +import ForeignHash (foreignFileHash) #endif -import PerceptualHash (fileHash) +import PerceptualHash (fileHash) +import System.FilePath (takeFileName) +mkBGroup :: String -> (FilePath -> IO Word64) -> Benchmark +mkBGroup str f = bgroup str (toBench <$> [catPath, frogJpeg, frogPng]) + + where toBench fp = bench (takeFileName fp) $ nfIO (f fp) + catPath = "demo-data/cat.png" + frogJpeg = "demo-data/frog.jpeg" + frogPng = "demo-data/frog.png" + main :: IO () main = - defaultMain [ bgroup "fileHash" - [ bench "cat.png" $ nfIO (fileHash catPath) ] + defaultMain [ mkBGroup "fileHash" fileHash #ifdef FOREIGN_PHASH - , bgroup "foreignHash" - [ bench "cat.png" $ nfIO (foreignFileHash catPath) ] + , mkBGroup "foreignHash" foreignFileHash #endif ] - where catPath = "demo-data/cat.png" diff --git a/demo-data/cat.png b/demo-data/cat.png new file mode 100644 Binary files /dev/null and b/demo-data/cat.png differ diff --git a/demo-data/frog.jpeg b/demo-data/frog.jpeg new file mode 100644 Binary files /dev/null and b/demo-data/frog.jpeg differ diff --git a/demo-data/frog.png b/demo-data/frog.png new file mode 100644 Binary files /dev/null and b/demo-data/frog.png differ diff --git a/perceptual-hash.cabal b/perceptual-hash.cabal --- a/perceptual-hash.cabal +++ b/perceptual-hash.cabal @@ -1,44 +1,47 @@ -cabal-version: 2.0 -name: perceptual-hash -version: 0.1.1.1 -license: BSD3 -license-file: LICENSE -copyright: Copyright: (c) 2019 Vanessa McHale -maintainer: vamchale@gmail.com -author: Vanessa McHale -synopsis: Find duplicate images -description: - Find similar images using perceptual hashes -category: Application, CommandLine, Images -build-type: Simple -extra-doc-files: README.md - CHANGELOG.md +cabal-version: 2.0 +name: perceptual-hash +version: 0.1.2.0 +license: BSD3 +license-file: LICENSE +copyright: Copyright: (c) 2019 Vanessa McHale +maintainer: vamchale@gmail.com +author: Vanessa McHale +synopsis: Find duplicate images +description: Find similar images using perceptual hashes +category: Application, CommandLine, Images +build-type: Simple +data-files: + demo-data/cat.png + demo-data/frog.jpeg + demo-data/frog.png +extra-doc-files: + README.md + CHANGELOG.md + source-repository head - type: git + type: git location: https://github.com/vmchale/phash flag with-phash - description: - Use FFI bindings to pHash + description: Use FFI bindings to pHash + default: False + manual: True flag llvm - description: - Use LLVM backend to GHC rather than NCG - default: False - manual: True + description: Use LLVM backend to GHC rather than NCG + default: False + manual: True library - exposed-modules: - PerceptualHash - hs-source-dirs: src - other-modules: - Median + exposed-modules: PerceptualHash + hs-source-dirs: src + other-modules: Median default-language: Haskell2010 other-extensions: FlexibleContexts TypeFamilies - ghc-options: -Wall -O2 + ghc-options: -Wall -O2 build-depends: - base >=4.3 && <5, + base >=4.8 && <5, hip -any, vector-algorithms -any, vector -any, @@ -52,27 +55,27 @@ pkgconfig-depends: pHash -any if flag(with-phash) - exposed-modules: - ForeignHash + exposed-modules: ForeignHash if impl(ghc >=8.0) - ghc-options: -Wincomplete-uni-patterns -Wincomplete-record-updates - -Wredundant-constraints -Widentities + ghc-options: + -Wincomplete-uni-patterns -Wincomplete-record-updates + -Wredundant-constraints -Widentities if impl(ghc >=8.4) ghc-options: -Wmissing-export-lists executable phash - main-is: Main.hs - hs-source-dirs: app + main-is: Main.hs + hs-source-dirs: app other-modules: Paths_perceptual_hash Parser Parallel - autogen-modules: - Paths_perceptual_hash + + autogen-modules: Paths_perceptual_hash default-language: Haskell2010 - ghc-options: -Wall -threaded -rtsopts "-with-rtsopts=-N -qg" + ghc-options: -Wall -threaded -rtsopts "-with-rtsopts=-N -qg" build-depends: base >=4.9 && <5, perceptual-hash -any, @@ -86,43 +89,48 @@ ghc-options: -fllvm if impl(ghc >=8.0) - ghc-options: -Wincomplete-uni-patterns -Wincomplete-record-updates - -Wredundant-constraints -Widentities + ghc-options: + -Wincomplete-uni-patterns -Wincomplete-record-updates + -Wredundant-constraints -Widentities if impl(ghc >=8.4) ghc-options: -Wmissing-export-lists test-suite perceptual-hash-test - type: exitcode-stdio-1.0 - main-is: Spec.hs - hs-source-dirs: 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 + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N build-depends: base -any, perceptual-hash -any, hspec -any if impl(ghc >=8.0) - ghc-options: -Wincomplete-uni-patterns -Wincomplete-record-updates - -Wredundant-constraints -Widentities + ghc-options: + -Wincomplete-uni-patterns -Wincomplete-record-updates + -Wredundant-constraints -Widentities if impl(ghc >=8.4) ghc-options: -Wmissing-export-lists benchmark phash-bench - type: exitcode-stdio-1.0 - main-is: Bench.hs + type: exitcode-stdio-1.0 + main-is: Bench.hs build-tool-depends: cpphs:cpphs -any - hs-source-dirs: bench - default-language: Haskell2010 - ghc-options: -threaded -rtsopts "-with-rtsopts=-N -qg" -Wall - -Wincomplete-uni-patterns -Wincomplete-record-updates - -Wredundant-constraints + hs-source-dirs: bench + default-language: Haskell2010 + 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 + criterion -any, + filepath -any if flag(llvm) ghc-options: -fllvm diff --git a/src/PerceptualHash.hs b/src/PerceptualHash.hs --- a/src/PerceptualHash.hs +++ b/src/PerceptualHash.hs @@ -6,16 +6,14 @@ ) where import Control.Monad.ST (runST) -import Data.Array.Repa.Eval (Elt) import Data.Bits (shiftL, (.|.)) -import qualified Data.Vector.Unboxed as V +import qualified Data.Vector.Generic as V import Data.Word (Word64) -import Graphics.Image (Array, Bilinear (..), - Border (Edge, Reflect), Image, - Pixel (PixelX, PixelY), RSU (..), X, - Y, convolve, crop, makeImage, - readImageY, resize, transpose, (|*|)) -import Graphics.Image.Interface (Elevator, toVector) +import Graphics.Image (Array, Bilinear (..), Border (Edge, Reflect), Image, + Pixel (PixelX, PixelY), RSU (..), X, Y, convolve, crop, + makeImage, readImageY, resize, transpose, (|*|)) +import Graphics.Image.Interface (toVector) +import qualified Graphics.Image.Interface as Hip import Median (median) dct32 :: (Floating e, Array arr Y e) => Image arr Y e @@ -24,13 +22,11 @@ n = 32 idMat :: (Fractional e, Array arr X e) => Image arr X e -idMat = makeImage (7,7) - (\_ -> PixelX (1/49)) +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 Reflect idMat --- {-# SCC meanFilter #-} +meanFilter = {-# SCC "meanFilter" #-} convolve Reflect idMat {-# INLINE size32 #-} size32 :: Array arr cs e => Image arr cs e -> Image arr cs e @@ -39,7 +35,7 @@ crop8 :: Array arr cs e => Image arr cs e -> Image arr cs e crop8 = crop (0,0) (8,8) -medianImmut :: (Ord e, V.Unbox e, Fractional e) => V.Vector e -> e +medianImmut :: (Ord e, Fractional e, V.Vector v e) => v e -> e medianImmut v = runST $ median =<< V.thaw v @@ -47,17 +43,20 @@ dct img = dct32 |*| img |*| transpose dct32 {-# INLINE imgHash #-} -{-# SPECIALIZE imgHash :: Image RSU Y Double -> Word64 #-} -imgHash :: (Elevator e, Ord e, Floating e, Elt e) => Image RSU Y e -> Word64 +-- | 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 Bool -> Word64 +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.Unbox e, Ord e) => V.Vector e -> V.Vector Bool +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 (