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