{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralisedNewtypeDeriving #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wall #-} -- | Colour representations and combinations. -- module Data.Colour ( -- * Colour Colour, pattern Colour, validColour, validate, trimColour, showRGBA, showRGB, opac', opac, hex, rgb, toHex, fromHex, unsafeFromHex, -- * Palette colours palette1, palette1a, transparent, black, white, light, dark, grey, -- * LCH model LCH (..), pattern LCH, lLCH', cLCH', hLCH', LCHA (..), pattern LCHA, lch', alpha', RGB3 (..), pattern RGB3, rgbd', rgb32colour', LAB (..), pattern LAB, lcha2colour', xy2ch', -- * mixins mix, mixTrim, mixLCHA, mixes, greyed, lightness', chroma', hue', showSwatch, showSwatches, rvRGB3, rvColour, paletteR, ) where import Chart.Data import qualified Data.Attoparsec.Text as A import Data.Bifunctor import Data.Bool (bool) import Data.Char import Data.Either import Data.FormatN import Data.Functor.Rep import qualified Data.List as List import Data.Text (Text, pack) import qualified Data.Text as Text import GHC.Exts import GHC.Generics hiding (prec) import Graphics.Color.Model as M hiding (LCH) import qualified Graphics.Color.Space as S import NeatInterpolation import NumHask.Algebra.Metric import NumHask.Array.Fixed import Optics.Core import System.Random import System.Random.Stateful -- $setup -- -- >>> :set -XOverloadedLabels -- >>> :set -XOverloadedStrings -- >>> import Chart -- >>> import Optics.Core -- | Colour type for the library, wrapping 'Color'. -- newtype Colour = Colour' { color' :: Color (Alpha RGB) Double } deriving (Eq, Generic) -- | Constructor pattern. -- -- > Colour red green blue alpha -- pattern Colour :: Double -> Double -> Double -> Double -> Colour pattern Colour r g b a = Colour' (ColorRGBA r g b a) {-# COMPLETE Colour #-} 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 -> Text showRGBA (Colour r' g' b' a') = [trimming|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 -> Text showRGB (Colour r' g' b' _) = [trimming|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 -- | lens for opacity (or alpha channel) opac' :: Lens' Colour Double opac' = lens opac (\(Colour r g b _) o -> Colour r g b o) -- | Convert to CSS hex representation. hex :: Colour -> Text hex c = toHex c -- | Sets RGB color but not opacity rgb :: Colour -> Colour -> Colour rgb (Colour r g b _) (Colour _ _ _ o) = Colour r g b o -- | Parse CSS hex text. parseHex :: A.Parser (Color RGB Double) parseHex = fmap toDouble . ( \((r, g), b) -> ColorRGB (fromIntegral r) (fromIntegral g) (fromIntegral b) :: Color RGB Word8 ) . (\(f, b) -> (f `divMod` (256 :: Int), b)) . (`divMod` 256) <$> (A.string "#" *> A.hexadecimal) -- | Convert CSS hex to Colour fromHex :: Text -> Either Text (Color RGB Double) fromHex = first pack . A.parseOnly parseHex -- | Convert CSS hex to Colour, unsafely. unsafeFromHex :: Text -> Color RGB Double unsafeFromHex t = fromRight (ColorRGB 0 0 0) $ A.parseOnly parseHex t -- | Convert from 'Colour' to CSS hex (#xxxxxx) toHex :: Colour -> Text toHex c = "#" <> Text.justifyRight 2 '0' (hex' r) <> Text.justifyRight 2 '0' (hex' g) <> Text.justifyRight 2 '0' (hex' b) where (ColorRGBA r g b _) = fromIntegral . toWord8 <$> color' c -- | hex' :: Int -> Text hex' i | i < 0 = "-" <> go (-i) | otherwise = go i where go n | n < 16 = hexDigit n | otherwise = go (n `quot` 16) <> hexDigit (n `rem` 16) -- | hexDigit :: Int -> Text hexDigit n | n <= 9 = Text.singleton $! i2d n | otherwise = Text.singleton $! toEnum (n + 87) -- | i2d :: Int -> Char i2d i = chr (ord '0' + i) -- | Select a Colour from the palette -- -- >>> palette1 0 -- Colour 0.02 0.73 0.80 1.00 -- -- ![wheel](other/wheel.svg) palette1 :: Int -> Colour palette1 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](other/palette1.svg) palette1_ :: [Colour] palette1_ = trimColour . view lcha2colour' <$> palette1LCHA_ -- | Select a Colour from the palette with a specified opacity -- -- >>> palette1a 0 0.5 -- Colour 0.02 0.73 0.80 0.50 palette1a :: Int -> Double -> Colour palette1a 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 -- | LCH colour representation -- -- oklab is a colour space being written into CSS specifications, that attempts to be ok at human-consistent colour representation. See: -- -- - -- - -- - -- -- 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 newtype LCH a = LCH' {lchArray :: Array '[3] a} deriving (Eq, Show, IsList, Functor) -- | LCH colour pattern pattern LCH :: a -> a -> a -> LCH a pattern LCH l c h <- LCH' [l, c, h] where LCH l c h = LCH' [l, c, h] {-# COMPLETE LCH #-} -- | 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' newtype RGB3 a = RGB3' {rgb3Array :: Array '[3] a} deriving (Eq, Show, IsList, Functor) -- | The RGB3 pattern pattern RGB3 :: a -> a -> a -> RGB3 a pattern RGB3 r g b <- RGB3' [r, g, b] where RGB3 r g b = RGB3' [r, g, b] {-# COMPLETE RGB3 #-} -- | 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 newtype LAB a = LAB' {labArray :: Array '[3] a} deriving (Eq, Show, IsList, Functor) -- | LAB pattern pattern LAB :: a -> a -> a -> LAB a pattern LAB l a b <- LAB' [l, a, b] where LAB l a b = LAB' [l, a, b] {-# COMPLETE LAB #-} -- * 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' {lchArray = [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' {lchArray = [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 version of the XY. xy2ch' :: Iso' (Double, Double) (Double, Double) xy2ch' = iso (\(x, y) -> (norm (Point x y), 180 / pi * mod_ (angle (Point x y)) (2 * pi))) (\(c, h) -> let (Point x y) = coord (Polar c (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' a) -> LAB' . xyz2lab_ . rgb2xyz_ $ a) (\(LAB' a) -> RGB3' . xyz2rgb_ . lab2xyz_ $ a) -- * rgb to xyz xyz2rgb_ :: Array '[3] Double -> Array '[3] Double xyz2rgb_ a = fromList [r, g, b] where (S.ColorSRGB r g b) = S.xyz2rgb (S.ColorXYZ (a `index` [0]) (a `index` [1]) (a `index` [2])) :: Color (S.SRGB 'S.NonLinear) Double -- >>> rgb2xyz_ [1,1,1] -- [0.9505, 1.0, 1.089] rgb2xyz_ :: Array '[3] Double -> Array '[3] Double rgb2xyz_ a = fromList [x, y, z] where (S.ColorXYZ x y z) = S.rgb2xyz (S.ColorSRGB (a `index` [0]) (a `index` [1]) (a `index` [2])) :: Color (S.XYZ S.D65) Double -- * xyz to lab m1 :: Array '[3, 3] Double m1 = [ 0.8189330101, 0.3618667424, -0.1288597137, 0.0329845436, 0.9293118715, 0.0361456387, 0.0482003018, 0.2643662691, 0.6338517070 ] m2 :: Array '[3, 3] Double m2 = [ 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_ :: Array '[3] Double -> Array '[3] Double xyz2lab_ xyz = dot sum (*) m2 (cubicroot <$> dot sum (*) m1 xyz) m1' :: Array '[3, 3] Double m1' = [ 1.227013851103521026, -0.5577999806518222383, 0.28125614896646780758, -0.040580178423280593977, 1.1122568696168301049, -0.071676678665601200577, -0.076381284505706892869, -0.42148197841801273055, 1.5861632204407947575 ] m2' :: Array '[3, 3] Double m2' = [ 0.99999999845051981432, 0.39633779217376785678, 0.21580375806075880339, 1.0000000088817607767, -0.1055613423236563494, -0.063854174771705903402, 1.0000000546724109177, -0.089484182094965759684, -1.2914855378640917399 ] lab2xyz_ :: Array '[3] Double -> Array '[3] Double lab2xyz_ lab = dot sum (*) m1' ((** 3.0) <$> 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 -- "
swatch
" showSwatch :: Text -> Colour -> Text showSwatch label c = [trimming|
$label
|] where rgba = showRGBA c -- | Show multiple colors with embedded text. showSwatches :: Text -> Text -> [(Text, Colour)] -> Text showSwatches pref suff hs = [trimming|
$pref $divs $suff
|] 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))