module Graphics.FieldTrip.Color
(
Col, rgb, rgba, rgb255
, transparent, black, white, red, green, blue, yellow, purple
, HasColor(..)
, VC(..)
, overC, overPre, overNon
) where
import Graphics.Rendering.OpenGL
import Data.VectorSpace
import Graphics.FieldTrip.Misc
type Col = Color4 R
rgba :: s -> s -> s -> s -> Color4 s
rgba = Color4
rgb :: Num s => s -> s -> s -> Color4 s
rgb r g b = Color4 r g b 1
grey :: Num s => s -> Color4 s
grey x = rgb x x x
transparent, black, white,
red, green, blue,
yellow, purple :: Fractional s => Color4 s
transparent = rgba 0 0 0 0
white = grey 1
black = grey 0
red = rgb 1 0 0
green = rgb 0 1 0
blue = rgb 0 0 1
yellow = rgb 1 1 0
purple = rgb255 160 32 240
rgb255 :: Fractional s => s -> s -> s -> Color4 s
rgb255 r g b = rgb (byte r) (byte g) (byte b)
byte :: Fractional s => s -> s
byte = (/ 255)
class HasColor c where toColor :: c -> Col
instance HasColor Bool where
toColor True = white
toColor False = transparent
instance HasColor Float where toColor = grey
instance Color Bool where
color = color . toColor
colorv = error "colorv: not defined on Bool"
instance Color R where
color = color . toColor
colorv = error "colorv: not defined on R"
data VC v c = VC !v !c
instance (Vertex v, Color c) => Vertex (VC v c)
where
vertex (VC v c) = color c >> vertex v
vertexv = error "vertexv: undefined on VC"
instance AdditiveGroup u => AdditiveGroup (Color4 u) where
zeroV = Color4 zeroV zeroV zeroV zeroV
Color4 r g b a ^+^ Color4 r' g' b' a'
= Color4 (r^+^r') (g^+^g') (b^+^b') (a^+^a')
negateV (Color4 r g b a)
= Color4 (negateV r) (negateV g) (negateV b) (negateV a)
instance VectorSpace u => VectorSpace (Color4 u) where
type Scalar (Color4 u) = Scalar u
s *^ (Color4 r g b a)
= Color4 (s*^r) (s*^g) (s*^b) (s*^a)
instance (InnerSpace r, AdditiveGroup (Scalar r))
=> InnerSpace (Color4 r) where
Color4 r g b a <.> Color4 r' g' b' a' =
r<.>r' ^+^ g<.>g' ^+^ b<.>b' ^+^ a<.>a'
instance Functor Color4 where
fmap f (Color4 r g b a) = Color4 (f r) (f g) (f b) (f a)
overC :: Fractional s => Color4 s -> Color4 s -> Color4 s
overC = overPre
overPre, overNon :: Fractional s => Binop (Color4 s)
Color4 r g b a `overPre` Color4 r' g' b' a' =
Color4 (r // r') (g // g') (b // b') (a // a')
where
top // bot = top + (1a) * bot
Color4 r g b a `overNon` Color4 r' g' b' a' =
Color4 (r // r') (g // g') (b // b') ao
where
top // bot = ((top*a) `pre` (bot*a')) / ao
ao = a `pre` a'
top `pre` bot = top + (1a) * bot