Color.hs

{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -Wno-name-shadowing #-}

{-
  Copyright 2020 The CodeWorld Authors. All rights reserved.

  Licensed under the Apache License, Version 2.0 (the "License");
  you may not use this file except in compliance with the License.
  You may obtain a copy of the License at

      http://www.apache.org/licenses/LICENSE-2.0

  Unless required by applicable law or agreed to in writing, software
  distributed under the License is distributed on an "AS IS" BASIS,
  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
  See the License for the specific language governing permissions and
  limitations under the License.
-}
module CodeWorld.Color where

import Control.DeepSeq
import GHC.Generics (Generic)

data Color
  = RGBA
      !Double
      !Double
      !Double
      !Double
  deriving (Generic, Show, Eq)

instance NFData Color

type Colour = Color

pattern RGB :: Double -> Double -> Double -> Color
pattern RGB r g b = RGBA r g b 1

pattern HSL :: Double -> Double -> Double -> Color
pattern HSL h s l <-
  (toHSL -> Just (h, s, l))
  where
    HSL h s l = fromHSL h s l

-- Utility functions for pattern synonyms.
fence :: Double -> Double
fence = max 0 . min 1

wrapNum :: Double -> Double -> Double
wrapNum lim x = x - fromInteger (floor (x / lim)) * lim

fenceColor :: Color -> Color
fenceColor (RGBA r g b a) = RGBA (fence r) (fence g) (fence b) (fence a)

-- Based on the algorithm from the CSS3 specification.
fromHSL :: Double -> Double -> Double -> Color
fromHSL (wrapNum (2 * pi) -> h) (fence -> s) (fence -> l) = RGBA r g b 1
  where
    m1 = l * 2 - m2
    m2
      | l <= 0.5 = l * (s + 1)
      | otherwise = l + s - l * s
    r = convert m1 m2 (h / 2 / pi + 1 / 3)
    g = convert m1 m2 (h / 2 / pi)
    b = convert m1 m2 (h / 2 / pi - 1 / 3)
    convert m1 m2 h
      | h < 0 = convert m1 m2 (h + 1)
      | h > 1 = convert m1 m2 (h - 1)
      | h * 6 < 1 = m1 + (m2 - m1) * h * 6
      | h * 2 < 1 = m2
      | h * 3 < 2 = m1 + (m2 - m1) * (2 / 3 - h) * 6
      | otherwise = m1

toHSL :: Color -> Maybe (Double, Double, Double)
toHSL c@(RGBA _ _ _ 1) = Just (hue c, saturation c, luminosity c)
toHSL _ = Nothing

mixed :: [Color] -> Color
mixed colors = go 0 0 0 0 0 colors
  where
    go rr gg bb aa n ((fenceColor -> RGBA r g b a) : cs) =
      go (rr + r * r * a) (gg + g * g * a) (bb + b * b * a) (aa + a) (n + 1) cs
    go rr gg bb aa n []
      | aa == 0 = RGBA 0 0 0 0
      | otherwise = RGBA (sqrt (rr / aa)) (sqrt (gg / aa)) (sqrt (bb / aa)) (aa / n)

-- Helper function that sets the alpha of the second color to that
-- of the first
sameAlpha :: Color -> Color -> Color
sameAlpha (fenceColor -> RGBA _ _ _ a1) (fenceColor -> RGBA r2 g2 b2 _) =
  RGBA r2 g2 b2 a1

lighter :: Double -> Color -> Color
lighter d c =
  sameAlpha c $ HSL (hue c) (saturation c) (fence (luminosity c + d))

light :: Color -> Color
light = lighter 0.15

darker :: Double -> Color -> Color
darker d = lighter (- d)

dark :: Color -> Color
dark = darker 0.15

brighter :: Double -> Color -> Color
brighter d c =
  sameAlpha c $ HSL (hue c) (fence (saturation c + d)) (luminosity c)

bright :: Color -> Color
bright = brighter 0.25

duller :: Double -> Color -> Color
duller d = brighter (- d)

dull :: Color -> Color
dull = duller 0.25

translucent :: Color -> Color
translucent (fenceColor -> RGBA r g b a) = RGBA r g b (a / 2)

-- | An infinite list of colors.
assortedColors :: [Color]
assortedColors = [HSL (adjusted h) 0.75 0.5 | h <- [0, 2 * pi / phi ..]]
  where
    phi = (1 + sqrt 5) / 2
    adjusted x =
      x + a0
        + a1 * sin (1 * x)
        + b1 * cos (1 * x)
        + a2 * sin (2 * x)
        + b2 * cos (2 * x)
        + a3 * sin (3 * x)
        + b3 * cos (3 * x)
        + a4 * sin (4 * x)
        + b4 * cos (4 * x)
    a0 = -8.6870353473225553e-02
    a1 = 8.6485747604766350e-02
    b1 = -9.6564816819163041e-02
    a2 = -3.0072759267059756e-03
    b2 = 1.5048456422494966e-01
    a3 = 9.3179137558373148e-02
    b3 = 2.9002513227535595e-03
    a4 = -6.6275768228887290e-03
    b4 = -1.0451841243520298e-02

hue :: Color -> Double
hue (fenceColor -> RGBA r g b _)
  | hi - lo < epsilon = 0
  | r == hi && g >= b = (g - b) / (hi - lo) * pi / 3
  | r == hi = (g - b) / (hi - lo) * pi / 3 + 2 * pi
  | g == hi = (b - r) / (hi - lo) * pi / 3 + 2 / 3 * pi
  | otherwise = (r - g) / (hi - lo) * pi / 3 + 4 / 3 * pi
  where
    hi = max r (max g b)
    lo = min r (min g b)
    epsilon = 0.000001

saturation :: Color -> Double
saturation (fenceColor -> RGBA r g b _)
  | hi - lo < epsilon = 0
  | otherwise = (hi - lo) / (1 - abs (hi + lo - 1))
  where
    hi = max r (max g b)
    lo = min r (min g b)
    epsilon = 0.000001

luminosity :: Color -> Double
luminosity (fenceColor -> RGBA r g b _) = (lo + hi) / 2
  where
    hi = max r (max g b)
    lo = min r (min g b)

alpha :: Color -> Double
alpha (RGBA _ _ _ a) = fence a

-- Named colors

white :: Color
white = HSL 0.00 0.00 1.00

black :: Color
black = HSL 0.00 0.00 0.00

gray :: Color
gray = HSL 0.00 0.00 0.50

grey :: Color
grey = HSL 0.00 0.00 0.50

red :: Color
red = HSL 0.00 0.75 0.50

orange :: Color
orange = HSL 0.61 0.75 0.50

yellow :: Color
yellow = HSL 0.98 0.75 0.50

green :: Color
green = HSL 2.09 0.75 0.50

blue :: Color
blue = HSL 3.84 0.75 0.50

purple :: Color
purple = HSL 4.80 0.75 0.50

pink :: Color
pink = HSL 5.76 0.75 0.75

brown :: Color
brown = HSL 0.52 0.60 0.40