module FRP.Helm.Color (
Color(..),
Gradient(..),
rgba,
rgb,
hsva,
hsv,
blend,
complement,
linear,
radial,
red,
lime,
blue,
yellow,
cyan,
magenta,
black,
white,
gray,
grey,
maroon,
navy,
green,
teal,
purple,
violet,
forestGreen
) where
import GHC.Generics
data Color = Color Double Double Double Double deriving (Show, Eq, Ord, Read, Generic)
rgb :: Double -> Double -> Double -> Color
rgb r g b = rgba r g b 1
rgba :: Double -> Double -> Double -> Double -> Color
rgba r g b a
| r < 0 || r > 1 ||
g < 0 || g > 1 ||
b < 0 || b > 1 ||
a < 0 || a > 1 = error "FRP.Helm.Color.rgba: color components must be between 0 and 1"
| otherwise = Color r g b a
red :: Color
red = rgb 1 0 0
lime :: Color
lime = rgb 0 1 0
blue :: Color
blue = rgb 0 0 1
yellow :: Color
yellow = rgb 1 1 0
cyan :: Color
cyan = rgb 0 1 1
magenta :: Color
magenta = rgb 1 0 1
black :: Color
black = rgb 0 0 0
white :: Color
white = rgb 1 1 1
gray :: Color
gray = rgb 0.5 0.5 0.5
grey :: Color
grey = gray
maroon :: Color
maroon = rgb 0.5 0 0
navy :: Color
navy = rgb 0 0 0.5
green :: Color
green = rgb 0 0.5 0
teal :: Color
teal = rgb 0 0.5 0.5
purple :: Color
purple = rgb 0.5 0 0.5
violet :: Color
violet = rgb 0.923 0.508 0.923
forestGreen :: Color
forestGreen = rgb 0.133 0.543 0.133
blend :: [Color] -> Color
blend colors = (\(Color r g b a) -> Color (r / denom) (g / denom) (b / denom) (a / denom)) $ foldl blend' black colors
where
denom = fromIntegral $ length colors
blend' :: Color -> Color -> Color
blend' (Color r1 g1 b1 a1) (Color r2 g2 b2 a2) = Color (r1 + r2) (g1 + g2) (b1 + b2) (a1 + a2)
complement :: Color -> Color
complement (Color r g b a) = hsva (fromIntegral ((round (h + 180) :: Int) `mod` 360)) (s / mx) mx a
where
mx = r `max` g `max` b
mn = r `min` g `min` b
s = mx mn
h | mx == r = (g b) / s * 60
| mx == g = (b r) / s * 60 + 120
| mx == b = (r g) / s * 60 + 240
| otherwise = undefined
hsva :: Double -> Double -> Double -> Double -> Color
hsva h s v a
| h'' == 0 = rgba v t p a
| h'' == 1 = rgba q v p a
| h'' == 2 = rgba p v t a
| h'' == 3 = rgba p q v a
| h'' == 4 = rgba t p v a
| h'' == 5 = rgba v p q a
| otherwise = undefined
where
h' = h / 60
h'' = floor h' `mod` 6 :: Int
f = h' fromIntegral h''
p = v * (1 s)
q = v * (1 f * s)
t = v * (1 (1 f) * s)
hsv :: Double -> Double -> Double -> Color
hsv h s v = hsva h s v 1
data Gradient = Linear (Double, Double) (Double, Double) [(Double, Color)] |
Radial (Double, Double) Double (Double, Double) Double [(Double, Color)] deriving (Show, Eq, Ord, Read)
linear :: (Double, Double) -> (Double, Double) -> [(Double, Color)] -> Gradient
linear = Linear
radial :: (Double, Double) -> Double -> (Double, Double) -> Double -> [(Double, Color)] -> Gradient
radial = Radial