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

Fix memory profile

This commit is contained in:
Mats Rauhala 2019-01-02 08:02:40 +02:00
parent b8884d4bf4
commit 08fdd68302
1 changed files with 3 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
src/Main.hs
View File

@ -13,7 +13,6 @@ import Control.Exception (SomeException, try)
import Control.Monad (forM_, void, when) 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.List (foldl') import Data.List (foldl')
import Data.Word (Word64) import Data.Word (Word64)
import Options.Generic import Options.Generic
@ -57,7 +56,8 @@ fingerprint = hash . grey . scale . convertRGB8
main :: IO () main :: IO ()
main = do main = do
Cmd{..} <- getRecord "Image duplicate finder" Cmd{..} <- getRecord "Image duplicate finder"
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))))) -- XXX: This is a really long line, split it up
fingerprints <- runSafeT (P.fold (\acc -> either (const acc) (\x -> x `seq` x : acc)) [] id (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
let similar = BK.search 1 fp index let similar = BK.search 1 fp index
@ -65,5 +65,5 @@ main = do
print similar print similar
let targetDir = target </> show (hash fp) let targetDir = target </> show (hash fp)
createDirectoryIfMissing True targetDir createDirectoryIfMissing True targetDir
forM_ similar $ \fp' -> do forM_ similar $ \fp' ->
void $ try @SomeException (createFileLink (imagePath fp') (targetDir </> takeFileName (imagePath fp'))) void $ try @SomeException (createFileLink (imagePath fp') (targetDir </> takeFileName (imagePath fp')))