From b61ca540117d17b2fc7fef8edc15430c2aa60d90 Mon Sep 17 00:00:00 2001
From: Mats Rauhala <mats.rauhala@iki.fi>
Date: Tue, 1 Jan 2019 20:49:26 +0200
Subject: [PATCH] Record to fingerprint

---
 src/Data/BKTree.hs | 26 ++++++++++++++++----------
 src/Main.hs        | 17 ++++++++++++++---
 2 files changed, 30 insertions(+), 13 deletions(-)

diff --git a/src/Data/BKTree.hs b/src/Data/BKTree.hs
index c1d367f..4180056 100644
--- a/src/Data/BKTree.hs
+++ b/src/Data/BKTree.hs
@@ -1,16 +1,16 @@
-{-# LANGUAGE DeriveFoldable    #-}
-{-# LANGUAGE DeriveFunctor     #-}
-{-# LANGUAGE DeriveGeneric     #-}
-{-# LANGUAGE DeriveTraversable #-}
-{-# LANGUAGE KindSignatures    #-}
-{-# LANGUAGE LambdaCase        #-}
-{-# LANGUAGE TemplateHaskell   #-}
-{-# LANGUAGE TypeFamilies      #-}
-{-# LANGUAGE ScopedTypeVariables      #-}
+{-# LANGUAGE DeriveFoldable      #-}
+{-# LANGUAGE DeriveFunctor       #-}
+{-# LANGUAGE DeriveGeneric       #-}
+{-# LANGUAGE DeriveTraversable   #-}
+{-# LANGUAGE KindSignatures      #-}
+{-# LANGUAGE LambdaCase          #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell     #-}
+{-# LANGUAGE TypeFamilies        #-}
 module Data.BKTree where
 
-import           Data.Functor.Foldable.TH
 import           Data.Functor.Foldable
+import           Data.Functor.Foldable.TH
 import           GHC.Generics             (Generic)
 
 -- Point for testing purposes
@@ -27,6 +27,12 @@ data BKTree a = Empty
 
 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 a = \case
   Empty -> Node a []
diff --git a/src/Main.hs b/src/Main.hs
index 033cefb..ffa40a3 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -8,8 +8,8 @@ module Main where
 
 import           Codec.Picture
 import           Codec.Picture.Extra (scaleBilinear)
-import           Data.Bifunctor      (second)
 import           Data.Bits
+import qualified Data.BKTree         as BK
 import           Data.List           (foldl')
 import           Data.Word           (Word64)
 import           Options.Generic
@@ -24,6 +24,18 @@ data Cmd = Cmd { source    :: FilePath
                , recursive :: Bool
                } 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 = hash . grey . scale . convertRGB8
   where
@@ -41,5 +53,4 @@ main = do
   Cmd{..} <- getRecord "Image duplicate finder"
   runSafeT $
     runEffect $
-      for (find source (glob "*.jpg" <> regular) >-> P.mapM (\path -> fmap (path,) <$> liftIO (readImage path)) >-> P.map (fmap (second fingerprint))) (liftIO . print)
-  putStrLn "Hello, Haskell!"
+      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)