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

35
src/Main.hs
View File

@ -1,4 +1,5 @@
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
@ -9,6 +10,8 @@ module Main where
import Codec.Picture
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
@ -21,7 +24,8 @@ import Pipes
import Pipes.Files
import qualified Pipes.Prelude as P
import Pipes.Safe (runSafeT)
import System.Directory (createDirectoryIfMissing, createFileLink)
import System.Directory (createDirectoryIfMissing,
createFileLink)
import System.FilePath (takeFileName, (</>))
@ -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