{-# 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 qualified Data.List.NonEmpty as NE
import Data.Maybe (fromMaybe)
getColorDefinition :: Hue -> ColorDefinition
getColorDefinition :: Hue -> ColorDefinition
getColorDefinition = \case
Hue
HueMonochrome -> Maybe (Int, Int) -> [(Int, Int)] -> ColorDefinition
ColorDefinition Maybe (Int, Int)
forall a. Maybe a
Nothing [(Int
0,Int
0),(Int
100, Int
0)]
Hue
HueRed -> Maybe (Int, Int) -> [(Int, Int)] -> ColorDefinition
ColorDefinition ((Int, Int) -> Maybe (Int, Int)
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 ((Int, Int) -> Maybe (Int, Int)
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 ((Int, Int) -> Maybe (Int, Int)
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 ((Int, Int) -> Maybe (Int, Int)
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 ((Int, Int) -> Maybe (Int, Int)
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 ((Int, Int) -> Maybe (Int, Int)
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 ((Int, Int) -> Maybe (Int, Int)
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 ((Int, Int) -> Maybe (Int, Int)
forall a. a -> Maybe a
Just (Int
0, Int
359)) []
getHue :: Int -> Hue
getHue :: Int -> Hue
getHue Int
n
| Int
n' Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = Hue
HueMonochrome
| Int
n' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
283 = Hue
HuePink
| Int
n' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
258 = Hue
HuePurple
| Int
n' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
179 = Hue
HueBlue
| Int
n' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
63 = Hue
HueGreen
| Int
n' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
47 = Hue
HueYellow
| Int
n' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
19 = Hue
HueOrange
| Int
n' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= -Int
26 = Hue
HueRed
| Bool
otherwise = [Char] -> Hue
forall a. HasCallStack => [Char] -> a
error [Char]
"getHue: hue outside [0, 360]"
where
n' :: Int
n' = if Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
334 Bool -> Bool -> Bool
&& Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
360 then Int
n Int -> Int -> Int
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 <- (Int, Int) -> m Int
forall a. Random a => (a, a) -> m a
forall (m :: * -> *) a. (MonadRandom m, Random a) => (a, a) -> m a
getRandomR (Int
lo, Int
hi)
Int -> m Int
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> m Int) -> Int -> m Int
forall a b. (a -> b) -> a -> b
$ if Int
hue Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 then Int
hue Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
360 else Int
hue
where
hr :: Maybe (Int, Int)
hr = ColorDefinition -> Maybe (Int, Int)
hueRange (ColorDefinition -> Maybe (Int, Int))
-> (Hue -> ColorDefinition) -> Hue -> Maybe (Int, Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Hue -> ColorDefinition
getColorDefinition (Hue -> Maybe (Int, Int)) -> Hue -> Maybe (Int, Int)
forall a b. (a -> b) -> a -> b
$ Hue
h
(Int
lo, Int
hi) = (Int, Int) -> Maybe (Int, Int) -> (Int, Int)
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 (ColorDefinition -> [(Int, Int)])
-> ColorDefinition -> [(Int, Int)]
forall a b. (a -> b) -> a -> b
$ Hue -> ColorDefinition
getColorDefinition Hue
hue
result :: (Int, Int)
result = case [(Int, Int)] -> Maybe (NonEmpty (Int, Int))
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [(Int, Int)]
lbs of
Maybe (NonEmpty (Int, Int))
Nothing -> [Char] -> (Int, Int)
forall a. HasCallStack => [Char] -> a
error [Char]
"Can\'t obtain saturationRange from an empty lowerBounds"
Just NonEmpty (Int, Int)
lbsNE -> ((Int, Int) -> Int
forall a b. (a, b) -> a
fst ((Int, Int) -> Int)
-> (NonEmpty (Int, Int) -> (Int, Int))
-> NonEmpty (Int, Int)
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (Int, Int) -> (Int, Int)
forall a. NonEmpty a -> a
NE.head (NonEmpty (Int, Int) -> Int) -> NonEmpty (Int, Int) -> Int
forall a b. (a -> b) -> a -> b
$ NonEmpty (Int, Int)
lbsNE, (Int, Int) -> Int
forall a b. (a, b) -> a
fst ((Int, Int) -> Int)
-> (NonEmpty (Int, Int) -> (Int, Int))
-> NonEmpty (Int, Int)
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (Int, Int) -> (Int, Int)
forall a. NonEmpty a -> a
NE.last (NonEmpty (Int, Int) -> Int) -> NonEmpty (Int, Int) -> Int
forall a b. (a -> b) -> a -> b
$ NonEmpty (Int, Int)
lbsNE)
randomSaturation :: MonadRandom m => Hue -> Luminosity -> m Int
randomSaturation :: forall (m :: * -> *). MonadRandom m => Hue -> Luminosity -> m Int
randomSaturation Hue
HueMonochrome Luminosity
_ = Int -> m Int
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
0
randomSaturation Hue
hue Luminosity
lum = case Luminosity
lum of
Luminosity
LumRandom -> (Int, Int) -> m Int
forall a. Random a => (a, a) -> m a
forall (m :: * -> *) a. (MonadRandom m, Random a) => (a, a) -> m a
getRandomR (Int
0, Int
100)
Luminosity
LumBright -> (Int, Int) -> m Int
forall a. Random a => (a, a) -> m a
forall (m :: * -> *) a. (MonadRandom m, Random a) => (a, a) -> m a
getRandomR (Int
55, Int
hi)
Luminosity
LumDark -> (Int, Int) -> m Int
forall a. Random a => (a, a) -> m a
forall (m :: * -> *) a. (MonadRandom m, Random a) => (a, a) -> m a
getRandomR (Int
hi Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
10, Int
hi)
Luminosity
LumLight -> (Int, Int) -> m Int
forall a. Random a => (a, a) -> m a
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 = Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (Double -> Int) -> Double -> Int
forall a b. (a -> b) -> a -> b
$ Double -> Maybe Double -> Double
forall a. a -> Maybe a -> a
fromMaybe Double
0 Maybe Double
result
where
lbs :: [(Int, Int)]
lbs = ColorDefinition -> [(Int, Int)]
lowerBounds (ColorDefinition -> [(Int, Int)])
-> ColorDefinition -> [(Int, Int)]
forall a b. (a -> b) -> a -> b
$ Hue -> ColorDefinition
getColorDefinition Hue
hue
tup :: [b] -> [(b, b)]
tup [b]
a = [b] -> [b] -> [(b, b)]
forall a b. [a] -> [b] -> [(a, b)]
zip (b
0b -> [b] -> [b]
forall a. a -> [a] -> [a]
:[b]
a) [b]
a
inRange :: a -> (a, a) -> Bool
inRange a
j (a
k, a
n) = a
j a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= a
k Bool -> Bool -> Bool
&& a
j a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
n
result :: Maybe Double
result :: Maybe Double
result = do
(Int
s1, Int
s2) <- ((Int, Int) -> Bool) -> [(Int, Int)] -> Maybe (Int, Int)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (Int -> (Int, Int) -> Bool
forall {a}. Ord a => a -> (a, a) -> Bool
inRange Int
saturationValue) ([Int] -> [(Int, Int)]
forall {b}. Num b => [b] -> [(b, b)]
tup ([Int] -> [(Int, Int)]) -> [Int] -> [(Int, Int)]
forall a b. (a -> b) -> a -> b
$ ((Int, Int) -> Int) -> [(Int, Int)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int, Int) -> Int
forall a b. (a, b) -> a
fst [(Int, Int)]
lbs)
Int
v1 <- Int -> [(Int, Int)] -> Maybe Int
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Int
s1 [(Int, Int)]
lbs
Int
v2 <- Int -> [(Int, Int)] -> Maybe Int
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Int
s2 [(Int, Int)]
lbs
let m :: Double
m = Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
v2 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
v1) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
s2 Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
s1)
b :: Double
b = Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
v1 Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
m Double -> Double -> Double
forall a. Num a => a -> a -> a
* Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
s1
Double -> Maybe Double
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (Double -> Maybe Double) -> Double -> Maybe Double
forall a b. (a -> b) -> a -> b
$ Double
m Double -> Double -> Double
forall a. Num a => a -> a -> a
* Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
saturationValue Double -> Double -> Double
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 = (Int, Int) -> m Int
forall a. Random a => (a, a) -> m a
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 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
20)
Luminosity
LumLight -> ((Int
b Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
100) Int -> Int -> Int
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 <- Hue -> m Int
forall (m :: * -> *). MonadRandom m => Hue -> m Int
randomHue Hue
hue
let hue' :: Hue
hue' = Int -> Hue
getHue Int
hueValue
Int
satValue <- Hue -> Luminosity -> m Int
forall (m :: * -> *). MonadRandom m => Hue -> Luminosity -> m Int
randomSaturation Hue
hue' Luminosity
lum
Int
briValue <- Hue -> Luminosity -> Int -> m Int
forall (m :: * -> *).
MonadRandom m =>
Hue -> Luminosity -> Int -> m Int
randomBrightness Hue
hue' Luminosity
lum Int
satValue
let (RGB Double
r Double
g Double
b) = Double -> Double -> Double -> RGB Double
forall a. (RealFrac a, Ord a) => a -> a -> a -> RGB a
hsv (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
hueValue)
(Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
satValue Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
100)
(Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
briValue Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
100)
Kolor -> m Kolor
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Kolor -> m Kolor) -> Kolor -> m Kolor
forall a b. (a -> b) -> a -> b
$ Double -> Double -> Double -> Kolor
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 <- [Kolor -> [Kolor]] -> m (Kolor -> [Kolor])
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
]
[Kolor] -> m [Kolor]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Kolor] -> m [Kolor]) -> [Kolor] -> m [Kolor]
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 = Hue -> Luminosity -> m Kolor
forall (m :: * -> *). MonadRandom m => Hue -> Luminosity -> m Kolor
randomColor Hue
hue Luminosity
lum m Kolor -> (Kolor -> m [Kolor]) -> m [Kolor]
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Kolor -> m [Kolor]
forall (m :: * -> *). MonadRandom m => Kolor -> m [Kolor]
randomHarmony
randomCIELab :: MonadRandom m => m Kolor
randomCIELab :: forall (m :: * -> *). MonadRandom m => m Kolor
randomCIELab = do
Double
l <- (Double, Double) -> m Double
forall a. Random a => (a, a) -> m a
forall (m :: * -> *) a. (MonadRandom m, Random a) => (a, a) -> m a
getRandomR (Double
0, Double
100)
Double
a <- (Double, Double) -> m Double
forall a. Random a => (a, a) -> m a
forall (m :: * -> *) a. (MonadRandom m, Random a) => (a, a) -> m a
getRandomR (-Double
100, Double
100)
Double
b <- (Double, Double) -> m Double
forall a. Random a => (a, a) -> m a
forall (m :: * -> *) a. (MonadRandom m, Random a) => (a, a) -> m a
getRandomR (-Double
100, Double
100)
Kolor -> m Kolor
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Kolor -> m Kolor) -> Kolor -> m Kolor
forall a b. (a -> b) -> a -> b
$ Chromaticity Double -> Double -> Double -> Double -> Kolor
forall a.
(Ord a, Floating a) =>
Chromaticity a -> a -> a -> a -> Colour a
cieLAB Chromaticity Double
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 = m Kolor
forall (m :: * -> *). MonadRandom m => m Kolor
randomCIELab m Kolor -> (Kolor -> m [Kolor]) -> m [Kolor]
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Kolor -> m [Kolor]
forall (m :: * -> *). MonadRandom m => Kolor -> m [Kolor]
randomHarmony