{-# LANGUAGE LambdaCase #-}

{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Palette.RandomColor
-- Copyright   :  (c) 2018 Jeffrey Rosenbluth
-- License     :  BSD-style (see LICENSE)
-- Maintainer  :  jeffrey.rosenbluth@gmail.com
--
-- Functions to create random colors.
-- Includes a port of [David Merfield's](https://github.com/davidmerfield/randomColor)
-- randomColor.
-----------------------------------------------------------------------------

module Data.Colour.Palette.RandomColor
  ( -- * A Library for generating random colors.

    -- ** Choose a random color from CIELAB colorspace.
    randomCIELab
  , randomCIELabPalette

    -- ** Choose a random color using David Merfield's algorithm
  , randomColor
  , randomPalette
  , randomHarmony

  -- ** Choose a random HSV component

  , randomHue
  , randomSaturation
  , randomBrightness

  ) where

import           Control.Monad.Random
import           Data.Colour.CIE            (cieLAB)
import           Data.Colour.CIE.Illuminant (d65)
import           Data.Colour.Palette.Harmony
import           Data.Colour.Palette.Types
import           Data.Colour.RGBSpace.HSV
import           Data.Colour.SRGB            (RGB (..), sRGB)
import           Data.List                   (find)
import           Data.Maybe                  (fromMaybe)

getColorDefinition :: Hue -> ColorDefinition
getColorDefinition :: Hue -> ColorDefinition
getColorDefinition = \case
  Hue
HueMonochrome -> Maybe (Int, Int) -> [(Int, Int)] -> ColorDefinition
ColorDefinition forall a. Maybe a
Nothing [(Int
0,Int
0),(Int
100, Int
0)]
  Hue
HueRed        -> Maybe (Int, Int) -> [(Int, Int)] -> ColorDefinition
ColorDefinition (forall a. a -> Maybe a
Just (-Int
26,Int
18))
                     [ (Int
20,Int
100), (Int
30,Int
92), (Int
40,Int
89), (Int
50,Int
85), (Int
60,Int
78), (Int
70,Int
70)
                     , (Int
80,Int
60), (Int
90,Int
55), (Int
100,Int
50)
                     ]
  Hue
HueOrange     -> Maybe (Int, Int) -> [(Int, Int)] -> ColorDefinition
ColorDefinition (forall a. a -> Maybe a
Just (Int
19,Int
46))
                     [ (Int
20,Int
100), (Int
30,Int
93), (Int
40,Int
88), (Int
50,Int
86), (Int
60,Int
85), (Int
70,Int
70)
                     , (Int
100,Int
70)
                     ]
  Hue
HueYellow     -> Maybe (Int, Int) -> [(Int, Int)] -> ColorDefinition
ColorDefinition (forall a. a -> Maybe a
Just (Int
47,Int
62))
                     [ (Int
25,Int
100), (Int
40,Int
94), (Int
50,Int
89), (Int
60,Int
86), (Int
70,Int
84), (Int
80,Int
82)
                     , (Int
90,Int
80), (Int
100,Int
75)
                     ]
  Hue
HueGreen      -> Maybe (Int, Int) -> [(Int, Int)] -> ColorDefinition
ColorDefinition (forall a. a -> Maybe a
Just (Int
63,Int
178))
                     [ (Int
30,Int
100), (Int
40,Int
90), (Int
50,Int
85), (Int
60,Int
81), (Int
70,Int
74), (Int
80,Int
64)
                     , (Int
90,Int
50), (Int
100,Int
40)
                     ]
  Hue
HueBlue       -> Maybe (Int, Int) -> [(Int, Int)] -> ColorDefinition
ColorDefinition (forall a. a -> Maybe a
Just (Int
179,Int
257))
                     [ (Int
20,Int
100), (Int
30,Int
86), (Int
40,Int
80), (Int
50,Int
74), (Int
60,Int
60), (Int
70,Int
52)
                     , (Int
80,Int
44), (Int
90,Int
39), (Int
100,Int
35)
                     ]
  Hue
HuePurple     -> Maybe (Int, Int) -> [(Int, Int)] -> ColorDefinition
ColorDefinition (forall a. a -> Maybe a
Just (Int
258,Int
282))
                     [ (Int
20,Int
100), (Int
30,Int
87), (Int
40,Int
79), (Int
50,Int
70), (Int
60,Int
65), (Int
70,Int
59)
                     , (Int
80,Int
52), (Int
90,Int
45), (Int
100,Int
42)
                     ]
  Hue
HuePink       -> Maybe (Int, Int) -> [(Int, Int)] -> ColorDefinition
ColorDefinition (forall a. a -> Maybe a
Just (Int
283,Int
334))
                     [ (Int
20,Int
100), (Int
30,Int
90), (Int
40,Int
86), (Int
60,Int
84), (Int
80,Int
80), (Int
90,Int
75)
                     , (Int
100,Int
73)
                     ]
  Hue
HueRandom     -> Maybe (Int, Int) -> [(Int, Int)] -> ColorDefinition
ColorDefinition (forall a. a -> Maybe a
Just (Int
0, Int
359)) []

getHue :: Int -> Hue
getHue :: Int -> Hue
getHue Int
n
  | Int
n' forall a. Eq a => a -> a -> Bool
== Int
0   = Hue
HueMonochrome
  | Int
n' forall a. Ord a => a -> a -> Bool
>= Int
283 = Hue
HuePink
  | Int
n' forall a. Ord a => a -> a -> Bool
>= Int
258 = Hue
HuePurple
  | Int
n' forall a. Ord a => a -> a -> Bool
>= Int
179 = Hue
HueBlue
  | Int
n' forall a. Ord a => a -> a -> Bool
>= Int
63  = Hue
HueGreen
  | Int
n' forall a. Ord a => a -> a -> Bool
>= Int
47  = Hue
HueYellow
  | Int
n' forall a. Ord a => a -> a -> Bool
>= Int
19  = Hue
HueOrange
  | Int
n' forall a. Ord a => a -> a -> Bool
>= -Int
26 = Hue
HueRed
  | Bool
otherwise = forall a. HasCallStack => [Char] -> a
error [Char]
"getHue: hue outside [0, 360]"
  where
    n' :: Int
n' = if Int
n forall a. Ord a => a -> a -> Bool
>= Int
334 Bool -> Bool -> Bool
&& Int
n forall a. Ord a => a -> a -> Bool
<= Int
360 then Int
n forall a. Num a => a -> a -> a
- Int
360 else Int
n

-- | Return a random hue in the range $[lo, hi]$ as a 'Double'.
--   lo should be >= 0 and hi < 360.
--   Instead of storing red as two seperate ranges we create a single
--   contiguous range using negative numbers.
randomHue :: MonadRandom m => Hue -> m Int
randomHue :: forall (m :: * -> *). MonadRandom m => Hue -> m Int
randomHue Hue
h = do
  Int
hue <- forall (m :: * -> *) a. (MonadRandom m, Random a) => (a, a) -> m a
getRandomR (Int
lo, Int
hi)
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ if Int
hue forall a. Ord a => a -> a -> Bool
< Int
0 then Int
hue forall a. Num a => a -> a -> a
+ Int
360 else Int
hue
  where
    hr :: Maybe (Int, Int)
hr = ColorDefinition -> Maybe (Int, Int)
hueRange forall b c a. (b -> c) -> (a -> b) -> a -> c
. Hue -> ColorDefinition
getColorDefinition forall a b. (a -> b) -> a -> b
$ Hue
h
    (Int
lo, Int
hi) = forall a. a -> Maybe a -> a
fromMaybe (Int
0, Int
0) Maybe (Int, Int)
hr

saturationRange :: Hue -> (Int, Int)
saturationRange :: Hue -> (Int, Int)
saturationRange Hue
hue = (Int, Int)
result
  where
    lbs :: [(Int, Int)]
lbs = ColorDefinition -> [(Int, Int)]
lowerBounds forall a b. (a -> b) -> a -> b
$ Hue -> ColorDefinition
getColorDefinition Hue
hue
    result :: (Int, Int)
result = case [(Int, Int)]
lbs of
      [] -> forall a. HasCallStack => [Char] -> a
error [Char]
"Can\'t obtain saturationRange from an empty lowerBounds"
      [(Int, Int)]
_  -> (forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> a
head forall a b. (a -> b) -> a -> b
$ [(Int, Int)]
lbs, forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> a
last forall a b. (a -> b) -> a -> b
$ [(Int, Int)]
lbs)

randomSaturation :: MonadRandom m => Hue -> Luminosity -> m Int
randomSaturation :: forall (m :: * -> *). MonadRandom m => Hue -> Luminosity -> m Int
randomSaturation Hue
HueMonochrome Luminosity
_   = forall (m :: * -> *) a. Monad m => a -> m a
return Int
0

randomSaturation Hue
hue           Luminosity
lum = case Luminosity
lum of
  Luminosity
LumRandom -> forall (m :: * -> *) a. (MonadRandom m, Random a) => (a, a) -> m a
getRandomR (Int
0, Int
100)
  Luminosity
LumBright -> forall (m :: * -> *) a. (MonadRandom m, Random a) => (a, a) -> m a
getRandomR (Int
55, Int
hi)
  Luminosity
LumDark   -> forall (m :: * -> *) a. (MonadRandom m, Random a) => (a, a) -> m a
getRandomR (Int
hi forall a. Num a => a -> a -> a
- Int
10, Int
hi)
  Luminosity
LumLight  -> forall (m :: * -> *) a. (MonadRandom m, Random a) => (a, a) -> m a
getRandomR (Int
lo, Int
55)
  where
    (Int
lo, Int
hi) = Hue -> (Int, Int)
saturationRange Hue
hue

minBrightness :: Hue -> Int -> Int
minBrightness :: Hue -> Int -> Int
minBrightness Hue
hue Int
saturationValue = forall a b. (RealFrac a, Integral b) => a -> b
round forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe Double
0 Maybe Double
result
  where
    lbs :: [(Int, Int)]
lbs = ColorDefinition -> [(Int, Int)]
lowerBounds forall a b. (a -> b) -> a -> b
$ Hue -> ColorDefinition
getColorDefinition Hue
hue
    tup :: [b] -> [(b, b)]
tup [b]
a  = forall a b. [a] -> [b] -> [(a, b)]
zip (b
0forall a. a -> [a] -> [a]
:[b]
a) [b]
a
    inRange :: a -> (a, a) -> Bool
inRange a
j (a
k, a
n) = a
j forall a. Ord a => a -> a -> Bool
>= a
k Bool -> Bool -> Bool
&& a
j forall a. Ord a => a -> a -> Bool
<= a
n
    result :: Maybe Double
    result :: Maybe Double
result = do
      (Int
s1, Int
s2) <- forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (forall {a}. Ord a => a -> (a, a) -> Bool
inRange Int
saturationValue) (forall {b}. Num b => [b] -> [(b, b)]
tup forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst [(Int, Int)]
lbs)
      Int
v1       <- forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Int
s1 [(Int, Int)]
lbs
      Int
v2       <- forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Int
s2 [(Int, Int)]
lbs
      let m :: Double
m = forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
v2 forall a. Num a => a -> a -> a
- Int
v1) forall a. Fractional a => a -> a -> a
/ forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
s2 forall a. Num a => a -> a -> a
-Int
s1)
          b :: Double
b = forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
v1 forall a. Num a => a -> a -> a
- Double
m forall a. Num a => a -> a -> a
* forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
s1
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Double
m forall a. Num a => a -> a -> a
* forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
saturationValue forall a. Num a => a -> a -> a
+ Double
b

-- | Pick a random brightness value given a 'Hue', 'Luminosity' and saturation.
randomBrightness :: MonadRandom m => Hue -> Luminosity -> Int -> m Int
randomBrightness :: forall (m :: * -> *).
MonadRandom m =>
Hue -> Luminosity -> Int -> m Int
randomBrightness Hue
hue Luminosity
lum Int
saturationValue = forall (m :: * -> *) a. (MonadRandom m, Random a) => (a, a) -> m a
getRandomR (Int
bMin, Int
bMax)
  where
    b :: Int
b            = Hue -> Int -> Int
minBrightness Hue
hue Int
saturationValue
    (Int
bMin, Int
bMax) = case Luminosity
lum of
      Luminosity
LumBright -> (Int
b, Int
100)
      Luminosity
LumDark   -> (Int
b, Int
b forall a. Num a => a -> a -> a
+ Int
20)
      Luminosity
LumLight  -> ((Int
b forall a. Num a => a -> a -> a
+ Int
100) forall a. Integral a => a -> a -> a
`div` Int
2, Int
100)
      Luminosity
LumRandom -> (Int
0, Int
100)

-- | Generate a random opaque color.
--
-- <<diagrams/src_Data_Colour_Palette_RandomColor_red.svg>>
--
-- > randomColor HueRed LumBright
--
-- <<diagrams/src_Data_Colour_Palette_RandomColor_orange.svg>>
--
-- > randomColor HueOrange LumBright
--
-- <<diagrams/src_Data_Colour_Palette_RandomColor_yellow.svg>>
--
-- > randomColor HueYellow LumBright
--
-- <<diagrams/src_Data_Colour_Palette_RandomColor_green.svg>>
--
-- > randomColor HueGreen LumBright
--
-- <<diagrams/src_Data_Colour_Palette_RandomColor_blue.svg>>
--
-- > randomColor HueBlue LumBright
--
-- <<diagrams/src_Data_Colour_Palette_RandomColor_purple.svg>>
--
-- > randomColor HuePurple LumBright
--
-- <<diagrams/src_Data_Colour_Palette_RandomColor_pink.svg>>
--
-- > randomColor HuePink LumBright
--
-- <<diagrams/src_Data_Colour_Palette_RandomColor_monochrome.svg>>
--
-- > randomColor HueMonochrome LumRandom
--
-- <<diagrams/src_Data_Colour_Palette_RandomColor_light.svg>>
--
-- > randomColor HueRandom LumLight
--
-- <<diagrams/src_Data_Colour_Palette_RandomColor_dark.svg>>
--
-- > randomColor HueRandom LumDark
--
-- <<diagrams/src_Data_Colour_Palette_RandomColor_random.svg>>
--
-- > randomColor HueRandom LumRandom
-- /Better to use 'randomCIELab' for truly random colors/.
randomColor :: MonadRandom m => Hue -> Luminosity -> m Kolor
randomColor :: forall (m :: * -> *). MonadRandom m => Hue -> Luminosity -> m Kolor
randomColor Hue
hue Luminosity
lum = do
  Int
hueValue <- forall (m :: * -> *). MonadRandom m => Hue -> m Int
randomHue Hue
hue
  let hue' :: Hue
hue'  = Int -> Hue
getHue Int
hueValue
  Int
satValue <- forall (m :: * -> *). MonadRandom m => Hue -> Luminosity -> m Int
randomSaturation Hue
hue' Luminosity
lum
  Int
briValue <- forall (m :: * -> *).
MonadRandom m =>
Hue -> Luminosity -> Int -> m Int
randomBrightness Hue
hue' Luminosity
lum Int
satValue
  let (RGB Double
r Double
g Double
b) = forall a. (RealFrac a, Ord a) => a -> a -> a -> RGB a
hsv (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
hueValue)
                        (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
satValue forall a. Fractional a => a -> a -> a
/ Double
100)
                        (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
briValue forall a. Fractional a => a -> a -> a
/ Double
100)
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall b. (Ord b, Floating b) => b -> b -> b -> Colour b
sRGB Double
r Double
g Double
b

-- | Return a random harmony based on a seed color.
randomHarmony :: MonadRandom m => Kolor -> m [Kolor]
randomHarmony :: forall (m :: * -> *). MonadRandom m => Kolor -> m [Kolor]
randomHarmony Kolor
c = do
  Kolor -> [Kolor]
harmony <- forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadRandom m) =>
t a -> m a
uniform
             [ Kolor -> [Kolor]
monochrome
             , Kolor -> [Kolor]
complement
             , Kolor -> [Kolor]
triad
             , Kolor -> [Kolor]
tetrad
             , Kolor -> [Kolor]
analogic
             , Kolor -> [Kolor]
accentAnalogic
             ]
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Kolor -> [Kolor]
harmony Kolor
c

