module FMP.Color ( Color(..), HasColor(..), HasBGColor(..), white, black, red, green, blue, yellow, cyan, magenta, grey, color, hsv2rgb, graduateLow, graduateMed, graduateHigh, graduate ) where data Color = DefaultColor | Color Double Double Double | Graduate Color Color Double Int deriving (Eq, Show, Read) class HasColor a where setColor :: Color -> a -> a setDefaultColor :: a -> a getColor :: a -> Color class HasBGColor a where setBGColor :: Color -> a -> a setDefaultBGColor :: a -> a getBGColor :: a -> Color white, black, red, green, blue , yellow, cyan, magenta :: Color white = Color 1 1 1 black = Color 0 0 0 red = Color 1 0 0 green = Color 0 1 0 blue = Color 0 0 1 yellow = Color 1 1 0 cyan = Color 0 1 1 magenta = Color 1 0 1 grey :: Double -> Color grey n = Color n n n color :: Double -> Double -> Double -> Color color r g b = Color r g b graduateLow :: Color -> Color -> Double -> Color graduateLow c1 c2 a = graduate c1 c2 a 16 graduateMed :: Color -> Color -> Double -> Color graduateMed c1 c2 a = graduate c1 c2 a 64 graduateHigh :: Color -> Color -> Double -> Color graduateHigh c1 c2 a = graduate c1 c2 a 256 graduate :: Color -> Color -> Double -> Int -> Color graduate c1 c2 a n = Graduate c1 c2 a n instance Num Color where Color r1 g1 b1 + Color r2 g2 b2 = Color (r1+r2) (g1+g2) (b1+b2) Graduate c1 c2 a n + c3@(Color _ _ _) = Graduate (c1+c3) (c2+c3) a n c3@(Color _ _ _) + Graduate c1 c2 a n = Graduate (c1+c3) (c2+c3) a n Graduate c1 c2 a n + Graduate c3 c4 a' n' = Graduate (c1+c3) (c2+c4) ((a+a')/2) (maximum [n,n']) a + DefaultColor = a DefaultColor + a = a Color r1 g1 b1 - Color r2 g2 b2 = Color (r1-r2) (g1-g2) (b1-b2) Graduate c1 c2 a n - c3@(Color _ _ _) = Graduate (c1-c3) (c2-c3) a n c3@(Color _ _ _) - Graduate c1 c2 a n = Graduate (c3-c1) (c3-c2) a n Graduate c1 c2 a n - Graduate c3 c4 a' n' = Graduate (c1-c3) (c2-c4) ((a+a')/2) (maximum [n,n']) a - DefaultColor = a DefaultColor - a = a Color r1 g1 b1 * Color r2 g2 b2 = Color (r1*r2) (g1*g2) (b1*b2) Graduate c1 c2 a n * c3@(Color _ _ _) = Graduate (c1*c3) (c2*c3) a n c3@(Color _ _ _) * Graduate c1 c2 a n = Graduate (c3*c1) (c3*c2) a n Graduate c1 c2 a n * Graduate c3 c4 a' n' = Graduate (c1*c3) (c2*c4) ((a+a')/2) (maximum [n,n']) a * DefaultColor = a DefaultColor * a = a negate (Color r g b) = Color (1-r) (1-g) (1-b) negate (Graduate c1 c2 a n) = Graduate (-c1) (-c2) a n negate DefaultColor = DefaultColor abs a = a signum a = a fromInteger i = Color f f f where f = fromInteger i instance Fractional Color where Color r1 g1 b1 / Color r2 g2 b2 = Color (r1/r2) (g1/g2) (b1/b2) Graduate c1 c2 a n / c3@(Color _ _ _) = Graduate (c1/c3) (c2/c3) a n c3@(Color _ _ _) / Graduate c1 c2 a n = Graduate (c3/c1) (c3/c2) a n Graduate c1 c2 a n / Graduate c3 c4 a' n' = Graduate (c1/c3) (c2/c4) ((a+a')/2) (maximum [n,n']) a / _ = a recip (Color r g b) = Color (recip r) (recip g) (recip b) recip a = a fromRational i = Color f f f where f = fromRational i hsv2rgb :: (Double,Double,Double) -> Color hsv2rgb (_, 0, v) = Color v v v hsv2rgb (h, s, v) = case i' of 0 -> Color v t3 t1 1 -> Color t2 v t1 2 -> Color t1 v t3 3 -> Color t1 t2 v 4 -> Color t3 t1 v _ -> Color v t1 t2 where h' = h / 60.0 i' = mod (floor h') 6 i = floor h' fract = h' - fromIntegral i t1 = v * (1 - s) t2 = v * (1 - s * fract) t3 = v * (1 - s * (1 - fract))