{-# 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 (forall x. Rep Color x -> Color
forall x. Color -> Rep Color x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Color x -> Color
$cfrom :: forall x. Color -> Rep Color x
Generic, Int -> Color -> ShowS
[Color] -> ShowS
Color -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Color] -> ShowS
$cshowList :: [Color] -> ShowS
show :: Color -> String
$cshow :: Color -> String
showsPrec :: Int -> Color -> ShowS
$cshowsPrec :: Int -> Color -> ShowS
Show, Color -> Color -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Color -> Color -> Bool
$c/= :: Color -> Color -> Bool
== :: Color -> Color -> Bool
$c== :: Color -> Color -> Bool
Eq)

instance NFData Color

type Colour = Color

pattern RGB :: Double -> Double -> Double -> Color
pattern $bRGB :: Double -> Double -> Double -> Color
$mRGB :: forall {r}.
Color -> (Double -> Double -> Double -> r) -> ((# #) -> r) -> r
RGB r g b = RGBA r g b 1

pattern HSL :: Double -> Double -> Double -> Color
pattern $bHSL :: Double -> Double -> Double -> Color
$mHSL :: forall {r}.
Color -> (Double -> Double -> Double -> r) -> ((# #) -> r) -> r
HSL h s l <-
  (toHSL -> Just (h, s, l))
  where
    HSL Double
h Double
s Double
l = Double -> Double -> Double -> Color
fromHSL Double
h Double
s Double
l

-- Utility functions for pattern synonyms.
fence :: Double -> Double
fence :: Double -> Double
fence = forall a. Ord a => a -> a -> a
max Double
0 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => a -> a -> a
min Double
1

wrapNum :: Double -> Double -> Double
wrapNum :: Double -> Double -> Double
wrapNum Double
lim Double
x = Double
x forall a. Num a => a -> a -> a
- forall a. Num a => Integer -> a
fromInteger (forall a b. (RealFrac a, Integral b) => a -> b
floor (Double
x forall a. Fractional a => a -> a -> a
/ Double
lim)) forall a. Num a => a -> a -> a
* Double
lim

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

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

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

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

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

lighter :: Double -> Color -> Color
lighter :: Double -> Color -> Color
lighter Double
d Color
c =
  Color -> Color -> Color
sameAlpha Color
c forall a b. (a -> b) -> a -> b
$ Double -> Double -> Double -> Color
HSL (Color -> Double
hue Color
c) (Color -> Double
saturation Color
c) (Double -> Double
fence (Color -> Double
luminosity Color
c forall a. Num a => a -> a -> a
+ Double
d))

light :: Color -> Color
light :: Color -> Color
light = Double -> Color -> Color
lighter Double
0.15

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

dark :: Color -> Color
dark :: Color -> Color
dark = Double -> Color -> Color
darker Double
0.15

brighter :: Double -> Color -> Color
brighter :: Double -> Color -> Color
brighter Double
d Color
c =
  Color -> Color -> Color
sameAlpha Color
c forall a b. (a -> b) -> a -> b
$ Double -> Double -> Double -> Color
HSL (Color -> Double
hue Color
c) (Double -> Double
fence (Color -> Double
saturation Color
c forall a. Num a => a -> a -> a
+ Double
d)) (Color -> Double
luminosity Color
c)

bright :: Color -> Color
bright :: Color -> Color
bright = Double -> Color -> Color
brighter Double
0.25

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

dull :: Color -> Color
dull :: Color -> Color
dull = Double -> Color -> Color
duller Double
0.25

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

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

hue :: Color -> Double
hue :: Color -> Double
hue (Color -> Color
fenceColor -> RGBA Double
r Double
g Double
b Double
_)
  | Double
hi forall a. Num a => a -> a -> a
- Double
lo forall a. Ord a => a -> a -> Bool
< Double
epsilon = Double
0
  | Double
r forall a. Eq a => a -> a -> Bool
== Double
hi Bool -> Bool -> Bool
&& Double
g forall a. Ord a => a -> a -> Bool
>= Double
b = (Double
g forall a. Num a => a -> a -> a
- Double
b) forall a. Fractional a => a -> a -> a
/ (Double
hi forall a. Num a => a -> a -> a
- Double
lo) forall a. Num a => a -> a -> a
* forall a. Floating a => a
pi forall a. Fractional a => a -> a -> a
/ Double
3
  | Double
r forall a. Eq a => a -> a -> Bool
== Double
hi = (Double
g forall a. Num a => a -> a -> a
- Double
b) forall a. Fractional a => a -> a -> a
/ (Double
hi forall a. Num a => a -> a -> a
- Double
lo) forall a. Num a => a -> a -> a
* forall a. Floating a => a
pi forall a. Fractional a => a -> a -> a
/ Double
3 forall a. Num a => a -> a -> a
+ Double
2 forall a. Num a => a -> a -> a
* forall a. Floating a => a
pi
  | Double
g forall a. Eq a => a -> a -> Bool
== Double
hi = (Double
b forall a. Num a => a -> a -> a
- Double
r) forall a. Fractional a => a -> a -> a
/ (Double
hi forall a. Num a => a -> a -> a
- Double
lo) forall a. Num a => a -> a -> a
* forall a. Floating a => a
pi forall a. Fractional a => a -> a -> a
/ Double
3 forall a. Num a => a -> a -> a
+ Double
2 forall a. Fractional a => a -> a -> a
/ Double
3 forall a. Num a => a -> a -> a
* forall a. Floating a => a
pi
  | Bool
otherwise = (Double
r forall a. Num a => a -> a -> a
- Double
g) forall a. Fractional a => a -> a -> a
/ (Double
hi forall a. Num a => a -> a -> a
- Double
lo) forall a. Num a => a -> a -> a
* forall a. Floating a => a
pi forall a. Fractional a => a -> a -> a
/ Double
3 forall a. Num a => a -> a -> a
+ Double
4 forall a. Fractional a => a -> a -> a
/ Double
3 forall a. Num a => a -> a -> a
* forall a. Floating a => a
pi
  where
    hi :: Double
hi = forall a. Ord a => a -> a -> a
max Double
r (forall a. Ord a => a -> a -> a
max Double
g Double
b)
    lo :: Double
lo = forall a. Ord a => a -> a -> a
min Double
r (forall a. Ord a => a -> a -> a
min Double
g Double
b)
    epsilon :: Double
epsilon = Double
0.000001

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

luminosity :: Color -> Double
luminosity :: Color -> Double
luminosity (Color -> Color
fenceColor -> RGBA Double
r Double
g Double
b Double
_) = (Double
lo forall a. Num a => a -> a -> a
+ Double
hi) forall a. Fractional a => a -> a -> a
/ Double
2
  where
    hi :: Double
hi = forall a. Ord a => a -> a -> a
max Double
r (forall a. Ord a => a -> a -> a
max Double
g Double
b)
    lo :: Double
lo = forall a. Ord a => a -> a -> a
min Double
r (forall a. Ord a => a -> a -> a
min Double
g Double
b)

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

-- Named colors

white :: Color
white :: Color
white = Double -> Double -> Double -> Color
HSL Double
0.00 Double
0.00 Double
1.00

black :: Color
black :: Color
black = Double -> Double -> Double -> Color
HSL Double
0.00 Double
0.00 Double
0.00

gray :: Color
gray :: Color
gray = Double -> Double -> Double -> Color
HSL Double
0.00 Double
0.00 Double
0.50

grey :: Color
grey :: Color
grey = Double -> Double -> Double -> Color
HSL Double
0.00 Double
0.00 Double
0.50

red :: Color
red :: Color
red = Double -> Double -> Double -> Color
HSL Double
0.00 Double
0.75 Double
0.50

orange :: Color
orange :: Color
orange = Double -> Double -> Double -> Color
HSL Double
0.61 Double
0.75 Double
0.50

yellow :: Color
yellow :: Color
yellow = Double -> Double -> Double -> Color
HSL Double
0.98 Double
0.75 Double
0.50

green :: Color
green :: Color
green = Double -> Double -> Double -> Color
HSL Double
2.09 Double
0.75 Double
0.50

blue :: Color
blue :: Color
blue = Double -> Double -> Double -> Color
HSL Double
3.84 Double
0.75 Double
0.50

purple :: Color
purple :: Color
purple = Double -> Double -> Double -> Color
HSL Double
4.80 Double
0.75 Double
0.50

pink :: Color
pink :: Color
pink = Double -> Double -> Double -> Color
HSL Double
5.76 Double
0.75 Double
0.75

brown :: Color
brown :: Color
brown = Double -> Double -> Double -> Color
HSL Double
0.52 Double
0.60 Double
0.40