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

Use comonads

Browse Source
This commit is contained in:
Mats Rauhala 2019-01-24 21:02:27 +02:00
parent 8833880c22
commit 7e448da839
1 changed files with 36 additions and 25 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

61
src/Main.hs
View File

@ -1,4 +1,5 @@
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
@ -8,30 +9,33 @@
module Main where
import Codec.Picture
import Codec.Picture.Extra (scaleBilinear)
import Control.Exception (SomeException, try)
import Control.Monad (forM_, void, when)
import Codec.Picture.Extra (scaleBilinear)
import Control.Comonad (extend, extract)
import Control.Comonad.Store (Store, experiment, seek, store)
import Control.Exception (SomeException, try)
import Control.Monad (forM_, void, when)
import Data.Bits
import qualified Data.BKTree as BK
import Data.List (foldl')
import Data.Maybe (fromMaybe)
import Data.Word (Word64)
import qualified Data.BKTree as BK
import Data.List (foldl')
import Data.Maybe (fromMaybe)
import Data.Word (Word64)
import Options.Generic
import Pipes
import Pipes.Files
import qualified Pipes.Prelude as P
import Pipes.Safe (runSafeT)
import System.Directory (createDirectoryIfMissing, createFileLink)
import System.FilePath (takeFileName, (</>))
import qualified Pipes.Prelude as P
import Pipes.Safe (runSafeT)
import System.Directory (createDirectoryIfMissing,
createFileLink)
import System.FilePath (takeFileName, (</>))
data Alg = Average | DHash deriving (Read, Show, Generic)
instance ParseField Alg
data Cmd = Cmd { source :: FilePath
, target :: FilePath
, range :: Maybe Int
data Cmd = Cmd { source :: FilePath
, target :: FilePath
, range :: Maybe Int
, algorithm :: Maybe Alg
} deriving (Show, Generic, ParseRecord)
@ -46,7 +50,6 @@ instance BK.Metric Fingerprint where
let xored = a `xor` b
in foldr (\shiftA acc -> acc + if 1 `shift` shiftA .&. xored > 0 then 1 else 0) 0 [0..63]
fingerprint :: Alg -> DynamicImage -> Word64
fingerprint alg = hash . grey . scale . convertRGB8
where
@ -54,17 +57,25 @@ fingerprint alg = hash . grey . scale . convertRGB8
scale = scaleBilinear 8 8
grey :: Image PixelRGB8 -> Image Pixel8
grey = pixelMap (\(PixelRGB8 r g b) -> ceiling ((fromIntegral r * (0.3 :: Double)) + (fromIntegral g * 0.59) + (fromIntegral b * 0.11)))
indexes = [(x,y) | x <- [0..7], y <- [0..7]]
hashWith :: Image Pixel8 -> (Store (Int, Int) Pixel8 -> Bool) -> Word64
hashWith img f =
let s = store (uncurry (pixelAt img)) (0,0)
img' = extend f s
at pos = extract $ seek pos img'
in foldr (\(shiftA, b) acc -> if b then 1 `shift` shiftA .|. acc else acc) 0 $ zip [0..] $ map at indexes
hash :: Image Pixel8 -> Word64
hash = case alg of
Average -> averageHash
DHash -> dhash
dhash :: Image Pixel8 -> Word64
dhash img =
foldr (\(shiftA, b) acc -> if b then 1 `shift` shiftA .|. acc else acc) 0 $ zip [0..] [(x < 7) && (pixelAt img x y > pixelAt img (x+1) y) | x <- [0..7], y <- [0..7]]
averageHash :: Image Pixel8 -> Word64
averageHash img = -- the average fingerprint method
let avg = fromIntegral (foldl' (\acc (x,y) -> acc + fromIntegral (pixelAt img x y)) (0 :: Int) [(x,y) | x <- [0..7], y <- [0..7]] `div` 64)
in foldr (\(shiftA, b) acc -> if b then 1 `shift` shiftA .|. acc else acc) 0 $ zip [0..] [pixelAt img x y > avg | x <- [0..7], y <- [0..7]]
hash img = case alg of
Average ->
let avg = fromIntegral (foldl' (\acc (x,y) -> acc + fromIntegral (pixelAt img x y)) (0 :: Int) [(x,y) | (x,y) <- indexes] `div` 64)
in img `hashWith` (avgAlg avg)
DHash -> img `hashWith` dAlg
dAlg :: Store (Int, Int) Pixel8 -> Bool
dAlg img = case experiment (\(x,y) -> [(x,y), (succ x `mod` 8, y)]) img of
[l,r] -> l > r
_ -> False
avgAlg :: Pixel8 -> Store (Int, Int) Pixel8 -> Bool
avgAlg avg img = extract img > avg
main :: IO ()
main = do