fixing scaling issues with #46

Handler/Commons.hs

@@ -17,6 +17,7 @@
 module Handler.Commons where
 
 import Import
+import Scale
 import qualified Data.Text as T
 import Data.String
 import qualified Data.List as L
@@ -242,7 +243,21 @@ generateThumbs path uId aId mime = do
     "image/svg+xml" -> do
       svg <- liftIO $ loadSvgFile path
       liftIO $ traceIO "------------------> SVG loaded!"
-      (img, _) <- liftIO $ renderSvgDocument emptyFontCache Nothing 100 $ fromJust svg
+      let (swidth, sheight) = documentSize 100 (fromJust svg)
+          scale =
+            let
+              picScale = (fromIntegral swidth / fromIntegral sheight) :: Double
+              nwidth =
+                if swidth < 1000
+                then 1000 :: Int
+                else swidth
+              nheight =
+                if swidth < 1000
+                then floor (1000 / picScale)
+                else sheight
+            in
+              Just (nwidth, nheight)
+      (img, _) <- liftIO $ renderSvgDocument emptyFontCache scale 100 $ fromJust svg
       liftIO $ traceIO "------------------> SVG rendered!"
       return img
     _ -> do
@@ -265,8 +280,8 @@ generateThumbs path uId aId mime = do
       tWidth = ceiling (fromIntegral oWidth / fromIntegral oHeight * fromIntegral tHeight :: Double)
       pScale = (fromIntegral pHeight :: Double) / (fromIntegral oHeight :: Double)
       pWidth = ceiling (fromIntegral oWidth * pScale)
-      tPix = scale (tWidth, tHeight) orig
-      pPix = scale (pWidth, pHeight) orig
+      tPix = scaleBilinearAlpha tWidth tHeight orig
+      pPix = scaleBilinearAlpha pWidth pHeight orig
   liftIO $ traceIO $ show oWidth
   liftIO $ traceIO "------------------> Image scaled!"
   liftIO $ savePngImage tPath $ ImageRGBA8 tPix

Scale.hs

@@ -0,0 +1,67 @@
+--  eidolon -- A simple gallery in Haskell and Yesod
+--  Copyright (C) 2015-2016  Amedeo Molnár
+--
+--  This program is free software: you can redistribute it and/or modify
+--  it under the terms of the GNU Affero General Public License as published
+--  by the Free Software Foundation, either version 3 of the License, or
+--  (at your option) any later version.
+--
+--  This program is distributed in the hope that it will be useful,
+--  but WITHOUT ANY WARRANTY; without even the implied warranty of
+--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+--  GNU Affero General Public License for more details.
+--
+--  You should have received a copy of the GNU Affero General Public License
+--  along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+module Scale
+  (scaleBilinearAlpha
+  ) where
+
+import Import
+import Codec.Picture
+import Control.Monad.ST
+import qualified Codec.Picture.Types as M
+
+scaleBilinearAlpha
+  :: Int                -- ^ Desired width
+  -> Int                -- ^ Desired height
+  -> Image PixelRGBA8   -- ^ Original image
+  -> Image PixelRGBA8   -- ^ Scaled image
+scaleBilinearAlpha 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 PixelRGBA8 0 0 0 0
+                    else pixelAt img i j
+            writePixel mimg x' y' $
+              mulp (pixelAt' x y) ((1 - δx) * (1 - δy)) `addp`
+              mulp (pixelAt' (x + 1) y) (δx * (1 - δy)) `addp`
+              mulp (pixelAt' x (y + 1)) ((1 - δx) * δy) `addp`
+              mulp (pixelAt' (x + 1) (y + 1)) (δx * δy)
+            go (x' + 1) y'
+  go 0 0
+
+mulp :: PixelRGBA8 -> Float -> PixelRGBA8
+mulp pixel x = colorMap (floor . (* x) . fromIntegral) pixel
+{-# INLINE mulp #-}
+
+addp :: PixelRGBA8 -> PixelRGBA8 -> PixelRGBA8
+addp = mixWith (const f)
+  where
+    f x y = fromIntegral $
+      (0xff :: Pixel8) `min` (fromIntegral x + fromIntegral y)

eidolon.cabal

@@ -1,5 +1,5 @@
 name:                eidolon
-version:             0.1.8.6
+version:             0.1.8.7
 synopsis:            Image gallery in Yesod
 homepage:            https://eidolon.nek0.eu
 license:             AGPL-3
@@ -26,6 +26,7 @@ library
                      Helper
                      Import
                      Model
+                     Scale
                      Settings
                      Settings.StaticFiles
                      Settings.Development