module Graphics.ColorSpace.RGB (
RGB(..), RGBA(..), Pixel(..)
) where
import Prelude hiding (map)
import Control.Applicative
import Foreign.Ptr
import Foreign.Storable
import Data.Foldable
import Data.Typeable (Typeable)
import Graphics.ColorSpace.Internal
data RGB = RedRGB
| GreenRGB
| BlueRGB deriving (Eq, Enum, Show, Bounded, Typeable)
data instance Pixel RGB e = PixelRGB !e !e !e deriving (Eq, Ord)
instance Show e => Show (Pixel RGB e) where
show (PixelRGB r g b) = "<RGB:("++show r++"|"++show g++"|"++show b++")>"
instance Elevator e => ColorSpace RGB e where
type Components RGB e = (e, e, e)
toComponents (PixelRGB r g b) = (r, g, b)
fromComponents !(r, g, b) = PixelRGB r g b
promote = pure
getPxC (PixelRGB r _ _) RedRGB = r
getPxC (PixelRGB _ g _) GreenRGB = g
getPxC (PixelRGB _ _ b) BlueRGB = b
setPxC (PixelRGB _ g b) RedRGB r = PixelRGB r g b
setPxC (PixelRGB r _ b) GreenRGB g = PixelRGB r g b
setPxC (PixelRGB r g _) BlueRGB b = PixelRGB r g b
mapPxC f (PixelRGB r g b) = PixelRGB (f RedRGB r) (f GreenRGB g) (f BlueRGB b)
liftPx = fmap
liftPx2 = liftA2
foldlPx = foldl'
foldlPx2 f !z (PixelRGB r1 g1 b1) (PixelRGB r2 g2 b2) =
f (f (f z r1 r2) g1 g2) b1 b2
instance Functor (Pixel RGB) where
fmap f (PixelRGB r g b) = PixelRGB (f r) (f g) (f b)
instance Applicative (Pixel RGB) where
pure !e = PixelRGB e e e
(PixelRGB fr fg fb) <*> (PixelRGB r g b) = PixelRGB (fr r) (fg g) (fb b)
instance Foldable (Pixel RGB) where
foldr f !z (PixelRGB r g b) = f r (f g (f b z))
instance Storable e => Storable (Pixel RGB e) where
sizeOf _ = 3 * sizeOf (undefined :: e)
alignment _ = alignment (undefined :: e)
peek !p = do
let !q = castPtr p
r <- peek q
g <- peekElemOff q 1
b <- peekElemOff q 2
return (PixelRGB r g b)
poke !p (PixelRGB r g b) = do
let !q = castPtr p
poke q r
pokeElemOff q 1 g
pokeElemOff q 2 b
data RGBA = RedRGBA
| GreenRGBA
| BlueRGBA
| AlphaRGBA deriving (Eq, Enum, Show, Bounded, Typeable)
data instance Pixel RGBA e = PixelRGBA !e !e !e !e deriving (Eq, Ord)
instance Show e => Show (Pixel RGBA e) where
show (PixelRGBA r g b a) = "<RGBA:("++show r++"|"++show g++"|"++show b++"|"++show a++")>"
instance Elevator e => ColorSpace RGBA e where
type Components RGBA e = (e, e, e, e)
toComponents (PixelRGBA r g b a) = (r, g, b, a)
fromComponents !(r, g, b, a) = PixelRGBA r g b a
promote = pure
getPxC (PixelRGBA r _ _ _) RedRGBA = r
getPxC (PixelRGBA _ g _ _) GreenRGBA = g
getPxC (PixelRGBA _ _ b _) BlueRGBA = b
getPxC (PixelRGBA _ _ _ a) AlphaRGBA = a
setPxC (PixelRGBA _ g b a) RedRGBA r = PixelRGBA r g b a
setPxC (PixelRGBA r _ b a) GreenRGBA g = PixelRGBA r g b a
setPxC (PixelRGBA r g _ a) BlueRGBA b = PixelRGBA r g b a
setPxC (PixelRGBA r g b _) AlphaRGBA a = PixelRGBA r g b a
mapPxC f (PixelRGBA r g b a) =
PixelRGBA (f RedRGBA r) (f GreenRGBA g) (f BlueRGBA b) (f AlphaRGBA a)
liftPx = fmap
liftPx2 = liftA2
foldlPx = foldl'
foldlPx2 f !z (PixelRGBA r1 g1 b1 a1) (PixelRGBA r2 g2 b2 a2) =
f (f (f (f z r1 r2) g1 g2) b1 b2) a1 a2
instance Elevator e => AlphaSpace RGBA e where
type Opaque RGBA = RGB
getAlpha (PixelRGBA _ _ _ a) = a
addAlpha !a (PixelRGB r g b) = PixelRGBA r g b a
dropAlpha (PixelRGBA r g b _) = PixelRGB r g b
instance Functor (Pixel RGBA) where
fmap f (PixelRGBA r g b a) = PixelRGBA (f r) (f g) (f b) (f a)
instance Applicative (Pixel RGBA) where
pure !e = PixelRGBA e e e e
(PixelRGBA fr fg fb fa) <*> (PixelRGBA r g b a) = PixelRGBA (fr r) (fg g) (fb b) (fa a)
instance Foldable (Pixel RGBA) where
foldr f !z (PixelRGBA r g b a) = f r (f g (f b (f a z)))
instance Storable e => Storable (Pixel RGBA e) where
sizeOf _ = 4 * sizeOf (undefined :: e)
alignment _ = alignment (undefined :: e)
peek p = do
q <- return $ castPtr p
r <- peek q
g <- peekElemOff q 1
b <- peekElemOff q 2
a <- peekElemOff q 3
return (PixelRGBA r g b a)
poke p (PixelRGBA r g b a) = do
q <- return $ castPtr p
poke q r
pokeElemOff q 1 g
pokeElemOff q 2 b
pokeElemOff q 3 a