diff --git a/JuicyPixels-scale-dct.cabal b/JuicyPixels-scale-dct.cabal new file mode 100644 --- /dev/null +++ b/JuicyPixels-scale-dct.cabal @@ -0,0 +1,58 @@ +-- This file has been generated from package.yaml by hpack version 0.8.0. +-- +-- see: https://github.com/sol/hpack + +name: JuicyPixels-scale-dct +version: 0.1.0.0 +synopsis: Scale JuicyPixels images with DCT +description: Scale JuicyPixels Images with DCT +category: Web +homepage: https://github.com/phadej/JuicyPixels-scale-dct#readme +bug-reports: https://github.com/phadej/JuicyPixels-scale-dct/issues +author: Oleg Grenrus +maintainer: Oleg Grenrus +license: BSD3 +license-file: LICENSE +tested-with: GHC==7.8.4, GHC==7.10.2 +build-type: Simple +cabal-version: >= 1.10 + +extra-source-files: + README.md + +source-repository head + type: git + location: https://github.com/phadej/JuicyPixels-scale-dct + +library + hs-source-dirs: + src + ghc-options: -Wall + build-depends: + base >=4.7 && <4.9 + , base-compat >=0.6.0 && <0.9 + , JuicyPixels >=3.2.5.3 && <3.3 + , fft >=0.1.8.1 && <0.2 + , carray >=0.1.6.1 && <0.2 + exposed-modules: + Codec.Picture.ScaleDCT + default-language: Haskell2010 + +test-suite example + type: exitcode-stdio-1.0 + main-is: Example.hs + hs-source-dirs: + example + ghc-options: -Wall + build-depends: + base >=4.7 && <4.9 + , base-compat >=0.6.0 && <0.9 + , JuicyPixels >=3.2.5.3 && <3.3 + , fft >=0.1.8.1 && <0.2 + , carray >=0.1.6.1 && <0.2 + , base + , JuicyPixels + , JuicyPixels-scale-dct + , JuicyPixels-util >=0.2 && <0.3 + , time >=1.4.2 && <1.6 + default-language: Haskell2010 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2015, Oleg Grenrus + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Oleg Grenrus nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,23 @@ +# JuicyPixels-scale-dct + +> Scale JuicyPixels images with DCT + +[![Build Status](https://travis-ci.org/phadej/JuicyPixels-scale-dct.svg?branch=master)](https://travis-ci.org/phadej/JuicyPixels-scale-dct) +[![Hackage](https://img.shields.io/hackage/v/JuicyPixels-scale-dct.svg)](http://hackage.haskell.org/package/JuicyPixels-scale-dct) +[![Stackage LTS 2](http://stackage.org/package/JuicyPixels-scale-dct/badge/lts-2)](http://stackage.org/lts-2/package/JuicyPixels-scale-dct) +[![Stackage LTS 3](http://stackage.org/package/JuicyPixels-scale-dct/badge/lts-3)](http://stackage.org/lts-3/package/JuicyPixels-scale-dct) +[![Stackage Nightly](http://stackage.org/package/JuicyPixels-scale-dct/badge/nightly)](http://stackage.org/nightly/package/JuicyPixels-scale-dct) + +--- + +## Example image + +![phadej](https://raw.githubusercontent.com/phadej/JuicyPixels-scale-dct/master/phadej.png) + +### smaller + +![phadej](https://raw.githubusercontent.com/phadej/JuicyPixels-scale-dct/master/phadej-small.png) + +### larger + +![phadej](https://raw.githubusercontent.com/phadej/JuicyPixels-scale-dct/master/phadej-large.png) diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple +main :: IO () +main = defaultMain diff --git a/example/Example.hs b/example/Example.hs new file mode 100644 --- /dev/null +++ b/example/Example.hs @@ -0,0 +1,18 @@ +module Main (main) where + +import Codec.Picture (readImage, writePng) +import Codec.Picture.RGBA8 (fromDynamicImage) +import Codec.Picture.ScaleDCT (scale) +import Data.Time (diffUTCTime, getCurrentTime) + +main :: IO () +main = do + start <- getCurrentTime + Right dimg <- readImage "phadej.png" + let img = fromDynamicImage dimg + let ava1 = scale (64, 64) img + let ava2 = scale (600, 600) img + writePng "phadej-small.png" ava1 + writePng "phadej-large.png" ava2 + end <- getCurrentTime + print $ end `diffUTCTime` start diff --git a/src/Codec/Picture/ScaleDCT.hs b/src/Codec/Picture/ScaleDCT.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Picture/ScaleDCT.hs @@ -0,0 +1,118 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +----------------------------------------------------------------------------- +-- | +-- Module : Code.Picture.ScaleDCT +-- Copyright : (C) 2015 Oleg Grenrus +-- License : BSD3 +-- Maintainer : Oleg Grenrus +-- +-- Scale pictures using Discrete Cosine Transform. +-- +module Codec.Picture.ScaleDCT (scale) where + +import Prelude () +import Prelude.Compat + +import Codec.Picture (Image (..), PixelRGBA8 (..), Traversal, + generateImage, imagePixels) +import Control.Applicative (Const (..)) +import Data.Array.CArray (CArray, amap, array, bounds, elems, listArray, size, + (!)) +import Data.Ix (inRange, range) +import Data.Monoid (Endo (..)) +import Data.Word (Word8) +import Math.FFT (dct2N, dct3N) +import Data.Coerce (Coercible, coerce) + +type Array2D = CArray (Int, Int) Double + +-- | Scale the image using DCT transform. +scale :: (Int, Int) -- ^ Output width, height + -> Image PixelRGBA8 -- ^ Input image + -> Image PixelRGBA8 -- ^ Output image +scale dim img = fromChannels r' g' b' a' + where + r = channelR img + g = channelG img + b = channelB img + a = channelA img + + transform ch = amap (k*) ch' + where + ch' = dct3N [1, 0] . cut dim . dct2N [0, 1] $ ch + k = imgNorm ch / imgNorm ch' + + r' = transform r + g' = transform g + b' = transform b + a' = transform a + +imgNorm :: Array2D -> Double +imgNorm ch = sqrt . (/n) . sum . fmap sq . elems $ ch + where sq x = x * x + n = fromIntegral $ size ch + +cut :: (Int, Int) -> Array2D -> Array2D +cut (w, h) img = array b [ (i, pick i) | i <- range b ] + where b = ((0,0), (h-1, w-1)) + b' = bounds img + pick i | inRange b' i = img ! i + | otherwise = 0 + +pixelR, pixelG, pixelB, pixelA :: PixelRGBA8 -> Word8 +pixelR (PixelRGBA8 r _ _ _) = r +pixelG (PixelRGBA8 _ g _ _) = g +pixelB (PixelRGBA8 _ _ b _) = b +pixelA (PixelRGBA8 _ _ _ a) = a + +extractChannel :: (PixelRGBA8 -> Word8) -> Image PixelRGBA8 -> Array2D +extractChannel f img@(Image w h _) = listArray ((0, 0), (h - 1, w - 1)) + . map (fromInteger . toInteger . f) + . toListOf imagePixels + $ img + +channelR, channelG, channelB, channelA :: Image PixelRGBA8 -> Array2D +channelR = extractChannel pixelR +channelG = extractChannel pixelG +channelB = extractChannel pixelB +channelA = extractChannel pixelA + +fromChannels :: Array2D + -> Array2D + -> Array2D + -> Array2D + -> Image PixelRGBA8 +fromChannels r g b a = generateImage f w h + where f x y = PixelRGBA8 (f' r) (f' g) (f' b) (f' a) + where i = (y, x) + f' c = truncate (limit $ c ! i) + (_, (h', w')) = bounds r + w = w' + 1 + h = h' + 1 + +limit :: Double -> Double +limit x | x < 0 = 0 + | x > 255 = 255 + | otherwise = x + +-- From 'Control.Lens.Lens' from 'lens' package +toListOf :: Traversal s s a a -> s -> [a] +toListOf l = foldrOf l (:) [] +{-# INLINE toListOf #-} + +foldrOf :: Traversal s s a a -> (a -> r -> r) -> r -> s -> r +foldrOf l f z = flip appEndo z . foldMapOf l (Endo #. f) +{-# INLINE foldrOf #-} + +foldMapOf :: Monoid r => Traversal s s a a -> (a -> r) -> s -> r +foldMapOf l f = getConst #. l (Const #. f) +{-# INLINE foldMapOf #-} + +(#.) :: Coercible c b => (b -> c) -> (a -> b) -> a -> c +(#.) _ = coerce (\x -> x :: b) :: forall a b. Coercible b a => a -> b +{-# INLINE (#.) #-} + +--(.#) :: Coercible b a => (b -> c) -> (a -> b) -> a -> c +--(.#) pbc _ = coerce pbc