{-# LANGUAGE OverloadedStrings #-}
module Clay.Color where
import Data.Char (isHexDigit)
import Data.Monoid
import Data.String
import Text.Printf
import Data.Text (Text)
import qualified Data.Text as Text
import Data.Text.Read as Text
import Clay.Property
import Clay.Common
data Color
= Rgba Integer Integer Integer Float
| Hsla Integer Float Float Float
| Other Value
deriving (Show, Eq)
rgba :: Integer -> Integer -> Integer -> Float -> Color
rgba = Rgba
rgb :: Integer -> Integer -> Integer -> Color
rgb r g b = rgba r g b 1
hsla :: Integer -> Float -> Float -> Float -> Color
hsla = Hsla
hsl :: Integer -> Float -> Float -> Color
hsl r g b = hsla r g b 1
grayish :: Integer -> Color
grayish g = rgb g g g
transparent :: Color
transparent = rgba 0 0 0 0
setR :: Integer -> Color -> Color
setR r (Rgba _ g b a) = Rgba r g b a
setR _ o = o
setG :: Integer -> Color -> Color
setG g (Rgba r _ b a) = Rgba r g b a
setG _ o = o
setB :: Integer -> Color -> Color
setB b (Rgba r g _ a) = Rgba r g b a
setB _ o = o
setA :: Float -> Color -> Color
setA a (Rgba r g b _) = Rgba r g b a
setA a (Hsla r g b _) = Hsla r g b a
setA _ o = o
toRgba :: Color -> Color
toRgba color =
case color of
Hsla h s l a -> toRgba' rgb' a
where sextant = fromIntegral h / 60.0
chroma = (s *) . (1.0 -) . abs $ (2.0 * l) - 1.0
x = (chroma *) . (1.0 -) . abs $ (sextant `fracMod` 2) - 1.0
lightnessAdjustment = l - (chroma / 2.0)
toRgbPart component = truncate . (* 255.0) $ component + lightnessAdjustment
toRgba' (r, g, b) = Rgba (toRgbPart r) (toRgbPart g) (toRgbPart b)
rgb' | h >= 0 && h < 60 = (chroma, x , 0)
| h >= 60 && h < 120 = (x , chroma, 0)
| h >= 120 && h < 180 = (0 , chroma, x)
| h >= 180 && h < 240 = (0 , x , chroma)
| h >= 240 && h < 300 = (x , 0 , chroma)
| otherwise = (chroma, 0 , x)
c@(Rgba _ _ _ _) -> c
Other _ -> error "Invalid to pass Other to toRgba."
toHsla :: Color -> Color
toHsla color =
case color of
Rgba redComponent greenComponent blueComponent alphaComponent -> Hsla h (decimalRound s 3) (decimalRound l 3) alphaComponent
where r = fromIntegral redComponent / 255.0
g = fromIntegral greenComponent / 255.0
b = fromIntegral blueComponent / 255.0
minColor = minimum [r, g, b]
maxColor = maximum [r, g, b]
delta = maxColor - minColor
l = (minColor + maxColor) / 2.0
s = if delta == 0.0 then 0.0
else (delta /) . (1.0 -) . abs $ (2.0 * l) - 1.0
h' | delta == 0.0 = 0.0
| r == maxColor = ((g - b) / delta) `fracMod` 6.0
| g == maxColor = ((b - r) / delta) + 2.0
| otherwise = ((r - g) / delta) + 4.0
h'' = truncate $ 60 * h'
h = if h'' < 0 then h''+ 360 else h''
c@(Hsla _ _ _ _) -> c
Other _ -> error "Invalid to pass Other to toHsla."
(*.) :: Color -> Integer -> Color
(*.) (Rgba r g b a) i = Rgba (clamp (r * i)) (clamp (g * i)) (clamp (b * i)) a
(*.) o _ = o
(+.) :: Color -> Integer -> Color
(+.) (Rgba r g b a) i = Rgba (clamp (r + i)) (clamp (g + i)) (clamp (b + i)) a
(+.) o _ = o
(-.) :: Color -> Integer -> Color
(-.) (Rgba r g b a) i = Rgba (clamp (r - i)) (clamp (g - i)) (clamp (b - i)) a
(-.) o _ = o
clamp :: Ord a => Num a => a -> a
clamp i = max (min i (fromIntegral (255 :: Integer))) (fromIntegral (0 :: Integer))
lighten :: Float -> Color -> Color
lighten factor color =
case color of
c@(Hsla {}) -> toHsla $ lighten factor (toRgba c)
c@(Rgba {}) -> lerp factor c (Rgba 255 255 255 255)
Other _ -> error "Other cannot be lightened."
darken :: Float -> Color -> Color
darken factor color =
case color of
c@(Hsla {}) -> toHsla $ darken factor (toRgba c)
c@(Rgba {}) -> lerp factor c (Rgba 0 0 0 255)
Other _ -> error "Other cannot be darkened."
lerp :: Float -> Color -> Color -> Color
lerp factor startColor boundColor =
case (startColor, boundColor) of
(Other _, _) -> error "Other cannot be lerped."
(_, Other _) -> error "Other cannot be lerped."
(color@(Hsla {}), bound) -> toHsla $ lerp factor (toRgba color) bound
(start, color@(Hsla {})) -> toHsla $ lerp factor start (toRgba color)
(Rgba r g b a, Rgba r' g' b' a') ->
Rgba
(lerpComponent factor r r')
(lerpComponent factor g g')
(lerpComponent factor b b')
(lerpAlpha factor a a')
where lerpComponent :: Float -> Integer -> Integer -> Integer
lerpComponent amount start bound =
let difference = bound - start
adjustment = truncate $ fromIntegral difference * amount
in clamp $ start + adjustment
lerpAlpha :: Float -> Float -> Float -> Float
lerpAlpha amount start bound =
let difference = bound - start
adjustment = fromIntegral $ (truncate $ difference * amount :: Integer)
in clamp $ start + adjustment
instance Val Color where
value clr =
case clr of
Rgba r g b 1.0 -> Value $mconcat ["#", p' r, p' g, p' b]
Rgba r g b a -> Value $mconcat ["rgba(", p r, ",", p g, ",", p b, ",", ah a, ")"]
Hsla h s l 1.0 -> Value $mconcat ["hsl(", p h, ",", f s, ",", f l, ")"]
Hsla h s l a -> Value $mconcat ["hsla(", p h, ",", f s, ",", f l, ",", ah a, ")"]
Other o -> o
where p = fromString . show
p' = fromString . printf "%02x"
f = fromString . printf "%.4f%%"
ah = fromString . take 6 . show
instance None Color where none = Other "none"
instance Auto Color where auto = Other "auto"
instance Inherit Color where inherit = Other "inherit"
instance Other Color where other = Other
instance IsString Color where
fromString = parse . fromString
parse :: Text -> Color
parse t =
case Text.uncons t of
Just ('#', cs) | Text.all isHexDigit cs ->
case Text.unpack cs of
[a, b, c, d, e, f, g, h] -> rgba (hex a b) (hex c d) (hex e f) (fromIntegral (hex g h :: Integer) / 255.0)
[a, b, c, d, e, f ] -> rgb (hex a b) (hex c d) (hex e f)
[a, b, c, d ] -> rgba (hex a a) (hex b b) (hex c c) (fromIntegral (hex d d :: Integer) / 255.0)
[a, b, c ] -> rgb (hex a a) (hex b b) (hex c c)
_ -> err
_ -> err
where
hex a b = either err fst (Text.hexadecimal (Text.singleton a <> Text.singleton b))
err = error "Invalid color string"
aliceblue, antiquewhite, aqua, aquamarine, azure, beige, bisque, black,
blanchedalmond, blue, blueviolet, brown, burlywood, cadetblue, chartreuse,
chocolate, coral, cornflowerblue, cornsilk, crimson, cyan, darkblue,
darkcyan, darkgoldenrod, darkgray, darkgreen, darkgrey, darkkhaki,
darkmagenta, darkolivegreen, darkorange, darkorchid, darkred, darksalmon,
darkseagreen, darkslateblue, darkslategray, darkslategrey, darkturquoise,
darkviolet, deeppink, deepskyblue, dimgray, dimgrey, dodgerblue, firebrick,
floralwhite, forestgreen, fuchsia, gainsboro, ghostwhite, gold, goldenrod,
gray, green, greenyellow, grey, honeydew, hotpink, indianred, indigo, ivory,
khaki, lavender, lavenderblush, lawngreen, lemonchiffon, lightblue,
lightcoral, lightcyan, lightgoldenrodyellow, lightgray, lightgreen,
lightgrey, lightpink, lightsalmon, lightseagreen, lightskyblue,
lightslategray, lightslategrey, lightsteelblue, lightyellow, lime, limegreen,
linen, magenta, maroon, mediumaquamarine, mediumblue, mediumorchid,
mediumpurple, mediumseagreen, mediumslateblue, mediumspringgreen,
mediumturquoise, mediumvioletred, midnightblue, mintcream, mistyrose,
moccasin, navajowhite, navy, oldlace, olive, olivedrab, orange, orangered,
orchid, palegoldenrod, palegreen, paleturquoise, palevioletred, papayawhip,
peachpuff, peru, pink, plum, powderblue, purple, red, rosybrown, royalblue,
saddlebrown, salmon, sandybrown, seagreen, seashell, sienna, silver, skyblue,
slateblue, slategray, slategrey, snow, springgreen, steelblue, tan, teal,
thistle, tomato, turquoise, violet, wheat, white, whitesmoke, yellow,
yellowgreen :: Color
aliceblue = rgb 240 248 255
antiquewhite = rgb 250 235 215
aqua = rgb 0 255 255
aquamarine = rgb 127 255 212
azure = rgb 240 255 255
beige = rgb 245 245 220
bisque = rgb 255 228 196
black = rgb 0 0 0
blanchedalmond = rgb 255 235 205
blue = rgb 0 0 255
blueviolet = rgb 138 43 226
brown = rgb 165 42 42
burlywood = rgb 222 184 135
cadetblue = rgb 95 158 160
chartreuse = rgb 127 255 0
chocolate = rgb 210 105 30
coral = rgb 255 127 80
cornflowerblue = rgb 100 149 237
cornsilk = rgb 255 248 220
crimson = rgb 220 20 60
cyan = rgb 0 255 255
darkblue = rgb 0 0 139
darkcyan = rgb 0 139 139
darkgoldenrod = rgb 184 134 11
darkgray = rgb 169 169 169
darkgreen = rgb 0 100 0
darkgrey = rgb 169 169 169
darkkhaki = rgb 189 183 107
darkmagenta = rgb 139 0 139
darkolivegreen = rgb 85 107 47
darkorange = rgb 255 140 0
darkorchid = rgb 153 50 204
darkred = rgb 139 0 0
darksalmon = rgb 233 150 122
darkseagreen = rgb 143 188 143
darkslateblue = rgb 72 61 139
darkslategray = rgb 47 79 79
darkslategrey = rgb 47 79 79
darkturquoise = rgb 0 206 209
darkviolet = rgb 148 0 211
deeppink = rgb 255 20 147
deepskyblue = rgb 0 191 255
dimgray = rgb 105 105 105
dimgrey = rgb 105 105 105
dodgerblue = rgb 30 144 255
firebrick = rgb 178 34 34
floralwhite = rgb 255 250 240
forestgreen = rgb 34 139 34
fuchsia = rgb 255 0 255
gainsboro = rgb 220 220 220
ghostwhite = rgb 248 248 255
gold = rgb 255 215 0
goldenrod = rgb 218 165 32
gray = rgb 128 128 128
green = rgb 0 128 0
greenyellow = rgb 173 255 47
grey = rgb 128 128 128
honeydew = rgb 240 255 240
hotpink = rgb 255 105 180
indianred = rgb 205 92 92
indigo = rgb 75 0 130
ivory = rgb 255 255 240
khaki = rgb 240 230 140
lavender = rgb 230 230 250
lavenderblush = rgb 255 240 245
lawngreen = rgb 124 252 0
lemonchiffon = rgb 255 250 205
lightblue = rgb 173 216 230
lightcoral = rgb 240 128 128
lightcyan = rgb 224 255 255
lightgoldenrodyellow = rgb 250 250 210
lightgray = rgb 211 211 211
lightgreen = rgb 144 238 144
lightgrey = rgb 211 211 211
lightpink = rgb 255 182 193
lightsalmon = rgb 255 160 122
lightseagreen = rgb 32 178 170
lightskyblue = rgb 135 206 250
lightslategray = rgb 119 136 153
lightslategrey = rgb 119 136 153
lightsteelblue = rgb 176 196 222
lightyellow = rgb 255 255 224
lime = rgb 0 255 0
limegreen = rgb 50 205 50
linen = rgb 250 240 230
magenta = rgb 255 0 255
maroon = rgb 128 0 0
mediumaquamarine = rgb 102 205 170
mediumblue = rgb 0 0 205
mediumorchid = rgb 186 85 211
mediumpurple = rgb 147 112 219
mediumseagreen = rgb 60 179 113
mediumslateblue = rgb 123 104 238
mediumspringgreen = rgb 0 250 154
mediumturquoise = rgb 72 209 204
mediumvioletred = rgb 199 21 133
midnightblue = rgb 25 25 112
mintcream = rgb 245 255 250
mistyrose = rgb 255 228 225
moccasin = rgb 255 228 181
navajowhite = rgb 255 222 173
navy = rgb 0 0 128
oldlace = rgb 253 245 230
olive = rgb 128 128 0
olivedrab = rgb 107 142 35
orange = rgb 255 165 0
orangered = rgb 255 69 0
orchid = rgb 218 112 214
palegoldenrod = rgb 238 232 170
palegreen = rgb 152 251 152
paleturquoise = rgb 175 238 238
palevioletred = rgb 219 112 147
papayawhip = rgb 255 239 213
peachpuff = rgb 255 218 185
peru = rgb 205 133 63
pink = rgb 255 192 203
plum = rgb 221 160 221
powderblue = rgb 176 224 230
purple = rgb 128 0 128
red = rgb 255 0 0
rosybrown = rgb 188 143 143
royalblue = rgb 65 105 225
saddlebrown = rgb 139 69 19
salmon = rgb 250 128 114
sandybrown = rgb 244 164 96
seagreen = rgb 46 139 87
seashell = rgb 255 245 238
sienna = rgb 160 82 45
silver = rgb 192 192 192
skyblue = rgb 135 206 235
slateblue = rgb 106 90 205
slategray = rgb 112 128 144
slategrey = rgb 112 128 144
snow = rgb 255 250 250
springgreen = rgb 0 255 127
steelblue = rgb 70 130 180
tan = rgb 210 180 140
teal = rgb 0 128 128
thistle = rgb 216 191 216
tomato = rgb 255 99 71
turquoise = rgb 64 224 208
violet = rgb 238 130 238
wheat = rgb 245 222 179
white = rgb 255 255 255
whitesmoke = rgb 245 245 245
yellow = rgb 255 255 0
yellowgreen = rgb 154 205 50