fixing scaling issues with #46

This commit is contained in:
nek0 2017-03-24 17:49:11 +01:00
parent e119038b0e
commit 344db7bb86
3 changed files with 87 additions and 4 deletions

View File

@ -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

67
Scale.hs Normal file
View File

@ -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)

View File

@ -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