{-# 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 = \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 -- | 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 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 -- | Pick a random brightness value given a 'Hue', 'Luminosity' and saturation. 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) -- | Generate a random opaque color. -- -- <> -- -- > randomColor HueRed LumBright -- -- <> -- -- > randomColor HueOrange LumBright -- -- <> -- -- > randomColor HueYellow LumBright -- -- <> -- -- > randomColor HueGreen LumBright -- -- <> -- -- > randomColor HueBlue LumBright -- -- <> -- -- > randomColor HuePurple LumBright -- -- <> -- -- > randomColor HuePink LumBright -- -- <> -- -- > randomColor HueMonochrome LumRandom -- -- <> -- -- > randomColor HueRandom LumLight -- -- <> -- -- > randomColor HueRandom LumDark -- -- <> -- -- > randomColor HueRandom LumRandom -- /Better to use 'randomCIELab' for truly random colors/. 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 -- | Return a random harmony based on a seed color. randomHarmony :: MonadRandom m => Kolor -> m [Kolor] randomHarmony c = do harmony <- uniform [ monochrome , complement , triad , tetrad , analogic , accentAnalogic ] return $ harmony c -- | Generate a random color palette. First choose a random color then choose a -- random harmony and apply it. -- -- <> -- -- > randomPalette randomPalette :: MonadRandom m => Hue -> Luminosity ->m [Kolor] randomPalette hue lum = randomColor hue lum >>= 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. -- -- <> -- -- > randomCIELab 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 -- | Generate a random color palette using 'randomCIELab'. First choose a -- random color then choose a random harmony and apply it. -- -- <> -- -- > randomCIELabPalette randomCIELabPalette :: MonadRandom m => m [Kolor] randomCIELabPalette = randomCIELab >>= randomHarmony