module Codec.Picture.Types(
Image( .. )
, MutableImage( .. )
, DynamicImage( .. )
, freezeImage
, unsafeFreezeImage
, Pixel8
, PixelF
, PixelYA8( .. )
, PixelRGB8( .. )
, PixelRGBF( .. )
, PixelRGBA8( .. )
, PixelYCbCr8( .. )
, ColorConvertible( .. )
, Pixel(..)
, ColorSpaceConvertible( .. )
, LumaPlaneExtractable( .. )
, TransparentPixel( .. )
, pixelMap
, pixelFold
, dropAlphaLayer
, generateImage
, generateFoldImage
, gammaCorrection
, toneMapping
, ColorPlane ( )
, PlaneRed( .. )
, PlaneGreen( .. )
, PlaneBlue( .. )
, PlaneAlpha( .. )
, PlaneLuma( .. )
, PlaneCr( .. )
, PlaneCb( .. )
, extractComponent
, unsafeExtractComponent
) where
import Control.Monad( forM_, foldM )
import Control.Applicative( (<$>) )
import Control.DeepSeq( NFData( .. ) )
import Control.Monad.ST( ST, runST )
import Control.Monad.Primitive ( PrimMonad, PrimState )
import Foreign.Storable ( Storable )
import Data.Word( Word8 )
import Data.List( foldl' )
import Data.Vector.Storable ( (!) )
import qualified Data.Vector.Storable as V
import qualified Data.Vector.Storable.Mutable as M
#include "ConvGraph.hs"
data Image a = Image
{
imageWidth :: !Int
, imageHeight :: !Int
, imageData :: V.Vector (PixelBaseComponent a)
}
(!!!) :: (Storable e) => V.Vector e -> Int -> e
(!!!) = V.unsafeIndex
class ColorPlane pixel planeToken where
toComponentIndex :: pixel -> planeToken -> Int
data PlaneRed = PlaneRed
data PlaneGreen = PlaneGreen
data PlaneBlue = PlaneBlue
data PlaneAlpha = PlaneAlpha
data PlaneLuma = PlaneLuma
data PlaneCr = PlaneCr
data PlaneCb = PlaneCb
instance ColorPlane PixelYCbCr8 PlaneLuma where
toComponentIndex _ _ = 0
instance ColorPlane PixelYCbCr8 PlaneCb where
toComponentIndex _ _ = 1
instance ColorPlane PixelYCbCr8 PlaneCr where
toComponentIndex _ _ = 2
instance ColorPlane PixelYA8 PlaneLuma where
toComponentIndex _ _ = 0
instance ColorPlane PixelYA8 PlaneAlpha where
toComponentIndex _ _ = 1
instance ColorPlane PixelRGB8 PlaneRed where
toComponentIndex _ _ = 0
instance ColorPlane PixelRGB8 PlaneGreen where
toComponentIndex _ _ = 1
instance ColorPlane PixelRGB8 PlaneBlue where
toComponentIndex _ _ = 2
instance ColorPlane PixelRGBF PlaneRed where
toComponentIndex _ _ = 0
instance ColorPlane PixelRGBF PlaneGreen where
toComponentIndex _ _ = 1
instance ColorPlane PixelRGBF PlaneBlue where
toComponentIndex _ _ = 2
instance ColorPlane PixelRGBA8 PlaneRed where
toComponentIndex _ _ = 0
instance ColorPlane PixelRGBA8 PlaneGreen where
toComponentIndex _ _ = 1
instance ColorPlane PixelRGBA8 PlaneBlue where
toComponentIndex _ _ = 2
instance ColorPlane PixelRGBA8 PlaneAlpha where
toComponentIndex _ _ = 3
extractComponent :: forall px plane. ( Pixel px
, Pixel (PixelBaseComponent px)
, PixelBaseComponent (PixelBaseComponent px)
~ PixelBaseComponent px
, ColorPlane px plane )
=> plane -> Image px -> Image (PixelBaseComponent px)
extractComponent plane = unsafeExtractComponent idx
where idx = toComponentIndex (undefined :: px) plane
unsafeExtractComponent :: forall a
. ( Pixel a
, Pixel (PixelBaseComponent a)
, PixelBaseComponent (PixelBaseComponent a)
~ PixelBaseComponent a)
=> Int
-> Image a
-> Image (PixelBaseComponent a)
unsafeExtractComponent comp img@(Image { imageWidth = w, imageHeight = h })
| comp >= padd = error $ "extractComponent : invalid component index ("
++ show comp ++ ", max:" ++ show padd ++ ")"
| otherwise = Image { imageWidth = w, imageHeight = h, imageData = plane }
where plane = stride img 1 padd comp
padd = componentCount (undefined :: a)
dropAlphaLayer :: (TransparentPixel a b) => Image a -> Image b
dropAlphaLayer = pixelMap dropTransparency
class (Pixel a, Pixel b) => TransparentPixel a b | a -> b where
dropTransparency :: a -> b
instance TransparentPixel PixelYA8 Pixel8 where
dropTransparency (PixelYA8 y _) = y
instance TransparentPixel PixelRGBA8 PixelRGB8 where
dropTransparency (PixelRGBA8 r g b _) = PixelRGB8 r g b
stride :: (Storable (PixelBaseComponent a))
=> Image a -> Int -> Int -> Int -> V.Vector (PixelBaseComponent a)
stride Image { imageWidth = w, imageHeight = h, imageData = array }
run padd firstComponent = runST $ do
let cell_count = w * h * run
outArray <- M.new cell_count
let strideWrite write_idx _ | write_idx == cell_count = return ()
strideWrite write_idx read_idx = do
forM_ [0 .. run 1] $ \i ->
(outArray .<-. (write_idx + i)) $ array !!! (read_idx + i)
strideWrite (write_idx + run) (read_idx + padd)
strideWrite 0 firstComponent
V.unsafeFreeze outArray
instance NFData (Image a) where
rnf (Image width height dat) = width `seq`
height `seq`
dat `seq`
()
data MutableImage s a = MutableImage
{
mutableImageWidth :: !Int
, mutableImageHeight :: !Int
, mutableImageData :: M.STVector s (PixelBaseComponent a)
}
freezeImage :: (Storable (PixelBaseComponent a))
=> MutableImage s a -> ST s (Image a)
freezeImage (MutableImage w h d) = Image w h <$> V.freeze d
unsafeFreezeImage :: (Storable (PixelBaseComponent a))
=> MutableImage s a -> ST s (Image a)
unsafeFreezeImage (MutableImage w h d) = Image w h <$> V.unsafeFreeze d
instance NFData (MutableImage s a) where
rnf (MutableImage width height dat) = width `seq`
height `seq`
dat `seq`
()
data DynamicImage =
ImageY8 (Image Pixel8)
| ImageYF (Image PixelF)
| ImageYA8 (Image PixelYA8)
| ImageRGB8 (Image PixelRGB8)
| ImageRGBF (Image PixelRGBF)
| ImageRGBA8 (Image PixelRGBA8)
| ImageYCbCr8 (Image PixelYCbCr8)
instance NFData DynamicImage where
rnf (ImageY8 img) = rnf img
rnf (ImageYF img) = rnf img
rnf (ImageYA8 img) = rnf img
rnf (ImageRGB8 img) = rnf img
rnf (ImageRGBF img) = rnf img
rnf (ImageRGBA8 img) = rnf img
rnf (ImageYCbCr8 img) = rnf img
type Pixel8 = Word8
type PixelF = Float
data PixelYA8 = PixelYA8 !Word8
!Word8
data PixelRGB8 = PixelRGB8 !Word8
!Word8
!Word8
data PixelRGBF = PixelRGBF !PixelF
!PixelF
!PixelF
data PixelYCbCr8 = PixelYCbCr8 !Word8
!Word8
!Word8
data PixelRGBA8 = PixelRGBA8 !Word8
!Word8
!Word8
!Word8
class ( Storable (PixelBaseComponent a), Num (PixelBaseComponent a) ) => Pixel a where
type PixelBaseComponent a :: *
componentCount :: a -> Int
colorMap :: (PixelBaseComponent a -> PixelBaseComponent a) -> a -> a
pixelBaseIndex :: Image a -> Int -> Int -> Int
pixelBaseIndex (Image { imageWidth = w }) x y =
(x + y * w) * componentCount (undefined :: a)
mutablePixelBaseIndex :: MutableImage s a -> Int -> Int -> Int
mutablePixelBaseIndex (MutableImage { mutableImageWidth = w }) x y =
(x + y * w) * componentCount (undefined :: a)
pixelAt :: Image a -> Int -> Int -> a
readPixel :: MutableImage s a -> Int -> Int -> ST s a
writePixel :: MutableImage s a -> Int -> Int -> a -> ST s ()
class (Pixel a, Pixel b) => ColorConvertible a b where
promotePixel :: a -> b
promoteImage :: Image a -> Image b
promoteImage = pixelMap promotePixel
class (Pixel a, Pixel b) => ColorSpaceConvertible a b where
convertPixel :: a -> b
convertImage :: Image a -> Image b
convertImage = pixelMap convertPixel
generateImage :: forall a. (Pixel a)
=> (Int -> Int -> a)
-> Int
-> Int
-> Image a
generateImage f w h = Image { imageWidth = w, imageHeight = h, imageData = generated }
where compCount = componentCount (undefined :: a)
generated = runST $ do
arr <- M.new (w * h * compCount)
let mutImage = MutableImage {
mutableImageWidth = w,
mutableImageHeight = h,
mutableImageData = arr }
forM_ [(x,y) | y <- [0 .. h1], x <- [0 .. w1]] $ \(x,y) ->
writePixel mutImage x y $ f x y
V.unsafeFreeze arr
generateFoldImage :: forall a acc. (Pixel a)
=> (acc -> Int -> Int -> (acc, a))
-> acc
-> Int
-> Int
-> (acc, Image a)
generateFoldImage f intialAcc w h =
(finalState, Image { imageWidth = w, imageHeight = h, imageData = generated })
where compCount = componentCount (undefined :: a)
(finalState, generated) = runST $ do
arr <- M.new (w * h * compCount)
let mutImage = MutableImage {
mutableImageWidth = w,
mutableImageHeight = h,
mutableImageData = arr }
foldResult <- foldM (\acc (x,y) -> do
let (acc', px) = f acc x y
writePixel mutImage x y px
return acc') intialAcc [(x,y) | y <- [0 .. h1], x <- [0 .. w1]]
frozen <- V.unsafeFreeze arr
return (foldResult, frozen)
pixelFold :: (Pixel pixel)
=> (acc -> Int -> Int -> pixel -> acc) -> acc -> Image pixel -> acc
pixelFold f initialAccumulator img@(Image { imageWidth = w, imageHeight = h }) =
lineFold
where pixelFolder y acc x = f acc x y $ pixelAt img x y
columnFold lineAcc y = foldl' (pixelFolder y) lineAcc [0 .. w 1]
lineFold = foldl' columnFold initialAccumulator [0 .. h 1]
pixelMap :: forall a b. (Pixel a, Pixel b)
=> (a -> b) -> Image a -> Image b
pixelMap f image@(Image { imageWidth = w, imageHeight = h }) =
Image w h pixels
where pixels = runST $ do
newArr <- M.replicate (w * h * componentCount (undefined :: b)) 0
let wrapped = MutableImage w h newArr
promotedPixel :: Int -> Int -> b
promotedPixel x y = f $ pixelAt image x y
sequence_ [writePixel wrapped x y $ promotedPixel x y
| y <- [0 .. h 1], x <- [0 .. w 1] ]
V.unsafeFreeze newArr
class (Pixel a, Pixel (PixelBaseComponent a)) => LumaPlaneExtractable a where
computeLuma :: a -> (PixelBaseComponent a)
extractLumaPlane :: Image a -> Image (PixelBaseComponent a)
extractLumaPlane = pixelMap computeLuma
instance LumaPlaneExtractable Pixel8 where
computeLuma = id
extractLumaPlane = id
instance LumaPlaneExtractable PixelF where
computeLuma = id
extractLumaPlane = id
instance LumaPlaneExtractable PixelRGB8 where
computeLuma (PixelRGB8 r g b) = floor $ 0.3 * toRational r +
0.59 * toRational g +
0.11 * toRational b
instance LumaPlaneExtractable PixelRGBF where
computeLuma (PixelRGBF r g b) =
0.3 * r + 0.59 * g + 0.11 * b
instance LumaPlaneExtractable PixelRGBA8 where
computeLuma (PixelRGBA8 r g b _) = floor $ 0.3 * toRational r +
0.59 * toRational g +
0.11 * toRational b
instance LumaPlaneExtractable PixelYA8 where
computeLuma (PixelYA8 y _) = y
extractLumaPlane = extractComponent PlaneLuma
instance LumaPlaneExtractable PixelYCbCr8 where
computeLuma (PixelYCbCr8 y _ _) = y
extractLumaPlane = extractComponent PlaneLuma
instance (Pixel a) => ColorConvertible a a where
promotePixel = id
promoteImage = id
(.!!!.) :: (PrimMonad m, Storable a) => M.STVector (PrimState m) a -> Int -> m a
(.!!!.) = M.read
(.<-.) :: (PrimMonad m, Storable a) => M.STVector (PrimState m) a -> Int -> a -> m ()
(.<-.) = M.write
instance Pixel Pixel8 where
type PixelBaseComponent Pixel8 = Word8
colorMap f = f
componentCount _ = 1
pixelAt (Image { imageWidth = w, imageData = arr }) x y = arr ! (x + y * w)
readPixel image@(MutableImage { mutableImageData = arr }) x y =
arr .!!!. mutablePixelBaseIndex image x y
writePixel image@(MutableImage { mutableImageData = arr }) x y =
arr .<-. mutablePixelBaseIndex image x y
instance Pixel PixelF where
type PixelBaseComponent PixelF = Float
colorMap f = f
componentCount _ = 1
pixelAt (Image { imageWidth = w, imageData = arr }) x y = arr ! (x + y * w)
readPixel image@(MutableImage { mutableImageData = arr }) x y =
arr .!!!. mutablePixelBaseIndex image x y
writePixel image@(MutableImage { mutableImageData = arr }) x y =
arr .<-. mutablePixelBaseIndex image x y
instance ColorConvertible Pixel8 PixelYA8 where
promotePixel c = PixelYA8 c 255
instance ColorConvertible Pixel8 PixelF where
promotePixel c = fromIntegral c / 255.0
instance ColorConvertible Pixel8 PixelRGB8 where
promotePixel c = PixelRGB8 c c c
instance ColorConvertible Pixel8 PixelRGBA8 where
promotePixel c = PixelRGBA8 c c c 255
instance ColorConvertible PixelF PixelRGBF where
promotePixel c = PixelRGBF c c c
instance Pixel PixelYA8 where
type PixelBaseComponent PixelYA8 = Word8
colorMap f (PixelYA8 y a) = PixelYA8 (f y) (f a)
componentCount _ = 2
pixelAt image@(Image { imageData = arr }) x y = PixelYA8 (arr ! (baseIdx + 0))
(arr ! (baseIdx + 1))
where baseIdx = pixelBaseIndex image x y
readPixel image@(MutableImage { mutableImageData = arr }) x y = do
yv <- arr .!!!. baseIdx
av <- arr .!!!. (baseIdx + 1)
return $ PixelYA8 yv av
where baseIdx = mutablePixelBaseIndex image x y
writePixel image@(MutableImage { mutableImageData = arr }) x y (PixelYA8 yv av) = do
let baseIdx = mutablePixelBaseIndex image x y
(arr .<-. (baseIdx + 0)) yv
(arr .<-. (baseIdx + 1)) av
instance ColorConvertible PixelYA8 PixelRGB8 where
promotePixel (PixelYA8 y _) = PixelRGB8 y y y
instance ColorConvertible PixelYA8 PixelRGBA8 where
promotePixel (PixelYA8 y a) = PixelRGBA8 y y y a
instance Pixel PixelRGBF where
type PixelBaseComponent PixelRGBF = PixelF
colorMap f (PixelRGBF r g b) = PixelRGBF (f r) (f g) (f b)
componentCount _ = 3
pixelAt image@(Image { imageData = arr }) x y = PixelRGBF (arr ! (baseIdx + 0))
(arr ! (baseIdx + 1))
(arr ! (baseIdx + 2))
where baseIdx = pixelBaseIndex image x y
readPixel image@(MutableImage { mutableImageData = arr }) x y = do
rv <- arr .!!!. baseIdx
gv <- arr .!!!. (baseIdx + 1)
bv <- arr .!!!. (baseIdx + 2)
return $ PixelRGBF rv gv bv
where baseIdx = mutablePixelBaseIndex image x y
writePixel image@(MutableImage { mutableImageData = arr }) x y (PixelRGBF rv gv bv) = do
let baseIdx = mutablePixelBaseIndex image x y
(arr .<-. (baseIdx + 0)) rv
(arr .<-. (baseIdx + 1)) gv
(arr .<-. (baseIdx + 2)) bv
instance Pixel PixelRGB8 where
type PixelBaseComponent PixelRGB8 = Word8
colorMap f (PixelRGB8 r g b) = PixelRGB8 (f r) (f g) (f b)
componentCount _ = 3
pixelAt image@(Image { imageData = arr }) x y = PixelRGB8 (arr ! (baseIdx + 0))
(arr ! (baseIdx + 1))
(arr ! (baseIdx + 2))
where baseIdx = pixelBaseIndex image x y
readPixel image@(MutableImage { mutableImageData = arr }) x y = do
rv <- arr .!!!. baseIdx
gv <- arr .!!!. (baseIdx + 1)
bv <- arr .!!!. (baseIdx + 2)
return $ PixelRGB8 rv gv bv
where baseIdx = mutablePixelBaseIndex image x y
writePixel image@(MutableImage { mutableImageData = arr }) x y (PixelRGB8 rv gv bv) = do
let baseIdx = mutablePixelBaseIndex image x y
(arr .<-. (baseIdx + 0)) rv
(arr .<-. (baseIdx + 1)) gv
(arr .<-. (baseIdx + 2)) bv
instance ColorConvertible PixelRGB8 PixelRGBA8 where
promotePixel (PixelRGB8 r g b) = PixelRGBA8 r g b 255
instance ColorConvertible PixelRGB8 PixelRGBF where
promotePixel (PixelRGB8 r g b) = PixelRGBF (toF r) (toF g) (toF b)
where toF v = fromIntegral v / 255
instance Pixel PixelRGBA8 where
type PixelBaseComponent PixelRGBA8 = Word8
colorMap f (PixelRGBA8 r g b a) = PixelRGBA8 (f r) (f g) (f b) (f a)
componentCount _ = 4
pixelAt image@(Image { imageData = arr }) x y = PixelRGBA8 (arr ! (baseIdx + 0))
(arr ! (baseIdx + 1))
(arr ! (baseIdx + 2))
(arr ! (baseIdx + 3))
where baseIdx = pixelBaseIndex image x y
readPixel image@(MutableImage { mutableImageData = arr }) x y = do
rv <- arr .!!!. baseIdx
gv <- arr .!!!. (baseIdx + 1)
bv <- arr .!!!. (baseIdx + 2)
av <- arr .!!!. (baseIdx + 3)
return $ PixelRGBA8 rv gv bv av
where baseIdx = mutablePixelBaseIndex image x y
writePixel image@(MutableImage { mutableImageData = arr }) x y (PixelRGBA8 rv gv bv av) = do
let baseIdx = mutablePixelBaseIndex image x y
(arr .<-. (baseIdx + 0)) rv
(arr .<-. (baseIdx + 1)) gv
(arr .<-. (baseIdx + 2)) bv
(arr .<-. (baseIdx + 3)) av
instance Pixel PixelYCbCr8 where
type PixelBaseComponent PixelYCbCr8 = Word8
colorMap f (PixelYCbCr8 y cb cr) = PixelYCbCr8 (f y) (f cb) (f cr)
componentCount _ = 3
pixelAt image@(Image { imageData = arr }) x y = PixelYCbCr8 (arr ! (baseIdx + 0))
(arr ! (baseIdx + 1))
(arr ! (baseIdx + 2))
where baseIdx = pixelBaseIndex image x y
readPixel image@(MutableImage { mutableImageData = arr }) x y = do
yv <- arr .!!!. baseIdx
cbv <- arr .!!!. (baseIdx + 1)
crv <- arr .!!!. (baseIdx + 2)
return $ PixelYCbCr8 yv cbv crv
where baseIdx = mutablePixelBaseIndex image x y
writePixel image@(MutableImage { mutableImageData = arr }) x y (PixelYCbCr8 yv cbv crv) = do
let baseIdx = mutablePixelBaseIndex image x y
(arr .<-. (baseIdx + 0)) yv
(arr .<-. (baseIdx + 1)) cbv
(arr .<-. (baseIdx + 2)) crv
instance (Pixel a) => ColorSpaceConvertible a a where
convertPixel = id
convertImage = id
instance ColorSpaceConvertible PixelRGB8 PixelYCbCr8 where
convertPixel (PixelRGB8 r g b) = PixelYCbCr8 (truncate y)
(truncate cb)
(truncate cr)
where rf = fromIntegral r :: Float
gf = fromIntegral g
bf = fromIntegral b
y = 0.29900 * rf + 0.58700 * gf + 0.11400 * bf
cb = 0.16874 * rf 0.33126 * gf + 0.50000 * bf + 128
cr = 0.50000 * rf 0.41869 * gf 0.08131 * bf + 128
instance ColorSpaceConvertible PixelYCbCr8 PixelRGB8 where
convertPixel (PixelYCbCr8 y_w8 cb_w8 cr_w8) = PixelRGB8 (clampWord8 r) (clampWord8 g) (clampWord8 b)
where y :: Float
y = fromIntegral y_w8 128.0
cb = fromIntegral cb_w8 128.0
cr = fromIntegral cr_w8 128.0
clampWord8 = truncate . max 0.0 . min 255.0 . (128 +)
cred = 0.299
cgreen = 0.587
cblue = 0.114
r = cr * (2 2 * cred) + y
b = cb * (2 2 * cblue) + y
g = (y cblue * b cred * r) / cgreen
gammaCorrection :: PixelF
-> Image PixelRGBF
-> Image PixelRGBF
gammaCorrection gammaVal = pixelMap gammaCorrector
where gammaExponent = 1.0 / gammaVal
fixVal v = v ** gammaExponent
gammaCorrector (PixelRGBF r g b) =
PixelRGBF (fixVal r) (fixVal g) (fixVal b)
toneMapping :: PixelF
-> Image PixelRGBF
-> Image PixelRGBF
toneMapping exposure img = Image (imageWidth img) (imageHeight img) scaledData
where coeff = exposure * (exposure / maxBrightness + 1.0) / (exposure + 1.0);
maxBrightness = pixelFold (\luma _ _ px -> max luma $ computeLuma px) 0 img
scaledData = V.map (* coeff) $ imageData img