module Data.Color (
RGB(..)
, HSV(..)
, rgbToHex
, hsvToHex
, red
, green
, blue
, rgbToGray
, hsvToGray
, rgbToHSV
, hsvToRGB
, colorGroups
, lightColorGroups
) where
import Numeric (showHex)
data RGB a = RGB {
rgbR :: !a
, rgbG :: !a
, rgbB :: !a
}
deriving( Eq, Ord )
instance Show a => Show (RGB a) where
show (RGB r g b) = "RGB("++show r++", "++show g++", "++show b++")"
instance Functor RGB where
fmap f (RGB r g b) = RGB (f r) (f g) (f b)
red, green, blue :: Fractional t => RGB t
red = RGB 1.0 0.0 0.0
green = RGB 0.0 1.0 0.0
blue = RGB 0.0 0.0 1.0
data HSV a = HSV {
hsvH :: !a
, hsvS :: !a
, hsvV :: !a
}
deriving( Eq, Ord )
instance Show a => Show (HSV a) where
show (HSV h s v) = "HSV("++show h++", "++show s++", "++show v++")"
instance Functor HSV where
fmap f (HSV h s v) = HSV (f h) (f s) (f v)
rgbToHSV :: (Fractional t, Ord t) => RGB t -> HSV t
rgbToHSV (RGB r g b) = HSV h' s v
where
ub = max r (max g b)
lb = min r (min g b)
h | ub == lb = 0
| ub == r = 60 * ( (gb)/(ublb))
| ub == g = 60 * (2 + (br)/(ublb))
| otherwise = 60 * (4 + (rg)/(ublb))
h' | h < 0 = h + 360
| otherwise = h
s | ub == 0 = 0
| otherwise = (ublb)/ub
v = ub
hsvToRGB :: RealFrac t => HSV t -> RGB t
hsvToRGB (HSV h s v) = case hIdx of
0 -> RGB v t p
1 -> RGB q v p
2 -> RGB p v t
3 -> RGB p q v
4 -> RGB t p v
5 -> RGB v p q
_ -> error "hsvToRGB: hue outside of range [0..360]"
where
hIdx = floor (h / 60)
f = h/60 fromIntegral (hIdx::Int)
p = v*(1s)
q = v*(1s*f)
t = v*(1s*(1f))
hsvToGray :: Num t => HSV t -> HSV t
hsvToGray (HSV h _ v) = HSV h 0 v
rgbToGray :: Ord t => RGB t -> t
rgbToGray (RGB r g b) = max r (max g b)
rgbToHex :: RealFrac t => RGB t -> String
rgbToHex (RGB r g b) = ('#':) . showHex' r . showHex' g . showHex' b $ ""
where showHex' f
| i <= 15 = ('0':) . showHex i
| otherwise = showHex i
where
i :: Int
i = max 0 (min 255 (floor (256 * f)))
hsvToHex :: RealFrac t => HSV t -> [Char]
hsvToHex = rgbToHex . hsvToRGB
data ColorParams t = ColorParams {
cpScale :: !t
, cpZeroHue :: !t
, cpVBottom :: !t
, cpVRange :: !t
, cpSBottom :: !t
, cpSRange :: !t
}
deriving( Eq, Ord, Show )
genColorGroups :: RealFrac t =>
ColorParams t
-> [Int]
-> [((Int,Int),(HSV t))]
genColorGroups (ColorParams {
cpScale = scale
, cpZeroHue = zeroHue
, cpVBottom = vBot, cpVRange = vRan
, cpSBottom = sBot, cpSRange = sRan
}) groups =
do
(groupIdx, groupSize) <- zip [0.. ] groups
elemIdx <- [0..groupSize 1]
let h = toShiftedGroupHue groupIdx (fromIntegral elemIdx / fromIntegral groupSize)
v = vBot + vRan * toGroupHue groupIdx (fromIntegral elemIdx / fromIntegral groupSize)
s = sBot + sRan * toGroupHue groupIdx (fromIntegral elemIdx / fromIntegral groupSize)
color = HSV (360*h) s v
return ((groupIdx, elemIdx), color)
where
nGroups :: Int
nGroups = length groups
toGroupHue g h = (
fromIntegral g +
0.5 * (1 scale) +
(h * scale)
) / (fromIntegral nGroups)
toShiftedGroupHue g h =
snd . properFraction $ toGroupHue g h + 1 +
(zeroHue/360) toGroupHue 0 0.5
colorGroupStyle :: Double -> ColorParams Double
colorGroupStyle zeroHue = ColorParams {
cpScale = 0.6
, cpZeroHue = zeroHue
, cpVBottom = 0.75, cpVRange = 0.2
, cpSBottom = 0.4, cpSRange = 0.00
}
colorGroups :: Double -> [Int] -> [((Int, Int), HSV Double)]
colorGroups zeroHue = genColorGroups (colorGroupStyle zeroHue)
lightColorGroupStyle :: Double -> ColorParams Double
lightColorGroupStyle zeroHue = ColorParams {
cpScale = 0.6
, cpZeroHue = zeroHue
, cpVBottom = 0.8, cpVRange = 0.15
, cpSBottom = 0.3, cpSRange = 0.00
}
lightColorGroups :: Double -> [Int] -> [((Int, Int), HSV Double)]
lightColorGroups zeroHue = genColorGroups (lightColorGroupStyle zeroHue)