perceptual-hash 0.1.1.1 → 0.1.2.0
raw patch · 8 files changed
+98/−81 lines, 8 filesbinary-added
Files
- CHANGELOG.md +5/−0
- app/Parallel.hs +1/−3
- bench/Bench.cpphs +14/−7
- demo-data/cat.png binary
- demo-data/frog.jpeg binary
- demo-data/frog.png binary
- perceptual-hash.cabal +62/−54
- src/PerceptualHash.hs +16/−17
CHANGELOG.md view
@@ -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
app/Parallel.hs view
@@ -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-
bench/Bench.cpphs view
@@ -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"
+ demo-data/cat.png view
binary file changed (absent → 276416 bytes)
+ demo-data/frog.jpeg view
binary file changed (absent → 17361 bytes)
+ demo-data/frog.png view
binary file changed (absent → 134922 bytes)
perceptual-hash.cabal view
@@ -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
src/PerceptualHash.hs view
@@ -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 (<med) v