module Codec.Picture.Types(
Image( .. )
, MutableImage( .. )
, DynamicImage( .. )
, PixelType( .. )
, Pixel8
, PixelYA8( .. )
, PixelRGB8( .. )
, PixelRGBA8( .. )
, PixelYCbCr8( .. )
, ColorConvertible( .. )
, Pixel(..)
, ColorSpaceConvertible( .. )
, canConvertTo
) where
import Control.Applicative( (<$>), (<*>) )
import Control.Monad.ST( ST )
import Data.Word( Word8 )
import Data.Array.Unboxed( UArray, (!) )
import Data.Array.ST( MArray, STUArray
, writeArray, newArray, runSTUArray, readArray )
import Data.Serialize( Serialize, put, get )
data Image a = Image
{
imageWidth :: !Int
, imageHeight :: !Int
, imageData :: UArray Int Word8
}
data MutableImage s a = MutableImage
{
mutableImageWidth :: !Int
, mutableImageHeight :: !Int
, mutableImageData :: STUArray s Int Word8
}
data DynamicImage =
ImageY8 (Image Pixel8)
| ImageYA8 (Image PixelYA8)
| ImageRGB8 (Image PixelRGB8)
| ImageRGBA8 (Image PixelRGBA8)
| ImageYCbCr8 (Image PixelYCbCr8)
type Pixel8 = Word8
data PixelYA8 = PixelYA8 !Word8
!Word8
data PixelRGB8 = PixelRGB8 !Word8
!Word8
!Word8
data PixelYCbCr8 = PixelYCbCr8 !Word8
!Word8
!Word8
data PixelRGBA8 = PixelRGBA8 !Word8
!Word8
!Word8
!Word8
instance Serialize PixelYA8 where
put (PixelYA8 y a) = put y >> put a
get = PixelYA8 <$> get <*> get
instance Serialize PixelRGB8 where
put (PixelRGB8 r g b) = put r >> put g >> put b
get = PixelRGB8 <$> get <*> get <*> get
instance Serialize PixelYCbCr8 where
put (PixelYCbCr8 y cb cr) = put y >> put cb >> put cr
get = PixelYCbCr8 <$> get <*> get <*> get
instance Serialize PixelRGBA8 where
put (PixelRGBA8 r g b a) = put r >> put g >> put b >> put a
get = PixelRGBA8 <$> get <*> get <*> get <*> get
data PixelType = PixelMonochromatic
| PixelGreyscale
| PixelGreyscaleAlpha
| PixelRedGreenBlue8
| PixelRedGreenBlueAlpha8
| PixelYChromaRChromaB8
deriving Eq
class (Serialize a) => Pixel a where
canPromoteTo :: a -> PixelType -> Bool
componentCount :: a -> Int
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)
promotionType :: a -> PixelType
pixelAt :: Image a -> Int -> Int -> a
readPixel :: MutableImage s a -> Int -> Int -> ST s a
writePixel :: MutableImage s a -> Int -> Int -> a -> ST s ()
canConvertTo :: (Pixel a, Pixel b) => a -> b -> Bool
canConvertTo a b = canPromoteTo a $ promotionType b
class (Pixel a, Pixel b) => ColorConvertible a b where
promotePixel :: a -> b
promoteImage :: Image a -> Image b
promoteImage image@(Image { imageWidth = w, imageHeight = h }) =
Image w h pixels
where pixels = runSTUArray $ do
newArr <- newArray (0, w * h * componentCount (undefined :: b) 1) 0
let wrapped = MutableImage w h newArr
promotedPixel :: Int -> Int -> b
promotedPixel x y = promotePixel $ pixelAt image x y
sequence_ [writePixel wrapped x y $ promotedPixel x y
| y <- [0 .. h 1], x <- [0 .. w 1] ]
return newArr
class (Pixel a, Pixel b) => ColorSpaceConvertible a b where
convertPixel :: a -> b
convertImage :: Image a -> Image b
convertImage image@(Image { imageWidth = w, imageHeight = h }) =
Image w h pixels
where pixels = runSTUArray $ do
newArr <- newArray (0, w * h * componentCount (undefined :: b) 1) 0
let wrapped = MutableImage w h newArr
promotedPixel :: Int -> Int -> b
promotedPixel x y = convertPixel $ pixelAt image x y
sequence_ [writePixel wrapped x y $ promotedPixel x y
| y <- [0 .. h 1], x <- [0 .. w 1] ]
return newArr
instance (Pixel a) => ColorConvertible a a where
promotePixel = id
promoteImage = id
(.!!!.) :: (MArray array e m) => array Int e -> Int -> m e
(.!!!.) = readArray
(.<-.) :: (MArray array e m) => array Int e -> Int -> e -> m ()
(.<-.) = writeArray
instance Pixel Pixel8 where
canPromoteTo _ a = a /= PixelMonochromatic
promotionType _ = PixelGreyscale
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 v =
(arr .<-. (mutablePixelBaseIndex image x y)) v
instance ColorConvertible Pixel8 PixelYA8 where
promotePixel c = PixelYA8 c 255
instance ColorConvertible Pixel8 PixelRGB8 where
promotePixel c = PixelRGB8 c c c
instance ColorConvertible Pixel8 PixelRGBA8 where
promotePixel c = PixelRGBA8 c c c 255
instance Pixel PixelYA8 where
canPromoteTo _ a = a == PixelRedGreenBlueAlpha8
promotionType _ = PixelGreyscaleAlpha
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 PixelRGB8 where
canPromoteTo _ PixelMonochromatic = False
canPromoteTo _ PixelGreyscale = False
canPromoteTo _ _ = True
componentCount _ = 3
promotionType _ = PixelRedGreenBlue8
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 Pixel PixelRGBA8 where
canPromoteTo _ PixelRedGreenBlueAlpha8 = True
canPromoteTo _ _ = False
promotionType _ = PixelRedGreenBlueAlpha8
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
canPromoteTo _ _ = False
promotionType _ = PixelYChromaRChromaB8
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 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