Compare commits

...

1 Commits

Author SHA1 Message Date
b61ca54011 Record to fingerprint 2019-01-01 21:06:48 +02:00
2 changed files with 30 additions and 13 deletions

View File

@ -1,16 +1,16 @@
{-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE KindSignatures #-} {-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-}
module Data.BKTree where module Data.BKTree where
import Data.Functor.Foldable.TH
import Data.Functor.Foldable import Data.Functor.Foldable
import Data.Functor.Foldable.TH
import GHC.Generics (Generic) import GHC.Generics (Generic)
-- Point for testing purposes -- Point for testing purposes
@ -27,6 +27,12 @@ data BKTree a = Empty
makeBaseFunctor ''BKTree makeBaseFunctor ''BKTree
empty :: BKTree a
empty = Empty
singleton :: Metric a => a -> BKTree a
singleton a = insert a empty
insert :: Metric a => a -> BKTree a -> BKTree a insert :: Metric a => a -> BKTree a -> BKTree a
insert a = \case insert a = \case
Empty -> Node a [] Empty -> Node a []

View File

@ -8,8 +8,8 @@ module Main where
import Codec.Picture import Codec.Picture
import Codec.Picture.Extra (scaleBilinear) import Codec.Picture.Extra (scaleBilinear)
import Data.Bifunctor (second)
import Data.Bits import Data.Bits
import qualified Data.BKTree as BK
import Data.List (foldl') import Data.List (foldl')
import Data.Word (Word64) import Data.Word (Word64)
import Options.Generic import Options.Generic
@ -24,6 +24,18 @@ data Cmd = Cmd { source :: FilePath
, recursive :: Bool , recursive :: Bool
} deriving (Show, Generic, ParseRecord) } deriving (Show, Generic, ParseRecord)
data Fingerprint =
Fingerprint { imagePath :: FilePath
, hash :: !Word64
} deriving Show
instance BK.Metric Fingerprint where
-- hamming distance
distance (Fingerprint _ a) (Fingerprint _ b) =
let xored = a `xor` b
in foldr (\shiftA acc -> acc + if 1 `shift` shiftA .&. xored > 0 then 1 else 0) 0 [0..63]
fingerprint :: DynamicImage -> Word64 fingerprint :: DynamicImage -> Word64
fingerprint = hash . grey . scale . convertRGB8 fingerprint = hash . grey . scale . convertRGB8
where where
@ -41,5 +53,4 @@ main = do
Cmd{..} <- getRecord "Image duplicate finder" Cmd{..} <- getRecord "Image duplicate finder"
runSafeT $ runSafeT $
runEffect $ runEffect $
for (find source (glob "*.jpg" <> regular) >-> P.mapM (\path -> fmap (path,) <$> liftIO (readImage path)) >-> P.map (fmap (second fingerprint))) (liftIO . print) for (find source (glob "*.jpg" <> regular) >-> P.mapM (\path -> fmap (path,) <$> liftIO (readImage path)) >-> P.map (fmap (\(path, img) -> Fingerprint path (fingerprint img)))) (liftIO . print)
putStrLn "Hello, Haskell!"