MasseR/imageduplicates
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Base feature set done

Browse Source
This commit is contained in:
Mats Rauhala 2019-01-01 23:31:16 +02:00
parent 6649744654
commit c7e074b73f
2 changed files with 14 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
imageduplicates.cabal
View File

@ -35,5 +35,7 @@ executable imageduplicates
, recursion-schemes , recursion-schemes
, text , text
, transformers , transformers
, directory
, filepath
hs-source-dirs: src hs-source-dirs: src
default-language: Haskell2010 default-language: Haskell2010

25
src/Main.hs
View File

@ -4,11 +4,13 @@
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-} {-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
module Main where module Main where
import Codec.Picture import Codec.Picture
import Codec.Picture.Extra (scaleBilinear) import Codec.Picture.Extra (scaleBilinear)
import Control.Monad (forM_) import Control.Exception (SomeException, try)
import Control.Monad (forM_, void, when)
import Data.Bits import Data.Bits
import qualified Data.BKTree as BK import qualified Data.BKTree as BK
import Data.Either (rights) import Data.Either (rights)
@ -19,7 +21,8 @@ import Pipes
import Pipes.Files import Pipes.Files
import qualified Pipes.Prelude as P import qualified Pipes.Prelude as P
import Pipes.Safe (runSafeT) import Pipes.Safe (runSafeT)
import Text.Printf (printf) import System.Directory (createDirectoryIfMissing, createFileLink)
import System.FilePath (takeFileName, (</>))
data Cmd = Cmd { source :: FilePath data Cmd = Cmd { source :: FilePath
@ -57,14 +60,10 @@ main = do
fingerprints <- rights <$> runSafeT (P.toListM (find source (glob "*.jpg" <> regular) >-> P.mapM (\path -> fmap (path,) <$> liftIO (readImage path)) >-> P.map (fmap (\(path, img) -> Fingerprint path (fingerprint img))))) fingerprints <- rights <$> runSafeT (P.toListM (find source (glob "*.jpg" <> regular) >-> P.mapM (\path -> fmap (path,) <$> liftIO (readImage path)) >-> P.map (fmap (\(path, img) -> Fingerprint path (fingerprint img)))))
let index = foldl' (flip BK.insert) BK.empty fingerprints let index = foldl' (flip BK.insert) BK.empty fingerprints
forM_ fingerprints $ \fp -> do forM_ fingerprints $ \fp -> do
debugPrint 1 fp index let similar = BK.search 1 fp index
debugPrint 2 fp index when (length similar > 1) $ do
debugPrint 3 fp index print similar
debugPrint 4 fp index let targetDir = target </> show (hash fp)
putStrLn "" createDirectoryIfMissing True targetDir
putStrLn "" forM_ similar $ \fp' -> do
where void $ try @SomeException (createFileLink (imagePath fp') (targetDir </> takeFileName (imagePath fp')))
debugPrint :: Int -> Fingerprint -> BK.BKTree Fingerprint -> IO ()
debugPrint n fp index = do
let similar = BK.search n fp index
printf "For %s there are %d similar images at distance %d\n" (imagePath fp) (length similar) n