{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Codec.Picture.Extra
(
scaleBilinear,
crop,
flipHorizontally,
flipVertically,
rotateLeft90,
rotateRight90,
rotate180,
beside,
below,
)
where
import Codec.Picture
import qualified Codec.Picture.Types as M
import Control.Monad.ST
import Data.List (foldl1')
scaleBilinear ::
( Pixel a,
Bounded (PixelBaseComponent a),
Integral (PixelBaseComponent a)
) =>
Int ->
Int ->
Image a ->
Image a
scaleBilinear :: Int -> Int -> Image a -> Image a
scaleBilinear Int
width Int
height img :: Image a
img@Image {Int
Vector (PixelBaseComponent a)
imageWidth :: forall a. Image a -> Int
imageHeight :: forall a. Image a -> Int
imageData :: forall a. Image a -> Vector (PixelBaseComponent a)
imageData :: Vector (PixelBaseComponent a)
imageHeight :: Int
imageWidth :: Int
..}
| Int
width Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 Bool -> Bool -> Bool
|| Int
height Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 =
(Int -> Int -> a) -> Int -> Int -> Image a
forall px. Pixel px => (Int -> Int -> px) -> Int -> Int -> Image px
generateImage ([Char] -> Int -> Int -> a
forall a. HasCallStack => [Char] -> a
error [Char]
"scaleBilinear: absurd") (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 Int
width) (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 Int
height)
| Bool
otherwise = (forall s. ST s (Image a)) -> Image a
forall a. (forall s. ST s a) -> a
runST ((forall s. ST s (Image a)) -> Image a)
-> (forall s. ST s (Image a)) -> Image a
forall a b. (a -> b) -> a -> b
$ do
MutableImage s a
mimg <- Int -> Int -> ST s (MutableImage (PrimState (ST s)) a)
forall px (m :: * -> *).
(Pixel px, PrimMonad m) =>
Int -> Int -> m (MutableImage (PrimState m) px)
M.newMutableImage Int
width Int
height
let sx, sy :: Float
sx :: Float
sx = Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
imageWidth Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
width
sy :: Float
sy = Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
imageHeight Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
height
go :: Int -> Int -> ST s (Image a)
go Int
x' Int
y'
| Int
x' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
width = Int -> Int -> ST s (Image a)
go Int
0 (Int
y' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
| Int
y' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
height = MutableImage (PrimState (ST s)) a -> ST s (Image a)
forall a (m :: * -> *).
(Storable (PixelBaseComponent a), PrimMonad m) =>
MutableImage (PrimState m) a -> m (Image a)
M.unsafeFreezeImage MutableImage s a
MutableImage (PrimState (ST s)) a
mimg
| Bool
otherwise = do
let xf :: Float
xf = Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
x' Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
sx
yf :: Float
yf = Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
y' Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
sy
x, y :: Int
x :: Int
x = Float -> Int
forall a b. (RealFrac a, Integral b) => a -> b
floor Float
xf
y :: Int
y = Float -> Int
forall a b. (RealFrac a, Integral b) => a -> b
floor Float
yf
δx :: Float
δx = Float
xf Float -> Float -> Float
forall a. Num a => a -> a -> a
- Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
x
δy :: Float
δy = Float
yf Float -> Float -> Float
forall a. Num a => a -> a -> a
- Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
y
pixelAt' :: Int -> Int -> a
pixelAt' Int
i Int
j =
Image a -> Int -> Int -> a
forall a. Pixel a => Image a -> Int -> Int -> a
pixelAt Image a
img (Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (Int -> Int
forall a. Enum a => a -> a
pred Int
imageWidth) Int
i) (Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (Int -> Int
forall a. Enum a => a -> a
pred Int
imageHeight) Int
j)
MutableImage (PrimState (ST s)) a -> Int -> Int -> a -> ST s ()
forall a (m :: * -> *).
(Pixel a, PrimMonad m) =>
MutableImage (PrimState m) a -> Int -> Int -> a -> m ()
writePixel MutableImage s a
MutableImage (PrimState (ST s)) a
mimg Int
x' Int
y' (a -> ST s ()) -> a -> ST s ()
forall a b. (a -> b) -> a -> b
$
a -> Float -> a
forall a.
(Pixel a, Integral (PixelBaseComponent a)) =>
a -> Float -> a
mulp (Int -> Int -> a
pixelAt' Int
x Int
y) ((Float
1 Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
δx) Float -> Float -> Float
forall a. Num a => a -> a -> a
* (Float
1 Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
δy))
a -> a -> a
forall a.
(Pixel a, Bounded (PixelBaseComponent a),
Integral (PixelBaseComponent a)) =>
a -> a -> a
`addp` a -> Float -> a
forall a.
(Pixel a, Integral (PixelBaseComponent a)) =>
a -> Float -> a
mulp (Int -> Int -> a
pixelAt' (Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int
y) (Float
δx Float -> Float -> Float
forall a. Num a => a -> a -> a
* (Float
1 Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
δy))
a -> a -> a
forall a.
(Pixel a, Bounded (PixelBaseComponent a),
Integral (PixelBaseComponent a)) =>
a -> a -> a
`addp` a -> Float -> a
forall a.
(Pixel a, Integral (PixelBaseComponent a)) =>
a -> Float -> a
mulp (Int -> Int -> a
pixelAt' Int
x (Int
y Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)) ((Float
1 Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
δx) Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
δy)
a -> a -> a
forall a.
(Pixel a, Bounded (PixelBaseComponent a),
Integral (PixelBaseComponent a)) =>
a -> a -> a
`addp` a -> Float -> a
forall a.
(Pixel a, Integral (PixelBaseComponent a)) =>
a -> Float -> a
mulp (Int -> Int -> a
pixelAt' (Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Int
y Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)) (Float
δx Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
δy)
Int -> Int -> ST s (Image a)
go (Int
x' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int
y'
Int -> Int -> ST s (Image a)
go Int
0 Int
0
{-# SPECIALIZE scaleBilinear :: Int -> Int -> Image M.PixelRGBA16 -> Image M.PixelRGBA16 #-}
{-# SPECIALIZE scaleBilinear :: Int -> Int -> Image M.PixelRGBA8 -> Image M.PixelRGBA8 #-}
{-# SPECIALIZE scaleBilinear :: Int -> Int -> Image M.PixelCMYK16 -> Image M.PixelCMYK16 #-}
{-# SPECIALIZE scaleBilinear :: Int -> Int -> Image M.PixelCMYK8 -> Image M.PixelCMYK8 #-}
{-# SPECIALIZE scaleBilinear :: Int -> Int -> Image M.PixelYCbCr8 -> Image M.PixelYCbCr8 #-}
{-# SPECIALIZE scaleBilinear :: Int -> Int -> Image M.PixelRGB16 -> Image M.PixelRGB16 #-}
{-# SPECIALIZE scaleBilinear :: Int -> Int -> Image M.PixelYCbCrK8 -> Image M.PixelYCbCrK8 #-}
{-# SPECIALIZE scaleBilinear :: Int -> Int -> Image M.PixelRGB8 -> Image M.PixelRGB8 #-}
{-# SPECIALIZE scaleBilinear :: Int -> Int -> Image M.PixelYA16 -> Image M.PixelYA16 #-}
{-# SPECIALIZE scaleBilinear :: Int -> Int -> Image M.PixelYA8 -> Image M.PixelYA8 #-}
{-# SPECIALIZE scaleBilinear :: Int -> Int -> Image M.Pixel32 -> Image M.Pixel32 #-}
{-# SPECIALIZE scaleBilinear :: Int -> Int -> Image M.Pixel16 -> Image M.Pixel16 #-}
{-# SPECIALIZE scaleBilinear :: Int -> Int -> Image M.Pixel8 -> Image M.Pixel8 #-}
mulp :: (Pixel a, Integral (PixelBaseComponent a)) => a -> Float -> a
mulp :: a -> Float -> a
mulp a
pixel Float
x = (PixelBaseComponent a -> PixelBaseComponent a) -> a -> a
forall a.
Pixel a =>
(PixelBaseComponent a -> PixelBaseComponent a) -> a -> a
colorMap (Float -> PixelBaseComponent a
forall a b. (RealFrac a, Integral b) => a -> b
floor (Float -> PixelBaseComponent a)
-> (PixelBaseComponent a -> Float)
-> PixelBaseComponent a
-> PixelBaseComponent a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
x) (Float -> Float)
-> (PixelBaseComponent a -> Float) -> PixelBaseComponent a -> Float
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PixelBaseComponent a -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral) a
pixel
{-# INLINE mulp #-}
addp ::
forall a.
( Pixel a,
Bounded (PixelBaseComponent a),
Integral (PixelBaseComponent a)
) =>
a ->
a ->
a
addp :: a -> a -> a
addp = (Int
-> PixelBaseComponent a
-> PixelBaseComponent a
-> PixelBaseComponent a)
-> a -> a -> a
forall a.
Pixel a =>
(Int
-> PixelBaseComponent a
-> PixelBaseComponent a
-> PixelBaseComponent a)
-> a -> a -> a
mixWith ((PixelBaseComponent a
-> PixelBaseComponent a -> PixelBaseComponent a)
-> Int
-> PixelBaseComponent a
-> PixelBaseComponent a
-> PixelBaseComponent a
forall a b. a -> b -> a
const PixelBaseComponent a
-> PixelBaseComponent a -> PixelBaseComponent a
forall a a b. (Integral a, Integral a, Num b) => a -> a -> b
f)
where
f :: a -> a -> b
f a
x a
y =
PixelBaseComponent a -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral (PixelBaseComponent a -> b) -> PixelBaseComponent a -> b
forall a b. (a -> b) -> a -> b
$
(PixelBaseComponent a
forall a. Bounded a => a
maxBound :: PixelBaseComponent a) PixelBaseComponent a
-> PixelBaseComponent a -> PixelBaseComponent a
forall a. Ord a => a -> a -> a
`min` (a -> PixelBaseComponent a
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
x PixelBaseComponent a
-> PixelBaseComponent a -> PixelBaseComponent a
forall a. Num a => a -> a -> a
+ a -> PixelBaseComponent a
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
y)
{-# INLINE addp #-}
crop ::
Pixel a =>
Int ->
Int ->
Int ->
Int ->
Image a ->
Image a
crop :: Int -> Int -> Int -> Int -> Image a -> Image a
crop Int
x' Int
y' Int
w' Int
h' img :: Image a
img@Image {Int
Vector (PixelBaseComponent a)
imageData :: Vector (PixelBaseComponent a)
imageHeight :: Int
imageWidth :: Int
imageWidth :: forall a. Image a -> Int
imageHeight :: forall a. Image a -> Int
imageData :: forall a. Image a -> Vector (PixelBaseComponent a)
..} =
(Int -> Int -> a) -> Int -> Int -> Image a
forall px. Pixel px => (Int -> Int -> px) -> Int -> Int -> Image px
generateImage Int -> Int -> a
gen Int
w Int
h
where
gen :: Int -> Int -> a
gen Int
i Int
j = Image a -> Int -> Int -> a
forall a. Pixel a => Image a -> Int -> Int -> a
pixelAt Image a
img (Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
i) (Int
y Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
j)
x :: Int
x = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (Int
imageWidth Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Int
x'
y :: Int
y = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (Int
imageHeight Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Int
y'
w :: Int
w = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (Int
imageWidth Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
x) Int
w'
h :: Int
h = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (Int
imageHeight Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
y) Int
h'
{-# INLINEABLE crop #-}
flipHorizontally :: Pixel a => Image a -> Image a
flipHorizontally :: Image a -> Image a
flipHorizontally img :: Image a
img@Image {Int
Vector (PixelBaseComponent a)
imageData :: Vector (PixelBaseComponent a)
imageHeight :: Int
imageWidth :: Int
imageWidth :: forall a. Image a -> Int
imageHeight :: forall a. Image a -> Int
imageData :: forall a. Image a -> Vector (PixelBaseComponent a)
..} =
(Int -> Int -> a) -> Int -> Int -> Image a
forall px. Pixel px => (Int -> Int -> px) -> Int -> Int -> Image px
generateImage Int -> Int -> a
gen Int
imageWidth Int
imageHeight
where
gen :: Int -> Int -> a
gen Int
x = Image a -> Int -> Int -> a
forall a. Pixel a => Image a -> Int -> Int -> a
pixelAt Image a
img (Int
imageWidth Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
x)
{-# INLINEABLE flipHorizontally #-}
flipVertically :: Pixel a => Image a -> Image a
flipVertically :: Image a -> Image a
flipVertically img :: Image a
img@Image {Int
Vector (PixelBaseComponent a)
imageData :: Vector (PixelBaseComponent a)
imageHeight :: Int
imageWidth :: Int
imageWidth :: forall a. Image a -> Int
imageHeight :: forall a. Image a -> Int
imageData :: forall a. Image a -> Vector (PixelBaseComponent a)
..} =
(Int -> Int -> a) -> Int -> Int -> Image a
forall px. Pixel px => (Int -> Int -> px) -> Int -> Int -> Image px
generateImage Int -> Int -> a
gen Int
imageWidth Int
imageHeight
where
gen :: Int -> Int -> a
gen Int
x Int
y = Image a -> Int -> Int -> a
forall a. Pixel a => Image a -> Int -> Int -> a
pixelAt Image a
img Int
x (Int
imageHeight Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
y)
{-# INLINEABLE flipVertically #-}
rotateLeft90 :: Pixel a => Image a -> Image a
rotateLeft90 :: Image a -> Image a
rotateLeft90 img :: Image a
img@Image {Int
Vector (PixelBaseComponent a)
imageData :: Vector (PixelBaseComponent a)
imageHeight :: Int
imageWidth :: Int
imageWidth :: forall a. Image a -> Int
imageHeight :: forall a. Image a -> Int
imageData :: forall a. Image a -> Vector (PixelBaseComponent a)
..} =
(Int -> Int -> a) -> Int -> Int -> Image a
forall px. Pixel px => (Int -> Int -> px) -> Int -> Int -> Image px
generateImage Int -> Int -> a
gen Int
imageHeight Int
imageWidth
where
gen :: Int -> Int -> a
gen Int
x Int
y = Image a -> Int -> Int -> a
forall a. Pixel a => Image a -> Int -> Int -> a
pixelAt Image a
img (Int
imageWidth Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
y) Int
x
{-# INLINEABLE rotateLeft90 #-}
rotateRight90 :: Pixel a => Image a -> Image a
rotateRight90 :: Image a -> Image a
rotateRight90 img :: Image a
img@Image {Int
Vector (PixelBaseComponent a)
imageData :: Vector (PixelBaseComponent a)
imageHeight :: Int
imageWidth :: Int
imageWidth :: forall a. Image a -> Int
imageHeight :: forall a. Image a -> Int
imageData :: forall a. Image a -> Vector (PixelBaseComponent a)
..} =
(Int -> Int -> a) -> Int -> Int -> Image a
forall px. Pixel px => (Int -> Int -> px) -> Int -> Int -> Image px
generateImage Int -> Int -> a
gen Int
imageHeight Int
imageWidth
where
gen :: Int -> Int -> a
gen Int
x Int
y = Image a -> Int -> Int -> a
forall a. Pixel a => Image a -> Int -> Int -> a
pixelAt Image a
img Int
y (Int
imageHeight Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
x)
{-# INLINEABLE rotateRight90 #-}
rotate180 :: Pixel a => Image a -> Image a
rotate180 :: Image a -> Image a
rotate180 img :: Image a
img@(Image Int
w Int
h Vector (PixelBaseComponent a)
_) = (Int -> Int -> a) -> Int -> Int -> Image a
forall px. Pixel px => (Int -> Int -> px) -> Int -> Int -> Image px
generateImage Int -> Int -> a
g Int
w Int
h
where
g :: Int -> Int -> a
g Int
x Int
y = Image a -> Int -> Int -> a
forall a. Pixel a => Image a -> Int -> Int -> a
pixelAt Image a
img (Int
w Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
x) (Int
h Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
y)
{-# INLINEABLE rotate180 #-}
beside :: Pixel a => [Image a] -> Image a
beside :: [Image a] -> Image a
beside = (Image a -> Image a -> Image a) -> [Image a] -> Image a
forall a. (a -> a -> a) -> [a] -> a
foldl1' Image a -> Image a -> Image a
forall a. Pixel a => Image a -> Image a -> Image a
go
where
go :: Pixel a => Image a -> Image a -> Image a
go :: Image a -> Image a -> Image a
go img1 :: Image a
img1@(Image Int
w1 Int
h1 Vector (PixelBaseComponent a)
_) img2 :: Image a
img2@(Image Int
w2 Int
h2 Vector (PixelBaseComponent a)
_) =
(Int -> Int -> a) -> Int -> Int -> Image a
forall px. Pixel px => (Int -> Int -> px) -> Int -> Int -> Image px
generateImage Int -> Int -> a
g (Int
w1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
w2) Int
h
where
g :: Int -> Int -> a
g Int
x
| Int
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
w1 = Image a -> Int -> Int -> a
forall a. Pixel a => Image a -> Int -> Int -> a
pixelAt Image a
img1 Int
x
| Bool
otherwise = Image a -> Int -> Int -> a
forall a. Pixel a => Image a -> Int -> Int -> a
pixelAt Image a
img2 (Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
w1)
h :: Int
h = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
h1 Int
h2
{-# INLINEABLE beside #-}
below :: Pixel a => [Image a] -> Image a
below :: [Image a] -> Image a
below = (Image a -> Image a -> Image a) -> [Image a] -> Image a
forall a. (a -> a -> a) -> [a] -> a
foldl1' Image a -> Image a -> Image a
forall a. Pixel a => Image a -> Image a -> Image a
go
where
go :: Pixel a => Image a -> Image a -> Image a
go :: Image a -> Image a -> Image a
go img1 :: Image a
img1@(Image Int
w1 Int
h1 Vector (PixelBaseComponent a)
_) img2 :: Image a
img2@(Image Int
w2 Int
h2 Vector (PixelBaseComponent a)
_) =
(Int -> Int -> a) -> Int -> Int -> Image a
forall px. Pixel px => (Int -> Int -> px) -> Int -> Int -> Image px
generateImage Int -> Int -> a
g Int
w (Int
h1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
h2)
where
g :: Int -> Int -> a
g Int
x Int
y
| Int
y Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
h1 = Image a -> Int -> Int -> a
forall a. Pixel a => Image a -> Int -> Int -> a
pixelAt Image a
img1 Int
x Int
y
| Bool
otherwise = Image a -> Int -> Int -> a
forall a. Pixel a => Image a -> Int -> Int -> a
pixelAt Image a
img2 Int
x (Int
y Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
h1)
w :: Int
w = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
w1 Int
w2
{-# INLINEABLE below #-}