{-# 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 = \case
HueMonochrome -> ColorDefinition Nothing [(0,0),(100, 0)]
HueRed -> ColorDefinition (Just (-26,18))
[ (20,100), (30,92), (40,89), (50,85), (60,78), (70,70)
, (80,60), (90,55), (100,50)
]
HueOrange -> ColorDefinition (Just (19,46))
[ (20,100), (30,93), (40,88), (50,86), (60,85), (70,70)
, (100,70)
]
HueYellow -> ColorDefinition (Just (47,62))
[ (25,100), (40,94), (50,89), (60,86), (70,84), (80,82)
, (90,80), (100,75)
]
HueGreen -> ColorDefinition (Just (63,178))
[ (30,100), (40,90), (50,85), (60,81), (70,74), (80,64)
, (90,50), (100,40)
]
HueBlue -> ColorDefinition (Just (179,257))
[ (20,100), (30,86), (40,80), (50,74), (60,60), (70,52)
, (80,44), (90,39), (100,35)
]
HuePurple -> ColorDefinition (Just (258,282))
[ (20,100), (30,87), (40,79), (50,70), (60,65), (70,59)
, (80,52), (90,45), (100,42)
]
HuePink -> ColorDefinition (Just (283,334))
[ (20,100), (30,90), (40,86), (60,84), (80,80), (90,75)
, (100,73)
]
HueRandom -> ColorDefinition (Just (0, 359)) []
getHue :: Int -> Hue
getHue n
| n' == 0 = HueMonochrome
| n' >= 283 = HuePink
| n' >= 258 = HuePurple
| n' >= 179 = HueBlue
| n' >= 63 = HueGreen
| n' >= 47 = HueYellow
| n' >= 19 = HueOrange
| n' >= -26 = HueRed
| otherwise = error "getHue: hue outside [0, 360]"
where
n' = if n >= 334 && n <= 360 then n - 360 else n
randomHue :: MonadRandom m => Hue -> m Int
randomHue h = do
hue <- getRandomR (lo, hi)
return $ if hue < 0 then hue + 360 else hue
where
hr = hueRange . getColorDefinition $ h
(lo, hi) = fromMaybe (0, 0) hr
saturationRange :: Hue -> (Int, Int)
saturationRange hue = result
where
lbs = lowerBounds $ getColorDefinition hue
result = case lbs of
[] -> error "Can\'t obtain saturationRange from an empty lowerBounds"
_ -> (fst . head $ lbs, fst . last $ lbs)
randomSaturation :: MonadRandom m => Hue -> Luminosity -> m Int
randomSaturation HueMonochrome _ = return 0
randomSaturation hue lum = case lum of
LumRandom -> getRandomR (0, 100)
LumBright -> getRandomR (55, hi)
LumDark -> getRandomR (hi - 10, hi)
LumLight -> getRandomR (lo, 55)
where
(lo, hi) = saturationRange hue
minBrightness :: Hue -> Int -> Int
minBrightness hue saturationValue = round $ fromMaybe 0 result
where
lbs = lowerBounds $ getColorDefinition hue
tup a = zip (0:a) a
inRange j (k, n) = j >= k && j <= n
result :: Maybe Double
result = do
(s1, s2) <- find (inRange saturationValue) (tup $ fmap fst lbs)
v1 <- lookup s1 lbs
v2 <- lookup s2 lbs
let m = fromIntegral (v2 - v1) / fromIntegral (s2 -s1)
b = fromIntegral v1 - m * fromIntegral s1
return $ m * fromIntegral saturationValue + b
randomBrightness :: MonadRandom m => Hue -> Luminosity -> Int -> m Int
randomBrightness hue lum saturationValue = getRandomR (bMin, bMax)
where
b = minBrightness hue saturationValue
(bMin, bMax) = case lum of
LumBright -> (b, 100)
LumDark -> (b, b + 20)
LumLight -> ((b + 100) `div` 2, 100)
LumRandom -> (0, 100)
randomColor :: MonadRandom m => Hue -> Luminosity -> m Kolor
randomColor hue lum = do
hueValue <- randomHue hue
let hue' = getHue hueValue
satValue <- randomSaturation hue' lum
briValue <- randomBrightness hue' lum satValue
let (RGB r g b) = hsv (fromIntegral hueValue)
(fromIntegral satValue / 100)
(fromIntegral briValue / 100)
return $ sRGB r g b
randomHarmony :: MonadRandom m => Kolor -> m [Kolor]
randomHarmony c = do
harmony <- uniform
[ monochrome
, complement
, triad
, tetrad
, analogic
, accentAnalogic
]
return $ harmony c
randomPalette :: MonadRandom m => Hue -> Luminosity ->m [Kolor]
randomPalette hue lum = randomColor hue lum >>= randomHarmony
randomCIELab :: MonadRandom m => m Kolor
randomCIELab = do
l <- getRandomR (0, 100)
a <- getRandomR (-100, 100)
b <- getRandomR (-100, 100)
return $ cieLAB d65 l a b
randomCIELabPalette :: MonadRandom m => m [Kolor]
randomCIELabPalette = randomCIELab >>= randomHarmony