{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeSynonymInstances #-}
module Graphics.Image.Processing.Filter
(
Filter (Filter)
, applyFilter
, Direction(..)
, gaussianLowPass
, gaussianBlur
, sobelFilter
, sobelOperator
, prewittFilter
, prewittOperator
, laplacianFilter
, logFilter
, gaussianSmoothingFilter
, meanFilter
, unsharpMaskingFilter
) where
import Graphics.Image.Interface as I
import Graphics.Image.Processing.Convolution
import Graphics.Image.ColorSpace (X)
data Filter arr cs e = Filter
{ applyFilter :: Image arr cs e -> Image arr cs e
}
data Direction
= Vertical
| Horizontal
gaussianLowPass :: (Array arr cs e, Array arr X e, Floating e, Fractional e) =>
Int
-> e
-> Border (Pixel cs e)
-> Filter arr cs e
gaussianLowPass !r !sigma border =
Filter (correlate border gV' . correlate border gV)
where
!gV = compute $ (gauss / scalar weight)
!gV' = compute $ transpose gV
!gauss = makeImage (1, n) getPx
!weight = I.fold (+) 0 gauss
!n = 2 * r + 1
!sigma2sq = 2 * sigma ^ (2 :: Int)
getPx (_, j) = promote $ exp (fromIntegral (-((j - r) ^ (2 :: Int))) / sigma2sq)
{-# INLINE getPx #-}
{-# INLINE gaussianLowPass #-}
gaussianBlur :: (Array arr cs e, Array arr X e, Floating e, RealFrac e) =>
e
-> Filter arr cs e
gaussianBlur !sigma = gaussianLowPass (ceiling (2*sigma)) sigma Edge
{-# INLINE gaussianBlur #-}
sobelFilter :: (Array arr cs e, Array arr X e) =>
Direction -> Border (Pixel cs e) -> Filter arr cs e
sobelFilter dir !border =
Filter (correlate border kernel)
where
!kernel =
case dir of
Vertical -> fromLists $ [ [ -1, -2, -1 ]
, [ 0, 0, 0 ]
, [ 1, 2, 1 ] ]
Horizontal -> fromLists $ [ [ -1, 0, 1 ]
, [ -2, 0, 2 ]
, [ -1, 0, 1 ] ]
{-# INLINE sobelFilter #-}
sobelOperator :: (Array arr cs e, Array arr X e, Floating e) => Image arr cs e -> Image arr cs e
sobelOperator !img = sqrt (sobelX ^ (2 :: Int) + sobelY ^ (2 :: Int))
where !sobelX = applyFilter (sobelFilter Horizontal Edge) img
!sobelY = applyFilter (sobelFilter Vertical Edge) img
{-# INLINE sobelOperator #-}
prewittFilter :: (Array arr cs e, Array arr X e) =>
Direction -> Border (Pixel cs e) -> Filter arr cs e
prewittFilter dir !border =
Filter (convolveCols border cV . convolveRows border rV)
where
!(rV, cV) =
case dir of
Vertical -> ([1, 1, 1], [1, 0, -1])
Horizontal -> ([1, 0, -1], [1, 1, 1])
{-# INLINE prewittFilter #-}
prewittOperator :: (Array arr cs e, Array arr X e, Floating e) => Image arr cs e -> Image arr cs e
prewittOperator !img = sqrt (prewittX ^ (2 :: Int) + prewittY ^ (2 :: Int))
where !prewittX = applyFilter (prewittFilter Horizontal Edge) img
!prewittY = applyFilter (prewittFilter Vertical Edge) img
{-# INLINE prewittOperator #-}
laplacianFilter :: (Array arr cs e, Array arr X e) =>
Border (Pixel cs e) -> Filter arr cs e
laplacianFilter !border =
Filter (correlate border kernel)
where
!kernel = fromLists $ [ [ -1, -1, -1 ]
, [ -1, 8, -1 ]
, [ -1, -1, -1 ]]
{-# INLINE laplacianFilter #-}
logFilter :: (Array arr cs e, Array arr X e) =>
Border (Pixel cs e) -> Filter arr cs e
logFilter !border =
Filter (correlate border kernel)
where
!kernel = fromLists $ [ [ 0, 1, 1, 2, 2, 2, 1, 1, 0 ]
, [ 1, 2, 4, 5, 5, 5, 4, 2, 1 ]
, [ 1, 4, 5, 3, 0, 3, 5, 4, 1 ]
, [ 2, 5, 3, -12, -24, -12, 3, 5, 2 ]
, [ 2, 5, 0, -24, -40, -24, 0, 5, 2 ]
, [ 2, 5, 3, -12, -24, -12, 3, 5, 2 ]
, [ 1, 4, 5, 3, 0, 3, 5, 4, 1 ]
, [ 1, 2, 4, 5, 5, 5, 4, 2, 1 ]
, [ 0, 1, 1, 2, 2, 2, 1, 1, 0 ] ]
{-# INLINE logFilter #-}
gaussianSmoothingFilter :: (Fractional e, Array arr cs e, Array arr X e) =>
Border (Pixel cs e) -> Filter arr cs e
gaussianSmoothingFilter !border =
Filter (I.map (/ 273) . correlate border kernel)
where
!kernel = fromLists $ [[ 1, 4, 7, 4, 1 ]
,[ 4, 16, 26, 16, 4 ]
,[ 7, 26, 41, 26, 7 ]
,[ 4, 16, 26, 16, 4 ]
,[ 1, 4, 7, 4, 1 ]]
{-# INLINE gaussianSmoothingFilter #-}
meanFilter :: (Fractional e, Array arr cs e, Array arr X e) =>
Border (Pixel cs e) -> Filter arr cs e
meanFilter !border =
Filter (I.map (/ 9) . correlate border kernel)
where
!kernel = fromLists $[ [ 1, 1, 1 ]
, [ 1, 1, 1 ]
, [ 1, 1, 1 ]]
{-# INLINE meanFilter #-}
unsharpMaskingFilter :: (Fractional e, Array arr cs e, Array arr X e) =>
Border (Pixel cs e) -> Filter arr cs e
unsharpMaskingFilter !border =
Filter (I.map (/256) . correlate border kernel)
where
!kernel = fromLists $ [[ -1, -4, -6, -4, -1 ]
,[ -4, -16, -24, -16, -4 ]
,[ -6, -24, 476, -24, -6 ]
,[ -4, -16, -24, -16, -4 ]
,[ -1, -4, -6, -4, -1 ]]
{-# INLINE unsharpMaskingFilter #-}