content: {-# LANGUAGE OverloadedStrings #-}
  module Clay.Color where
  
  import Data.Char (isHexDigit)
  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
  
  -- * Color datatype.
  
  data Color
    = Rgba Integer Integer Integer Float
    | Hsla Integer Float   Float   Float
    | Other Value
    deriving (Show, Eq)
  
  -- * Color constructors.
  
  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
  
  -- * Setting individual color components.
  
  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
  
  -- * Color conversions.
  
  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."
  
  -- * Computing with colors.
  
  (*.) :: Color -> Integer -> Color
  (*.) (Rgba r g b a) i = Rgba (clamp (r * i)) (clamp (g * i)) (clamp (b * i)) a
  (*.) o              _ = o
  infixl 7 *.
  
  (+.) :: Color -> Integer -> Color
  (+.) (Rgba r g b a) i = Rgba (clamp (r + i)) (clamp (g + i)) (clamp (b + i)) a
  (+.) o              _ = o
  infixl 6 +.
  
  (-.) :: Color -> Integer -> Color
  (-.) (Rgba r g b a) i = Rgba (clamp (r - i)) (clamp (g - i)) (clamp (b - i)) a
  (-.) o              _ = o
  infixl 6 -.
  
  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"
  
  -------------------------------------------------------------------------------
  
  -- * List of color values by name.
  
  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
  
  