{-# LANGUAGE LambdaCase #-}
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
module Data.Colour.Palette.RandomColor
(
randomCIELab
, randomCIELabPalette
, randomColor
, randomPalette
, randomHarmony
, 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
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
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)
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
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
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
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
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