module Graphics.Image.ColorSpace.YCbCr (
YCbCr(..), YCbCrA(..), Pixel(..),
ToYCbCr(..), ToYCbCrA(..)
) where
import Prelude hiding (map)
import Control.Applicative
import Data.Foldable
import Data.Typeable (Typeable)
import Foreign.Ptr
import Foreign.Storable
import Graphics.Image.Interface
data YCbCr = LumaYCbCr
| CBlueYCbCr
| CRedYCbCr
deriving (Eq, Enum, Show, Bounded, Typeable)
data instance Pixel YCbCr e = PixelYCbCr !e !e !e deriving Eq
instance Show e => Show (Pixel YCbCr e) where
show (PixelYCbCr y b r) = "<YCbCr:("++show y++"|"++show b++"|"++show r++")>"
instance (Elevator e, Typeable e) => ColorSpace YCbCr e where
type Components YCbCr e = (e, e, e)
promote !e = PixelYCbCr e e e
fromComponents !(y, b, r) = PixelYCbCr y b r
toComponents (PixelYCbCr y b r) = (y, b, r)
getPxC (PixelYCbCr y _ _) LumaYCbCr = y
getPxC (PixelYCbCr _ b _) CBlueYCbCr = b
getPxC (PixelYCbCr _ _ r) CRedYCbCr = r
setPxC (PixelYCbCr _ b r) LumaYCbCr y = PixelYCbCr y b r
setPxC (PixelYCbCr y _ r) CBlueYCbCr b = PixelYCbCr y b r
setPxC (PixelYCbCr y b _) CRedYCbCr r = PixelYCbCr y b r
mapPxC f (PixelYCbCr y b r) = PixelYCbCr (f LumaYCbCr y) (f CBlueYCbCr b) (f CRedYCbCr r)
liftPx = fmap
liftPx2 = liftA2
foldlPx = foldl'
foldlPx2 f !z (PixelYCbCr y1 b1 r1) (PixelYCbCr y2 b2 r2) =
f (f (f z y1 y2) b1 b2) r1 r2
instance Functor (Pixel YCbCr) where
fmap f (PixelYCbCr y b r) = PixelYCbCr (f y) (f b) (f r)
instance Applicative (Pixel YCbCr) where
pure !e = PixelYCbCr e e e
(PixelYCbCr fy fb fr) <*> (PixelYCbCr y b r) = PixelYCbCr (fy y) (fb b) (fr r)
instance Foldable (Pixel YCbCr) where
foldr f !z (PixelYCbCr y b r) = f y (f b (f r z))
instance Storable e => Storable (Pixel YCbCr e) where
sizeOf _ = 3 * sizeOf (undefined :: e)
alignment _ = alignment (undefined :: e)
peek p = do
q <- return $ castPtr p
y <- peek q
b <- peekElemOff q 1
r <- peekElemOff q 2
return (PixelYCbCr y b r)
poke p (PixelYCbCr y b r) = do
q <- return $ castPtr p
pokeElemOff q 0 y
pokeElemOff q 1 b
pokeElemOff q 2 r
data YCbCrA = LumaYCbCrA
| CBlueYCbCrA
| CRedYCbCrA
| AlphaYCbCrA
deriving (Eq, Enum, Show, Bounded, Typeable)
data instance Pixel YCbCrA e = PixelYCbCrA !e !e !e !e deriving Eq
instance Show e => Show (Pixel YCbCrA e) where
show (PixelYCbCrA y b r a) = "<YCbCrA:("++show y++"|"++show b++"|"++show r++"|"++show a++")>"
instance (Elevator e, Typeable e) => ColorSpace YCbCrA e where
type Components YCbCrA e = (e, e, e, e)
promote !e = PixelYCbCrA e e e e
fromComponents !(y, b, r, a) = PixelYCbCrA y b r a
toComponents (PixelYCbCrA y b r a) = (y, b, r, a)
getPxC (PixelYCbCrA y _ _ _) LumaYCbCrA = y
getPxC (PixelYCbCrA _ b _ _) CBlueYCbCrA = b
getPxC (PixelYCbCrA _ _ r _) CRedYCbCrA = r
getPxC (PixelYCbCrA _ _ _ a) AlphaYCbCrA = a
setPxC (PixelYCbCrA _ b r a) LumaYCbCrA y = PixelYCbCrA y b r a
setPxC (PixelYCbCrA y _ r a) CBlueYCbCrA b = PixelYCbCrA y b r a
setPxC (PixelYCbCrA y b _ a) CRedYCbCrA r = PixelYCbCrA y b r a
setPxC (PixelYCbCrA y b r _) AlphaYCbCrA a = PixelYCbCrA y b r a
mapPxC f (PixelYCbCrA y b r a) =
PixelYCbCrA (f LumaYCbCrA y) (f CBlueYCbCrA b) (f CRedYCbCrA r) (f AlphaYCbCrA a)
liftPx = fmap
liftPx2 = liftA2
foldlPx = foldl'
foldlPx2 f !z (PixelYCbCrA y1 b1 r1 a1) (PixelYCbCrA y2 b2 r2 a2) =
f (f (f (f z y1 y2) b1 b2) r1 r2) a1 a2
class ColorSpace cs Double => ToYCbCr cs where
toPixelYCbCr :: Pixel cs Double -> Pixel YCbCr Double
toImageYCbCr :: (Array arr cs Double, Array arr YCbCr Double) =>
Image arr cs Double
-> Image arr YCbCr Double
toImageYCbCr = map toPixelYCbCr
class (ToYCbCr (Opaque cs), AlphaSpace cs Double) => ToYCbCrA cs where
toPixelYCbCrA :: Pixel cs Double -> Pixel YCbCrA Double
toPixelYCbCrA px = addAlpha (getAlpha px) (toPixelYCbCr (dropAlpha px))
toImageYCbCrA :: (Array arr cs Double, Array arr YCbCrA Double) =>
Image arr cs Double
-> Image arr YCbCrA Double
toImageYCbCrA = map toPixelYCbCrA
instance (Elevator e, Typeable e) => AlphaSpace YCbCrA e where
type Opaque YCbCrA = YCbCr
getAlpha (PixelYCbCrA _ _ _ a) = a
addAlpha !a (PixelYCbCr y b r) = PixelYCbCrA y b r a
dropAlpha (PixelYCbCrA y b r _) = PixelYCbCr y b r
instance Functor (Pixel YCbCrA) where
fmap f (PixelYCbCrA y b r a) = PixelYCbCrA (f y) (f b) (f r) (f a)
instance Applicative (Pixel YCbCrA) where
pure !e = PixelYCbCrA e e e e
(PixelYCbCrA fy fb fr fa) <*> (PixelYCbCrA y b r a) = PixelYCbCrA (fy y) (fb b) (fr r) (fa a)
instance Foldable (Pixel YCbCrA) where
foldr f !z (PixelYCbCrA y b r a) = f y (f b (f r (f a z)))
instance Storable e => Storable (Pixel YCbCrA e) where
sizeOf _ = 3 * sizeOf (undefined :: e)
alignment _ = alignment (undefined :: e)
peek p = do
q <- return $ castPtr p
y <- peekElemOff q 0
b <- peekElemOff q 1
r <- peekElemOff q 2
a <- peekElemOff q 3
return (PixelYCbCrA y b r a)
poke p (PixelYCbCrA y b r a) = do
q <- return $ castPtr p
poke q y
pokeElemOff q 1 b
pokeElemOff q 2 r
pokeElemOff q 3 a