module Graphics.Image.ColorSpace.Y (
Y(..), YA(..), Pixel(..),
ToY(..), ToYA(..)
) 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 Y = LumaY deriving (Eq, Enum, Show, Bounded, Typeable)
newtype instance Pixel Y e = PixelY e deriving (Ord, Eq)
class ColorSpace cs Double => ToY cs where
toPixelY :: Pixel cs Double -> Pixel Y Double
toImageY :: (Array arr cs Double, Array arr Y Double) =>
Image arr cs Double
-> Image arr Y Double
toImageY = map toPixelY
instance Show e => Show (Pixel Y e) where
show (PixelY g) = "<Luma:("++show g++")>"
instance (Elevator e, Typeable e) => ColorSpace Y e where
type Components Y e = e
promote = PixelY
fromComponents = PixelY
toComponents (PixelY y) = y
getPxC (PixelY y) LumaY = y
setPxC _ LumaY y = PixelY y
mapPxC f (PixelY y) = PixelY (f LumaY y)
liftPx = fmap
liftPx2 = liftA2
foldlPx = foldl'
foldlPx2 f !z (PixelY y1) (PixelY y2) = f z y1 y2
instance Functor (Pixel Y) where
fmap f (PixelY y) = PixelY (f y)
instance Applicative (Pixel Y) where
pure = PixelY
(PixelY fy) <*> (PixelY y) = PixelY (fy y)
instance Foldable (Pixel Y) where
foldr f !z (PixelY y) = f y z
instance Monad (Pixel Y) where
return = PixelY
(>>=) (PixelY y) f = f y
instance Storable e => Storable (Pixel Y e) where
sizeOf _ = sizeOf (undefined :: e)
alignment _ = alignment (undefined :: e)
peek p = do
q <- return $ castPtr p
y <- peek q
return (PixelY y)
poke p (PixelY y) = do
q <- return $ castPtr p
poke q y
data YA = LumaYA
| AlphaYA
deriving (Eq, Enum, Show, Bounded, Typeable)
data instance Pixel YA e = PixelYA !e !e deriving Eq
class (ToY (Opaque cs), AlphaSpace cs Double) => ToYA cs where
toPixelYA :: Pixel cs Double -> Pixel YA Double
toPixelYA px = addAlpha (getAlpha px) (toPixelY (dropAlpha px))
toImageYA :: (Array arr cs Double, Array arr YA Double) =>
Image arr cs Double
-> Image arr YA Double
toImageYA = map toPixelYA
instance (Elevator e, Typeable e) => ColorSpace YA e where
type Components YA e = (e, e)
promote e = PixelYA e e
fromComponents (y, a) = PixelYA y a
toComponents (PixelYA y a) = (y, a)
getPxC (PixelYA y _) LumaYA = y
getPxC (PixelYA _ a) AlphaYA = a
setPxC (PixelYA _ a) LumaYA y = PixelYA y a
setPxC (PixelYA y _) AlphaYA a = PixelYA y a
mapPxC f (PixelYA y a) = PixelYA (f LumaYA y) (f AlphaYA a)
liftPx = fmap
liftPx2 = liftA2
foldlPx = foldl'
foldlPx2 f !z (PixelYA y1 a1) (PixelYA y2 a2) = f (f z y1 y2) a1 a2
instance (Elevator e, Typeable e) => AlphaSpace YA e where
type Opaque YA = Y
getAlpha (PixelYA _ a) = a
addAlpha !a (PixelY y) = PixelYA y a
dropAlpha (PixelYA y _) = PixelY y
instance Functor (Pixel YA) where
fmap f (PixelYA y a) = PixelYA (f y) (f a)
instance Applicative (Pixel YA) where
pure !e = PixelYA e e
(PixelYA fy fa) <*> (PixelYA y a) = PixelYA (fy y) (fa a)
instance Foldable (Pixel YA) where
foldr f !z (PixelYA y a) = f y (f a z)
instance Storable e => Storable (Pixel YA e) where
sizeOf _ = 2 * sizeOf (undefined :: e)
alignment _ = alignment (undefined :: e)
peek p = do
q <- return $ castPtr p
y <- peekElemOff q 0
a <- peekElemOff q 1
return (PixelYA y a)
poke p (PixelYA y a) = do
q <- return $ castPtr p
pokeElemOff q 0 y
pokeElemOff q 1 a