module Data.Glome.Clr where
import Data.List(foldl')
type CFlt = Double
data Color = Color !CFlt !CFlt !CFlt deriving Show
data ColorA = ColorA !CFlt !CFlt !CFlt !CFlt
c_black = Color 0 0 0
c_white = Color 1 1 1
c_red = Color 1 0 0
c_green = Color 0 1 0
c_blue = Color 0 0 1
ca_black = ColorA 0 0 0 1
ca_white = ColorA 1 1 1 1
ca_red = ColorA 1 0 0 1
ca_green = ColorA 0 1 0 1
ca_blue = ColorA 0 0 1 1
ca_transparent = ColorA 0 0 0 0
cadd :: Color -> Color -> Color
cadd (Color r1 g1 b1) (Color r2 g2 b2) =
Color (r1+r2) (g1+g2) (b1+b2)
caadd :: ColorA -> ColorA -> ColorA
caadd (ColorA r1 g1 b1 a1) (ColorA r2 g2 b2 a2) =
ColorA (r1*a1 + r2*a2) (g1*a1 + g2*a2) (b1*a1 + b2*a2) (a1+a2)
canorm :: ColorA -> ColorA
canorm c@(ColorA r g b a)
| a <= 1 = c
| otherwise = ColorA (r/a) (g/a) (b/a) 1
cdiv :: Color -> CFlt -> Color
cdiv c1 div =
cscale c1 (1/div)
cadiv :: ColorA -> CFlt -> ColorA
cadiv (ColorA r g b a) d =
ColorA (r/d) (g/d) (b/d) (a/d)
cscale :: Color -> CFlt -> Color
cscale (Color r g b) mul =
Color (r * mul) (g * mul) (b * mul)
cascale :: ColorA -> CFlt -> ColorA
cascale (ColorA r g b a) mul =
ColorA (r * mul) (g * mul) (b*mul) a
cmul :: Color -> Color -> Color
cmul (Color r1 g1 b1) (Color r2 g2 b2) =
Color (r1*r2) (g1*g2) (b1*b2)
cavg :: Color -> Color -> Color
cavg c1 c2 = cscale (cadd c1 c2) 0.5
cscaleadd :: Color -> Color -> CFlt -> Color
cscaleadd (Color r1 g1 b1) (Color r2 g2 b2) mul =
Color (r1+(r2*mul)) (g1+(g2*mul)) (b1+(b2*mul))
cclamp :: Color -> Color
cclamp (Color r g b) =
Color (if r > 0.0 then r else 0.0)
(if g > 0.0 then g else 0.0)
(if b > 0.0 then b else 0.0)
color r g b = Color r g b
colora r g b a = ColorA r g b a
liftcolor :: Color -> ColorA
liftcolor (Color r g b) = ColorA r g b 1
aclamp :: CFlt -> CFlt
aclamp x
| x > 1 = 1
| x < 0 = 0
| otherwise = x
alphas :: [ColorA] -> CFlt
alphas cs =
let as = map (\(ColorA _ _ _ a) -> 1 (aclamp a)) cs
in 1 (product as)
caweight :: ColorA -> ColorA -> CFlt -> ColorA
caweight (ColorA r1 g1 b1 a1) (ColorA r2 g2 b2 a2) weight =
ColorA (w r1 r2) (w g1 g2) (w b1 b2) (w a1 a2)
where
w a b = (a * weight) + (b * (1weight))
casum :: [ColorA] -> ColorA
casum cs =
let Color r g b = foldl'
(\(Color r1 g1 b1) (ColorA r2 g2 b2 a2) ->
Color (r1 + r2*a2) (g1 + g2*a2) (b1 + b2*a2)
)
c_black
cs
a = alphas cs
in
ColorA r g b a
cafold :: ColorA -> ColorA -> ColorA
cafold (ColorA r1 g1 b1 a1) (ColorA r2 g2 b2 a2) =
ColorA (r1 + (r2 * trans * a2))
(g1 + (g2 * trans * a2))
(b1 + (b2 * trans * a2))
(a1 + (a2 * trans))
where
trans = 1a1