Compare commits
1 Commits
b33b45a4ea
...
b61ca54011
Author | SHA1 | Date | |
---|---|---|---|
b61ca54011 |
@ -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 []
|
||||||
|
10
src/Main.hs
10
src/Main.hs
@ -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
|
||||||
@ -17,7 +17,6 @@ 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 qualified Data.BKTree as BK
|
|
||||||
|
|
||||||
|
|
||||||
data Cmd = Cmd { source :: FilePath
|
data Cmd = Cmd { source :: FilePath
|
||||||
@ -27,14 +26,14 @@ data Cmd = Cmd { source :: FilePath
|
|||||||
|
|
||||||
data Fingerprint =
|
data Fingerprint =
|
||||||
Fingerprint { imagePath :: FilePath
|
Fingerprint { imagePath :: FilePath
|
||||||
, hash :: !Word64
|
, hash :: !Word64
|
||||||
} deriving Show
|
} deriving Show
|
||||||
|
|
||||||
instance BK.Metric Fingerprint where
|
instance BK.Metric Fingerprint where
|
||||||
-- hamming distance
|
-- hamming distance
|
||||||
distance (Fingerprint _ a) (Fingerprint _ b) =
|
distance (Fingerprint _ a) (Fingerprint _ b) =
|
||||||
let xored = a `xor` b
|
let xored = a `xor` b
|
||||||
in _
|
in foldr (\shiftA acc -> acc + if 1 `shift` shiftA .&. xored > 0 then 1 else 0) 0 [0..63]
|
||||||
|
|
||||||
|
|
||||||
fingerprint :: DynamicImage -> Word64
|
fingerprint :: DynamicImage -> Word64
|
||||||
@ -54,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!"
|
|
||||||
|
Loading…
Reference in New Issue
Block a user