chart-svg-0.8.3.2: src/Data/Colour.hs
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
-- | Colour representations and combinations.
module Data.Colour
( -- * Colour
Colour,
pattern Colour,
validColour,
validate,
trimColour,
showRGBA,
showRGB,
showOpacity,
opac',
opac,
rgb,
-- * Palette colours
palette,
paletteO,
transparent,
black,
white,
light,
dark,
grey,
-- * LCH model
LCH (..),
lLCH',
cLCH',
hLCH',
LCHA (..),
pattern LCHA,
lch',
alpha',
RGB3 (..),
rgbd',
rgb32colour',
LAB (..),
lcha2colour',
xy2ch',
-- * mixins
mix,
mixTrim,
mixLCHA,
mixes,
greyed,
lightness',
chroma',
hue',
showSwatch,
showSwatches,
rvRGB3,
rvColour,
paletteR,
)
where
import Chart.Data
import Data.Bool (bool)
import Data.ByteString (ByteString)
import Data.ByteString.Char8 (pack)
import Data.Data
import Data.FormatN
import Data.List qualified as List
import Data.Text (Text)
import Data.Text qualified as Text
import GHC.Generics hiding (prec)
import Graphics.Color.Model as M hiding (LCH)
import Graphics.Color.Space qualified as S
import Harpie.Fixed (Array, array, (!))
import Harpie.Fixed qualified as F
import Harpie.Shape (KnownNats)
import Optics.Core
import System.Random
import System.Random.Stateful
{-# ANN module ("doctest-parallel: --no-implicit-module-import" :: String) #-}
-- $setup
--
-- >>> :set -XOverloadedLabels
-- >>> :set -XOverloadedStrings
-- >>> import Chart
-- >>> import Optics.Core
-- | Colour type for the library: red, green, blue, opacity in [0,1].
data Colour = Colour Double Double Double Double
deriving (Eq, Generic, Data)
instance Show Colour where
show (Colour r g b a) =
Text.unpack $
"Colour "
<> fixed (Just 2) r
<> " "
<> fixed (Just 2) g
<> " "
<> fixed (Just 2) b
<> " "
<> fixed (Just 2) a
-- | CSS-style representation
showRGBA :: Colour -> ByteString
showRGBA (Colour r' g' b' a') =
pack $ Text.unpack $ "rgba(" <> r <> ", " <> g <> ", " <> b <> ", " <> a <> ")"
where
r = percent (fixedSF (Just 0)) (Just 2) r'
g = percent (fixedSF (Just 0)) (Just 2) g'
b = percent (fixedSF (Just 0)) (Just 2) b'
a = fixed (Just 2) a'
-- | CSS-style representation
showRGB :: Colour -> ByteString
showRGB (Colour r' g' b' _) =
pack $ Text.unpack $ "rgb(" <> r <> ", " <> g <> ", " <> b <> ")"
where
r = percent (fixedSF (Just 0)) (Just 2) r'
g = percent (fixedSF (Just 0)) (Just 2) g'
b = percent (fixedSF (Just 0)) (Just 2) b'
-- | Is Colour in-gamut?
--
-- >>> validColour (Colour 1 1 1.01 1)
-- False
validColour :: Colour -> Bool
validColour (Colour r g b o) = r >= 0 && r <= 1 && g >= 0 && g <= 1 && b >= 0 && b <= 1 && o >= 0 && o <= 1
-- | Trim colour back to gamut.
--
-- >>> trimColour (Colour 1 1 1.01 1)
-- Colour 1.00 1.00 1.00 1.00
trimColour :: Colour -> Colour
trimColour (Colour r g b a) = Colour (trim r) (trim g) (trim b) (trim a)
where
trim x = max 0 $ min 1 x
-- | Validate that the Colout is in-gamut.
--
-- >>> validate (Colour 1 1 1.01 1)
-- Nothing
validate :: Colour -> Maybe Colour
validate c = bool Nothing (Just c) (validColour c)
-- | Opacity or alpha
opac :: Colour -> Double
opac (Colour _ _ _ o) = o
-- | CSS-style representation
showOpacity :: Colour -> ByteString
showOpacity c = pack $ Text.unpack $ formatOrShow (FixedStyle 2) Nothing (opac c)
-- | lens for opacity (or alpha channel)
opac' :: Lens' Colour Double
opac' = lens opac (\(Colour r g b _) o -> Colour r g b o)
-- | Sets RGB color but not opacity
rgb :: Colour -> Colour -> Colour
rgb (Colour r g b _) (Colour _ _ _ o) = Colour r g b o
-- | Select a Colour from the palette
--
-- >>> palette 0
-- Colour 0.02 0.73 0.80 1.00
--
-- 
palette :: Int -> Colour
palette x = cycle palette1_ List.!! x
palette1LCHA_ :: [LCHA]
palette1LCHA_ = [LCHA 0.72 0.123 207 1, LCHA 0.40 0.10 246 1, LCHA 0.50 0.21 338 1, LCHA 0.8 0.15 331 1, LCHA 0.83 0.14 69 1, LCHA 0.57 0.15 50 1, LCHA 0.38 0.085 128 1, LCHA 0.60 0.08 104 1]
-- | Finite list of Colours
--
-- Swatched to the oklab color model:
--
-- 
palette1_ :: [Colour]
palette1_ = trimColour . view lcha2colour' <$> palette1LCHA_
-- | Select a Colour from the palette with a specified opacity
--
-- >>> paletteO 0 0.5
-- Colour 0.02 0.73 0.80 0.50
paletteO :: Int -> Double -> Colour
paletteO x a = set opac' a $ cycle palette1_ List.!! x
-- | black
--
-- >>> black
-- Colour 0.00 0.00 0.00 1.00
black :: Colour
black = Colour 0 0 0 1
-- | white
--
-- >>> white
-- Colour 0.99 0.99 0.99 1.00
white :: Colour
white = Colour 0.99 0.99 0.99 1
-- | light
--
-- For lighter huds against a dark background ...
--
-- > colourHudOptions light defaultHudOptions
--
-- >>> light
-- Colour 0.94 0.94 0.94 1.00
light :: Colour
light = Colour 0.94 0.94 0.94 1
-- | dark
--
-- dark is hardcoded in most of the default options.
--
-- >>> dark
-- Colour 0.05 0.05 0.05 1.00
dark :: Colour
dark = Colour 0.05 0.05 0.05 1
-- | Grey(scale) colour inputting lightness and opacity.
--
-- >>> grey 0.5 0.4
-- Colour 0.50 0.50 0.50 0.40
grey :: Double -> Double -> Colour
grey g a = Colour g g g a
-- | Zero-opacity black
--
-- >>> transparent
-- Colour 0.00 0.00 0.00 0.00
transparent :: Colour
transparent = Colour 0 0 0 0
class ArrayAs f s a where
arrayAs :: (KnownNats s) => Array s a -> f a
-- | LCH colour representation
--
-- oklab is a colour space being written into CSS specifications, that attempts to be ok at human-consistent colour representation. See:
--
-- - <https://bottosson.github.io/posts/oklab/ A perceptual color space for image processing>
-- - <https://www.w3.org/TR/css-color-5/#colorcontrast CSS Color Module Level 5>
-- - <https://www.w3.org/TR/css-color-4/#rgb-functions CSS Color Module Level 4>
--
-- The type is represented by three elements:
--
-- L: Lightness ranging from 0 (@LCH 0 _ _@ is black) to 1 (@LCH 1 _ _@ is white)
--
-- C: Chromacity, which ranges from 0 to around 0.32 or so.
--
-- H: Hue, which ranges from 0 to 360
data LCH a = LCH a a a deriving (Eq, Show, Functor)
instance ArrayAs LCH '[3] a where
arrayAs a = LCH (a ! [0]) (a ! [1]) (a ! [2])
-- | Lightness lens for LCH
lLCH' :: Lens' (LCH Double) Double
lLCH' = lens (\(LCH l _ _) -> l) (\(LCH _ c h) l -> LCH l c h)
-- | Chromacity lens for LCH
cLCH' :: Lens' (LCH Double) Double
cLCH' = lens (\(LCH _ c _) -> c) (\(LCH l _ h) c -> LCH l c h)
-- | Hue lens for LCH
hLCH' :: Lens' (LCH Double) Double
hLCH' = lens (\(LCH _ _ h) -> h) (\(LCH l c _) h -> LCH l c h)
-- | LCHA representation, including an alpha channel.
data LCHA = LCHA' {_lch :: LCH Double, _alpha :: Double} deriving (Eq, Show)
-- | LCH lens for LCHA
lch' :: Lens' LCHA (LCH Double)
lch' = lens (\(LCHA' lch _) -> lch) (\(LCHA' _ a) lch -> LCHA' lch a)
-- | Alpha lens for LCHA
alpha' :: Lens' LCHA Double
alpha' = lens (\(LCHA' _ a) -> a) (\(LCHA' lch _) a -> LCHA' lch a)
-- | LCHA pattern
pattern LCHA :: Double -> Double -> Double -> Double -> LCHA
pattern LCHA l c h a <-
LCHA' (LCH l c h) a
where
LCHA l c h a = LCHA' (LCH l c h) a
{-# COMPLETE LCHA #-}
-- * RGB colour representation
-- | A type to represent the RGB triple, useful as an intermediary between 'Colour' and 'LCHA'
data RGB3 a = RGB3 a a a deriving (Eq, Show, Functor)
instance ArrayAs RGB3 '[3] a where
arrayAs a = RGB3 (a ! [0]) (a ! [1]) (a ! [2])
-- | Lens for conversion between Double and Word8 RGB triples.
rgbd' :: Iso' (RGB3 Double) (RGB3 Word8)
rgbd' = iso (fmap (floor . (* 256))) (fmap (\x -> fromIntegral x / 256.0))
-- | Lens for conversion between an (RGB3, alpha) pair and Colour
rgb32colour' :: Iso' (RGB3 Double, Double) Colour
rgb32colour' = iso (\(RGB3 r g b, a) -> Colour r g b a) (\(Colour r g b a) -> (RGB3 r g b, a))
-- * LAB colour representation
-- | LAB colour representation. a is green-red and b is blue-yellow
data LAB a = LAB a a a deriving (Eq, Show, Functor)
instance ArrayAs LAB '[3] a where
arrayAs a = LAB (a ! [0]) (a ! [1]) (a ! [2])
-- * Colour conversions
-- * lcha to colour
-- | LCHA to Colour lens
--
-- >>> c0 = Colour 0.78 0.36 0.02 1.00
-- >>> view (re lcha2colour') c0
-- LCHA' {_lch = LCH 0.5969891006896103 0.15793931531669247 49.191113810479784, _alpha = 1.0}
--
-- >>> view (re lcha2colour' % lcha2colour') c0
-- Colour 0.78 0.36 0.02 1.00
--
-- >>> c1 = Colour 0.49 0.14 0.16 1
-- >>> view (re lcha2colour') c1
-- LCHA' {_lch = LCH 0.40115567099848914 0.12279066817938503 21.51476756026837, _alpha = 1.0}
--
-- >>> view (re lcha2colour' % lcha2colour') c1
-- Colour 0.49 0.14 0.16 1.00
lcha2colour' :: Iso' LCHA Colour
lcha2colour' =
iso
(\(LCHA' lch a) -> let (RGB3 r g b) = view (re lab2lch' % re rgb2lab') lch in Colour r g b a)
(\c@(Colour _ _ _ a) -> LCHA' (view (re rgb32colour' % _1 % rgb2lab' % lab2lch') c) a)
-- * lab to lch
-- | Lens between generic XY color representations and CH ones, which are polar versions of the XY.
xy2ch' :: Iso' (Double, Double) (Double, Double)
xy2ch' =
iso
(\(x, y) -> (magnitude (Point x y), 180 / pi * mod_ (angle (Point x y)) (2 * pi)))
(\(c, h) -> let (Point x y) = fmap (c *) (ray (pi / 180 * h)) in (x, y))
mod_ :: Double -> Double -> Double
mod_ x d = x - fromIntegral (floor (x / d) :: Integer) * d
-- | Lens between LAB and LCH
lab2lch' :: Iso' (LAB Double) (LCH Double)
lab2lch' =
iso
(\(LAB l a b) -> let (c, h) = view xy2ch' (a, b) in LCH l c h)
(\(LCH l c h) -> let (a, b) = view (re xy2ch') (c, h) in LAB l a b)
-- * rgb to lab
-- | Lens between RGB3 and LAB
rgb2lab' :: Iso' (RGB3 Double) (LAB Double)
rgb2lab' =
iso
(\(RGB3 r g b) -> arrayAs . xyz2lab_ . rgb2xyz_ $ array [r, g, b])
(\(LAB l a b) -> arrayAs . xyz2rgb_ . lab2xyz_ $ array [l, a, b])
-- * rgb to xyz
xyz2rgb_ :: F.Array '[3] Double -> F.Array '[3] Double
xyz2rgb_ a = array [r, g, b]
where
(S.ColorSRGB r g b) = S.xyz2rgb (S.ColorXYZ (a ! [0]) (a ! [1]) (a ! [2])) :: Color (S.SRGB 'S.NonLinear) Double
-- >>> rgb2xyz_ [1,1,1]
-- [0.9505, 1.0, 1.089]
rgb2xyz_ :: F.Array '[3] Double -> F.Array '[3] Double
rgb2xyz_ a = array [x, y, z]
where
(S.ColorXYZ x y z) = S.rgb2xyz (S.ColorSRGB (a ! [0]) (a ! [1]) (a ! [2])) :: Color (S.XYZ S.D65) Double
-- * xyz to lab
m1 :: F.Array '[3, 3] Double
m1 =
array
[ 0.8189330101,
0.3618667424,
-0.1288597137,
0.0329845436,
0.9293118715,
0.0361456387,
0.0482003018,
0.2643662691,
0.6338517070
]
m2 :: F.Array '[3, 3] Double
m2 =
array
[ 0.2104542553,
0.7936177850,
-0.0040720468,
1.9779984951,
-2.4285922050,
0.4505937099,
0.0259040371,
0.7827717662,
-0.8086757660
]
cubicroot :: (Floating a, Ord a) => a -> a
cubicroot x = bool ((-1) * (-x) ** (1 / 3.0)) (x ** (1 / 3.0)) (x >= 0)
-- >>> xyz2lab_ [0.95, 1, 1.089]
-- [0.9999686754143632, -2.580058168537569e-4, -1.1499756458199784e-4]
--
-- >>> xyz2lab_ [1,0,0]
-- [0.4499315814860224, 1.2357102101076207, -1.9027581087245393e-2]
--
-- >>> xyz2lab_ [0,1,0]
-- [0.921816758286376, -0.6712376131199635, 0.2633235500611929]
--
-- >>> xyz2lab_ [1,0,1]
-- [0.5081033967278659, 1.147837087146462, -0.36768466477695416]
--
-- >>> xyz2lab_ [0,0,1]
-- [0.15260258004008057, -1.4149965510120839, -0.4489272035597538]
xyz2lab_ :: F.Array '[3] Double -> F.Array '[3] Double
xyz2lab_ xyz =
F.dot sum (*) m2 (cubicroot <$> F.dot sum (*) m1 xyz)
m1' :: F.Array '[3, 3] Double
m1' =
array
[ 1.227013851103521026,
-0.5577999806518222383,
0.28125614896646780758,
-0.040580178423280593977,
1.1122568696168301049,
-0.071676678665601200577,
-0.076381284505706892869,
-0.42148197841801273055,
1.5861632204407947575
]
m2' :: F.Array '[3, 3] Double
m2' =
array
[ 0.99999999845051981432,
0.39633779217376785678,
0.21580375806075880339,
1.0000000088817607767,
-0.1055613423236563494,
-0.063854174771705903402,
1.0000000546724109177,
-0.089484182094965759684,
-1.2914855378640917399
]
lab2xyz_ :: F.Array '[3] Double -> F.Array '[3] Double
lab2xyz_ lab =
F.dot sum (*) m1' ((** 3.0) <$> F.dot sum (*) m2' lab)
-- * mixins
-- | Mix 2 colours, using the oklch model.
--
-- This may not always be what you expect. One example is mixing black and another colour:
--
-- >>> mix 0.8 (Colour 0 0 0 1) (Colour 0.2 0.6 0.8 0.5)
-- Colour -0.09 0.48 0.45 0.60
--
-- The mix has gone out of gamut because we are swishing through hue mixes.
--
-- In this case, settting the hue on the black colour within the LCH contruct helps:
--
-- >>> betterblack = set (lch' % hLCH') (view hue' (Colour 0.2 0.6 0.8 0.5)) (review lcha2colour' black)
-- >>> view lcha2colour' $ mixLCHA 0.8 betterblack (review lcha2colour' $ Colour 0.2 0.6 0.8 0.5)
-- Colour 0.14 0.44 0.59 0.60
mix :: Double -> Colour -> Colour -> Colour
mix x c0 c1 = view lcha2colour' (mixLCHA x (review lcha2colour' c0) (review lcha2colour' c1))
-- | Mix 2 colours, using the oklch model, trimming the reult back to in-gamut.
--
-- >>> mixTrim 0.8 (Colour 0 0 0 1) (Colour 0.2 0.6 0.8 0.5)
-- Colour 0.00 0.48 0.45 0.60
mixTrim :: Double -> Colour -> Colour -> Colour
mixTrim x c0 c1 = trimColour (mix x c0 c1)
-- | Mix two LCHA specified colours.
mixLCHA :: Double -> LCHA -> LCHA -> LCHA
mixLCHA x (LCHA l c h a) (LCHA l' c' h' a') = LCHA l'' c'' h'' a''
where
l'' = l + x * (l' - l)
c'' = c + x * (c' - c)
h'' = h + x * (h' - h)
a'' = a + x * (a' - a)
-- | Interpolate across a list of Colours, with input being in Range 0 1
--
-- >>> mixes 0 [black, (Colour 0.2 0.6 0.8 0.5), white]
-- Colour 0.00 0.00 0.00 1.00
--
-- >>> mixes 1 [black, (Colour 0.2 0.6 0.8 0.5), white]
-- Colour 0.99 0.99 0.99 1.00
--
-- >>> mixes 0.6 [black, (Colour 0.2 0.6 0.8 0.5), white]
-- Colour 0.42 0.67 0.86 0.60
mixes :: Double -> [Colour] -> Colour
mixes _ [] = light
mixes _ [c] = c
mixes x cs = mix r (cs List.!! i') (cs List.!! (i' + 1))
where
l = length cs - 1
x' = x * fromIntegral l
i' = max 0 (min (floor x') (l - 1))
r = x' - fromIntegral i'
-- * Colour manipulation
-- | Convert a colour to grayscale with the same lightness.
--
-- >>> greyed (Colour 0.4 0.7 0.8 0.4)
-- Colour 0.65 0.65 0.65 0.40
greyed :: Colour -> Colour
greyed = over chroma' (const 0)
-- | Lightness lens
--
-- >>> over lightness' (*0.8) (Colour 0.4 0.7 0.8 0.4)
-- Colour 0.22 0.52 0.62 0.40
lightness' :: Lens' Colour Double
lightness' = re lcha2colour' % lch' % lLCH'
-- | Chromacity lens
--
-- >>> over chroma' (*0.8) (Colour 0.4 0.7 0.8 0.4)
-- Colour 0.46 0.69 0.77 0.40
chroma' :: Lens' Colour Double
chroma' = re lcha2colour' % lch' % cLCH'
-- | Hue lens
--
-- >>> over hue' (+180) (Colour 0.4 0.7 0.8 0.4)
-- Colour 0.83 0.58 0.49 0.40
hue' :: Lens' Colour Double
hue' = re lcha2colour' % lch' % hLCH'
-- | Html element to display colours
--
-- >>> showSwatch "swatch" dark
-- "<div class=swatch style=\"background:rgba(5%, 5%, 5%, 1.00);\">swatch</div>"
showSwatch :: Text -> Colour -> Text
showSwatch label (Colour r' g' b' a') =
"<div class=swatch style=\"background:" <> rgba <> ";\">" <> label <> "</div>"
where
rgba = "rgba(" <> r <> ", " <> g <> ", " <> b <> ", " <> a <> ")"
r = percent (fixedSF (Just 0)) (Just 2) r'
g = percent (fixedSF (Just 0)) (Just 2) g'
b = percent (fixedSF (Just 0)) (Just 2) b'
a = fixed (Just 2) a'
-- | Show multiple colors with embedded text.
showSwatches :: Text -> Text -> [(Text, Colour)] -> Text
showSwatches pref suff hs = "<div>" <> "\n" <> pref <> "\n" <> divs <> "\n" <> suff <> "\n" <> "</div>"
where
divs = Text.intercalate "\n" (uncurry showSwatch <$> hs)
-- * random colors
instance Uniform (RGB3 Double) where
uniformM gen = do
r <- uniformRM (0, 1) gen
g <- uniformRM (0, 1) gen
b <- uniformRM (0, 1) gen
pure (RGB3 r g b)
instance Uniform Colour where
uniformM gen = do
r <- uniformRM (0, 1) gen
g <- uniformRM (0, 1) gen
b <- uniformRM (0, 1) gen
a <- uniformRM (0, 1) gen
pure (Colour r g b a)
-- | Random variates of a uniform
rvs :: (Uniform a) => [a]
rvs = go g0
where
g0 = mkStdGen 42
go g = let (x, g') = uniform g in x : go g'
-- | Random list of RGB3s
rvRGB3 :: [RGB3 Double]
rvRGB3 = rvs
-- | Random list of Colours
rvColour :: [Colour]
rvColour = rvs
-- | Random Colours with an opacity of 1 that are not too extreme in terms of lightness or chromacity.
paletteR :: [Colour]
paletteR = go g0
where
g0 = mkStdGen 42
go g = let (x, g') = runStateGen g rvSensible in x : go g'
-- | A random Colour generator that provides a (hopefully) pleasant colour not too light, dark, over-saturated or dull.
rvSensible :: (StatefulGen g m) => g -> m Colour
rvSensible gen = do
l <- uniformRM (0.3, 0.75) gen
c <- uniformRM (0.05, 0.24) gen
h <- uniformRM (0, 360) gen
pure ((trimColour . view lcha2colour') (LCHA l c h 1))