{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ViewPatterns #-}
module Graphics.Image.Processing.Geometric (
downsampleRows, downsampleCols, downsample,
upsampleRows, upsampleCols, upsample,
leftToRight, topToBottom,
translate, canvasSize, crop, superimpose,
flipV, flipH,
rotate90, rotate180, rotate270, rotate,
resize, scale
) where
#if MIN_VERSION_base(4,8,0)
import Prelude hiding (traverse)
#endif
import qualified Data.Vector as V
import Graphics.Image.Interface
import Graphics.Image.Processing.Interpolation
downsample :: Array arr cs e =>
(Int -> Bool)
-> (Int -> Bool)
-> Image arr cs e
-> Image arr cs e
downsample mPred nPred !img =
traverse img (const (V.length rowsIx, V.length colsIx)) getNewPx where
!(m, n) = dims img
!rowsIx = V.filter (not . mPred) $ V.enumFromN 0 m
!colsIx = V.filter (not . nPred) $ V.enumFromN 0 n
getNewPx getPx !(i, j) = getPx (V.unsafeIndex rowsIx i, V.unsafeIndex colsIx j)
{-# INLINE downsample #-}
upsample :: Array arr cs e =>
(Int -> (Int, Int))
-> (Int -> (Int, Int))
-> Image arr cs e
-> Image arr cs e
upsample mAdd nAdd !img = traverse img (const (newM, newN)) getNewPx where
!(m, n) = dims img
validate !p@(pre, post)
| pre < 0 || post < 0 =
error $ "upsample: negative values are not accepted: " ++ show p
| otherwise = p
!rowsIx = V.unfoldr (spread (V.map (validate . mAdd) $ V.enumFromN 0 m)) (0, Nothing, Nothing)
!colsIx = V.unfoldr (spread (V.map (validate . nAdd) $ V.enumFromN 0 n)) (0, Nothing, Nothing)
!newM = V.length rowsIx
!newN = V.length colsIx
spread !v !params =
case params of
(k, Nothing, Nothing) | k == V.length v -> Nothing
(k, Nothing, Nothing) ->
let (pre, post) = v V.! k in spread v (k, Just pre, Just post)
(k, Just 0, my) -> Just (Just k, (k, Nothing, my))
(k, Just x, my) -> Just (Nothing, (k, Just (x-1), my))
(k, Nothing, Just 0) -> spread v (k+1, Nothing, Nothing)
(k, Nothing, Just y) -> Just (Nothing, (k, Nothing, Just (y-1)))
{-# INLINE spread #-}
getNewPx getPx !(i, j) =
case (V.unsafeIndex rowsIx i, V.unsafeIndex colsIx j) of
(Just i', Just j') -> getPx (i', j')
_ -> 0
{-# INLINE getNewPx #-}
{-# INLINE upsample #-}
downsampleRows :: Array arr cs e => Image arr cs e -> Image arr cs e
downsampleRows = downsample odd (const False)
{-# INLINE downsampleRows #-}
downsampleCols :: Array arr cs e => Image arr cs e -> Image arr cs e
downsampleCols = downsample (const False) odd
{-# INLINE downsampleCols #-}
upsampleRows :: Array arr cs e => Image arr cs e -> Image arr cs e
upsampleRows = upsample (const (0, 1)) (const (0, 0))
{-# INLINE upsampleRows #-}
upsampleCols :: Array arr cs e => Image arr cs e -> Image arr cs e
upsampleCols = upsample (const (0, 0)) (const (0, 1))
{-# INLINE upsampleCols #-}
leftToRight :: Array arr cs e => Image arr cs e -> Image arr cs e -> Image arr cs e
leftToRight !img1@(dims -> (_, n1)) !img2 = traverse2 img1 img2 newDims newPx where
newDims !(m1, _) !(m2, n2)
| m1 == m2 = (m1, n1 + n2)
| otherwise = error ("leftToRight: Images must agree in numer of rows, but received: "
++ show img1 ++ " and " ++ show img2)
{-# INLINE newDims #-}
newPx !getPx1 !getPx2 !(i, j) = if j < n1 then getPx1 (i, j) else getPx2 (i, j-n1)
{-# INLINE newPx #-}
{-# INLINE leftToRight #-}
topToBottom :: Array arr cs e => Image arr cs e -> Image arr cs e -> Image arr cs e
topToBottom !img1@(dims -> (m1, _)) !img2 = traverse2 img1 img2 newDims newPx where
newDims !(_, n1) !(m2, n2)
| n1 == n2 = (m1 + m2, n1)
| otherwise = error ("topToBottom: Images must agree in numer of columns, but received: "
++ show img1 ++ " and " ++ show img2)
{-# INLINE newDims #-}
newPx !getPx1 !getPx2 !(i, j) = if i < m1 then getPx1 (i, j) else getPx2 (i-m1, j)
{-# INLINE newPx #-}
{-# INLINE topToBottom #-}
translate
:: Array arr cs e
=> Border (Pixel cs e)
-> (Int, Int)
-> Image arr cs e -> Image arr cs e
translate atBorder !(dm, dn) !img = traverse img id newPx
where
newPx !getPx !(i, j) =
handleBorderIndex atBorder (dims img) getPx (i - dm, j - dn)
{-# INLINE newPx #-}
{-# INLINE translate #-}
canvasSize
:: Array arr cs e
=> Border (Pixel cs e)
-> (Int, Int)
-> Image arr cs e
-> Image arr cs e
canvasSize atBorder !ds !img = traverse img (const ds) newPx
where
newPx !getPx !ix = handleBorderIndex atBorder (dims img) getPx ix
{-# INLINE newPx #-}
{-# INLINE canvasSize #-}
crop :: Array arr cs e =>
(Int, Int)
-> (Int, Int)
-> Image arr cs e
-> Image arr cs e
crop !(i0, j0) !sz@(m', n') !img
| i0 < 0 || j0 < 0 || i0 >= m || j0 >= n =
error $
"Graphics.Image.Processing.crop: Starting index: " ++
show (i0, j0) ++
" is greater than dimensions of the source image: " ++ show img
| i0 + m' > m || j0 + n' > n =
error $
"Graphics.Image.Processing.crop: Result image dimensions: " ++
show (m', n') ++
" plus the offset: " ++
show (i0, j0) ++ " are bigger than the source image: " ++ show img
| otherwise = backpermute sz (\ !(i, j) -> (i + i0, j + j0)) img
where !(m, n) = dims img
{-# INLINE crop #-}
superimpose :: Array arr cs e =>
(Int, Int)
-> Image arr cs e
-> Image arr cs e
-> Image arr cs e
superimpose !(i0, j0) !imgA !imgB = traverse2 imgB imgA const newPx where
!(m, n) = dims imgA
newPx getPxB getPxA (i, j) = let !(i', j') = (i - i0, j - j0) in
if i' >= 0 && j' >= 0 && i' < m && j' < n then getPxA (i', j') else getPxB (i, j)
{-# INLINE superimpose #-}
flipUsing :: Array arr cs e =>
((Int, Int) -> (Int, Int) -> (Int, Int)) -> Image arr cs e -> Image arr cs e
flipUsing getNewIndex !img@(dims -> sz) = backpermute sz (getNewIndex sz) img
{-# INLINE flipUsing #-}
flipV :: Array arr cs e => Image arr cs e -> Image arr cs e
flipV = flipUsing (\ (m, _) !(i, j) -> (m - 1 - i, j))
{-# INLINE flipV #-}
flipH :: Array arr cs e => Image arr cs e -> Image arr cs e
flipH = flipUsing (\ (_, n) !(i, j) -> (i, n - 1 - j))
{-# INLINE flipH #-}
rotate90 :: Array arr cs e => Image arr cs e -> Image arr cs e
rotate90 = transpose . flipV
{-# INLINE rotate90 #-}
rotate180 :: Array arr cs e => Image arr cs e -> Image arr cs e
rotate180 = flipUsing (\ !(m, n) !(i, j) -> (m - 1 - i, n - 1 - j))
{-# INLINE rotate180 #-}
rotate270 :: Array arr cs e => Image arr cs e -> Image arr cs e
rotate270 = transpose . flipH
{-# INLINE rotate270 #-}
rotate :: (Array arr cs e, Interpolation method) =>
method
-> Border (Pixel cs e)
-> Double
-> Image arr cs e
-> Image arr cs e
rotate !method border !theta' !img = traverse img getNewDims getNewPx where
!theta = angle0to2pi (-theta')
!sz@(m, n) = dims img
!(mD, nD) = (fromIntegral m, fromIntegral n)
!(sinTheta, cosTheta) = (sin' theta, cos' theta)
!(sinThetaAbs, cosThetaAbs) = (abs sinTheta, abs cosTheta)
!(mD', nD') = (mD * cosThetaAbs + nD * sinThetaAbs, nD * cosThetaAbs + mD * sinThetaAbs)
!(iDelta, jDelta) =
case (sinTheta >= 0, cosTheta >= 0) of
(True, True ) -> (nD * sinTheta, 0)
(True, False) -> (mD', -nD * cosTheta)
(False, False) -> (-mD * cosTheta, nD')
(False, True ) -> (0, -mD * sinTheta)
getNewDims _ = (ceiling mD', ceiling nD')
{-# INLINE getNewDims #-}
getNewPx getPx !(i, j) = interpolate method border sz getPx (i', j') where
!(iD, jD) = (fromIntegral i - iDelta + 0.5, fromIntegral j - jDelta + 0.5)
!i' = iD * cosTheta + jD * sinTheta - 0.5
!j' = jD * cosTheta - iD * sinTheta - 0.5
{-# INLINE getNewPx #-}
{-# INLINE rotate #-}
resize :: (Interpolation method, Array arr cs e) =>
method
-> Border (Pixel cs e)
-> (Int, Int)
-> Image arr cs e
-> Image arr cs e
resize !method border !sz'@(m', n') !img = traverse img (const sz') getNewPx where
!sz@(m, n) = dims img
!(fM, fN) = (fromIntegral m' / fromIntegral m, fromIntegral n' / fromIntegral n)
getNewPx !getPx !(i, j) =
interpolate method border sz getPx ((fromIntegral i + 0.5) / fM - 0.5, (fromIntegral j + 0.5) / fN - 0.5)
{-# INLINE getNewPx #-}
{-# INLINE resize #-}
scale :: (Interpolation method, Array arr cs e) =>
method
-> Border (Pixel cs e)
-> (Double, Double)
-> Image arr cs e
-> Image arr cs e
scale !method border !(fM, fN) !img@(dims -> (m, n)) =
if fM <= 0 || fN <= 0
then error "scale: scaling factor must be greater than 0."
else resize method border (round (fM * fromIntegral m), round (fN * fromIntegral n)) img
{-# INLINE scale #-}
angle0to2pi :: Double -> Double
angle0to2pi !f = f - 2 * pi * floor' (f / (2 * pi))
where floor' :: Double -> Double
floor' !x = fromIntegral (floor x :: Int)
{-# INLINE floor' #-}
{-# INLINE angle0to2pi #-}
sin' :: Double -> Double
sin' a = if abs sinA <= _0 then 0 else sinA
where !_0 = 10 * sin pi
!sinA = sin a
{-# INLINE sin' #-}
cos' :: Double -> Double
cos' a = sin' (a + pi/2)
{-# INLINE cos' #-}