module Graphics.Image.ColorSpace.Luma (
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, Typeable)
data 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 Y where
show LumaY = "Luma"
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
broadcastC = 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)
mapPx = fmap
zipWithPx = liftA2
foldlPx = foldl'
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 Num e => Num (Pixel Y e) where
(+) = liftA2 (+)
() = liftA2 ()
(*) = liftA2 (*)
abs = liftA abs
signum = liftA signum
fromInteger = pure . fromInteger
instance Fractional e => Fractional (Pixel Y e) where
(/) = liftA2 (/)
recip = liftA recip
fromRational = pure . fromRational
instance Floating e => Floating (Pixel Y e) where
pi = pure pi
exp = liftA exp
log = liftA log
sin = liftA sin
cos = liftA cos
asin = liftA asin
atan = liftA atan
acos = liftA acos
sinh = liftA sinh
cosh = liftA cosh
asinh = liftA asinh
atanh = liftA atanh
acosh = liftA acosh
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, 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 Show YA where
show LumaYA = "Luma"
show AlphaYA = "Alpha"
instance (Elevator e, Typeable e) => ColorSpace YA e where
type Components YA e = (e, e)
broadcastC 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)
mapPx = fmap
zipWithPx = liftA2
foldlPx = foldl'
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 Num e => Num (Pixel YA e) where
(+) = liftA2 (+)
() = liftA2 ()
(*) = liftA2 (*)
abs = liftA abs
signum = liftA signum
fromInteger = pure . fromInteger
instance Fractional e => Fractional (Pixel YA e) where
(/) = liftA2 (/)
recip = liftA recip
fromRational = pure . fromRational
instance Floating e => Floating (Pixel YA e) where
pi = pure pi
exp = liftA exp
log = liftA log
sin = liftA sin
cos = liftA cos
asin = liftA asin
atan = liftA atan
acos = liftA acos
sinh = liftA sinh
cosh = liftA cosh
asinh = liftA asinh
atanh = liftA atanh
acosh = liftA acosh
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