-- | Generate a random color palette. First choose a random color then choose a
--   random harmony and apply it.
--
-- <<diagrams/src_Data_Colour_Palette_RandomColor_palette.svg>>
--
-- > randomPalette
randomPalette :: MonadRandom m => Hue -> Luminosity ->m [Kolor]
randomPalette :: forall (m :: * -> *).
MonadRandom m =>
Hue -> Luminosity -> m [Kolor]
randomPalette Hue
hue Luminosity
lum = forall (m :: * -> *). MonadRandom m => Hue -> Luminosity -> m Kolor
randomColor Hue
hue Luminosity
lum forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *). MonadRandom m => Kolor -> m [Kolor]
randomHarmony

-- | Generate a random color from CIELAB (a perceptually uniform color space)
--   with a White point of 'd65'. Probably the best choice if you want a totally
--   random color.
--
-- <<diagrams/src_Data_Colour_Palette_RandomColor_cielab.svg>>
--
-- > randomCIELab
randomCIELab :: MonadRandom m => m Kolor
randomCIELab :: forall (m :: * -> *). MonadRandom m => m Kolor
randomCIELab = do
  Double
l <- forall (m :: * -> *) a. (MonadRandom m, Random a) => (a, a) -> m a
getRandomR (Double
0, Double
100)
  Double
a <- forall (m :: * -> *) a. (MonadRandom m, Random a) => (a, a) -> m a
getRandomR (-Double
100, Double
100)
  Double
b <- forall (m :: * -> *) a. (MonadRandom m, Random a) => (a, a) -> m a
getRandomR (-Double
100, Double
100)
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a.
(Ord a, Floating a) =>
Chromaticity a -> a -> a -> a -> Colour a
cieLAB forall a. Fractional a => Chromaticity a
d65 Double
l Double
a Double
b

-- | Generate a random color palette using 'randomCIELab'. First choose a
--   random color then choose a random harmony and apply it.
--
-- <<diagrams/src_Data_Colour_Palette_RandomColor_labpalette.svg>>
--
-- > randomCIELabPalette
randomCIELabPalette :: MonadRandom m => m [Kolor]
randomCIELabPalette :: forall (m :: * -> *). MonadRandom m => m [Kolor]
randomCIELabPalette = forall (m :: * -> *). MonadRandom m => m Kolor
randomCIELab forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *). MonadRandom m => Kolor -> m [Kolor]
randomHarmony