diff --git a/Handler/Commons.hs b/Handler/Commons.hs index cbbab20..09ca94a 100755 --- a/Handler/Commons.hs +++ b/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 diff --git a/Scale.hs b/Scale.hs new file mode 100644 index 0000000..b9d3ab5 --- /dev/null +++ b/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 . + +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) diff --git a/eidolon.cabal b/eidolon.cabal index e65638c..9159660 100755 --- a/eidolon.cabal +++ b/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