bones of image file rescaler to be fitted into Hakyll site

scale images preserving ratios.hs

{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeOperators   #-}

module Main  where

import Codec.Picture
import Codec.Picture.Types as M
import System.Environment (getArgs)
import System.FilePath (replaceExtension)
import qualified Codec.Picture.Metadata as M
import qualified Codec.Picture.Extra as E
import Control.Error
import Control.Monad.ST

main :: IO ()
main = do
  [quality, longEdge, path] <- getArgs
  let le = read longEdge
  let q  = read quality
  dynImg <- readImage path
  let pxlImg = resize le dynImg
  case pxlImg of
    (Right img) -> saveJpgImage q "newimage.jpg" img
    (Left err) -> print ("OMG an error" ++ err)
  return ()

resize :: Int -> Either String DynamicImage -> Either String DynamicImage
resize longEdge (Right (ImageRGB8 image@(Image w h _)))
  = Right $ ImageRGB8 $ resize' longEdge image
resize longEdge (Right (ImageYCbCr8 image@(Image w h _)))
  = Right $ ImageRGB8 $ resize' longEdge (convertImage image)
resize longEdge (Right (ImageCMYK8 image@(Image w h _)))
  = Right $ ImageRGB8 $ resize' longEdge (convertImage image)

resize longEdge (Right (ImageRGB16 image@(Image w h _)))
  = Right $ ImageRGB16 $ resize16' longEdge image
resize longEdge (Right (ImageCMYK16 image@(Image w h _)))
  = Right $ ImageRGB16 $ resize16' longEdge (convertImage image)

resize _ _ = Left "unsupported image format"

resize' :: Int -> Image PixelRGB8 -> Image PixelRGB8
resize' longEdge image@(Image w h _) = E.scaleBilinear nw nh image
    where
        (nw,nh) = chooseNewDimensions longEdge w h

resize16' :: Int -> Image PixelRGB16 -> Image PixelRGB16
resize16' longEdge image@(Image w h _) = scaleBilinear16 nw nh image
    where
        (nw,nh) = chooseNewDimensions longEdge w h

chooseNewDimensions :: Int -> Int -> Int -> (Int, Int)
chooseNewDimensions longEdge w h =
  toInts $ chooseR le $ toRationals (w,h)
  where
    le = toRational longEdge
    toInts (w,h) = (floor w, floor h)
    toRationals (w,h) = (toRational w, toRational h)
    chooseR le (w,h) = (w * ratio, h * ratio) -- calc needs to be done as Rationals
      where ratio = le / max w h


-- straight copy from JuicyPixels-extras adapted for 16 bit images
scaleBilinear16
  :: Int               -- ^ Desired width
  -> Int               -- ^ Desired height
  -> Image PixelRGB16   -- ^ Original image
  -> Image PixelRGB16   -- ^ Scaled image
scaleBilinear16 width height img@Image {..} = runST $ do
  mimg <- M.newMutableImage width height
  let sx, sy :: Float
      sx = fromIntegral imageWidth  / fromIntegral width
      sy = fromIntegral imageHeight / fromIntegral height
      go x' y'
        | x' >= width = go 0 (y' + 1)
        | y' >= height = M.unsafeFreezeImage mimg
        | otherwise = do
            let xf = fromIntegral x' * sx
                yf = fromIntegral y' * sy
                x, y :: Int
                x  = floor xf
                y  = floor yf
                δx = xf - fromIntegral x
                δy = yf - fromIntegral y
                pixelAt' i j =
                  if i >= imageWidth || j >= imageHeight
                    then PixelRGB16 0 0 0
                    else pixelAt img i j
            writePixel mimg x' y' $
              mulp16 (pixelAt' x y) ((1 - δx) * (1 - δy)) `addp16`
              mulp16 (pixelAt' (x + 1) y) (δx * (1 - δy)) `addp16`
              mulp16 (pixelAt' x (y + 1)) ((1 - δx) * δy) `addp16`
              mulp16 (pixelAt' (x + 1) (y + 1)) (δx * δy)
            go (x' + 1) y'
  go 0 0

mulp16 :: PixelRGB16 -> Float -> PixelRGB16
mulp16 pixel x = colorMap (floor . (* x) . fromIntegral) pixel
{-# INLINE mulp16 #-}

addp16 :: PixelRGB16 -> PixelRGB16 -> PixelRGB16
addp16 = mixWith (const f)
  where
    f x y = fromIntegral $
      (0xff :: Pixel16) `min` (fromIntegral x + fromIntegral y)
{-# INLINE addp16 #-}