gistfile1.hs

import System.Directory
import Codec.Picture
import Data.Either

type RGB = (Int, Int, Int)

main :: IO ()
main =
  run "blocks" 1 "/Users/anton/Downloads/fantasy_art_blizzard_entertainment_artwork_starcraft_heart_of_desktop_1920x1080_hd-wallpaper-949727.png" "test3.html"

run :: FilePath -> Int -> FilePath -> FilePath -> IO ()
run path res inputImg out = do
  db <- build path
  (outRes, img) <- slice inputImg res
  save outRes out $ zip [0..] . fmap (`search` db) $ img

build :: FilePath -> IO [(FilePath, RGB)]
build path = do
  files <- getDirectoryContents path
  (paths, img) <- fmap (unzip . filter (isRight . snd)) $ sequence $ fmap ((\n -> readImage n >>= \f -> return (n, f)) . ((path ++ "/") ++)) files
  return $ zip paths $ average . extractFull <$> rights img

slice :: FilePath -> Int -> IO (Int, [RGB])
slice img res = do
  Right dyn@(ImageRGB8 (Image w h _)) <- readImage img
  return (div w res, [ average (extractPartial dyn (res*x) ((res*(x+1))-res) (res*y) (res*(y+1)-res)) | y <- [0..(div h res - 1)], x <- [0..(div w res - 1)]])

pixSum :: [RGB] -> (Integer, Integer, Integer)
pixSum = foldl (\(accR, accG, accB) (r, g, b) -> (accR + fromIntegral r, accG + fromIntegral g, accB + fromIntegral b)) (0, 0, 0)

pixAvg :: Integer -> (Integer, Integer, Integer) -> RGB
pixAvg n (a, b, c) = (fromIntegral . div a $ n, fromIntegral . div b $ n, fromIntegral . div c $ n)

average :: [RGB] -> RGB
average l = pixAvg (fromIntegral . length $ l) . pixSum $ l

srcVal :: RGB -> RGB -> Double
srcVal (r1, g1, b1) (r2, g2, b2) =  sqrt . fromIntegral $ r^2 + g^2 + b^2
  where
    r = r1 - r2
    g = g1 - g2
    b = b1 - b2

srcFld :: RGB -> (FilePath, Double) -> (FilePath, RGB) -> (FilePath, Double)
srcFld rgb acc@(_, val) (dbFile, dbRGB)
  | newVal < val = (dbFile, newVal)
  | otherwise    = acc
  where newVal = srcVal rgb dbRGB

search :: RGB -> [(FilePath, RGB)] -> FilePath
search rgb ((p, dbRGB):db) = fst $ foldl (srcFld rgb) (p, srcVal rgb dbRGB) db

pixels :: Pixel t => Image t -> Int -> Int -> Int -> Int -> [t]
pixels img x1 x2 y1 y2  = [pixelAt img x y | x <- [x1..x2], y <- [y1..y2]]

extractPartial :: DynamicImage -> Int -> Int -> Int -> Int -> [RGB]
extractPartial (ImageRGB8 img) x1 x2 y1 y2 =  (\(PixelRGB8 r g b) -> (fromIntegral r, fromIntegral g, fromIntegral b)) <$> pixels img x1 x2 y1 y2
extractPartial (ImageRGBA8 img) x1 x2 y1 y2 =  (\(PixelRGBA8 r g b _) -> (fromIntegral r, fromIntegral g, fromIntegral b)) <$> pixels img x1 x2 y1 y2

extractFull :: DynamicImage -> [RGB]
extractFull img@(ImageRGBA8 (Image w h _)) = extractPartial img 0 (w-1) 0 (h-1)
extractFull img@(ImageRGB8 (Image w h _)) = extractPartial img 0 (w-1) 0 (h-1)

imgTag :: String -> String
imgTag p = "<img src=\"" ++ p ++ "\">"

str :: Int -> (Int, String) -> String
str res (i,p) 
  | mod (i + 1) res == 0 = imgTag p ++ "</div><div style=\"white-space: nowrap;\">"
  | otherwise            = imgTag p

save :: Int -> FilePath -> [(Int, String)] -> IO()
save res out x = writeFile out $ "<div style=\"white-space: nowrap;\">" ++ foldr ((++) . str res) "" x ++ "</div>"