{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE QuasiQuotes #-}

-- | 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.FormatN
import Data.List qualified as List
import Data.String.Interpolate
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, wrapping 'Color'.
newtype Colour = Colour'
  { Colour -> Color (Alpha RGB) Double
color' :: Color (Alpha RGB) Double
  }
  deriving (Colour -> Colour -> Bool
(Colour -> Colour -> Bool)
-> (Colour -> Colour -> Bool) -> Eq Colour
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Colour -> Colour -> Bool
== :: Colour -> Colour -> Bool
$c/= :: Colour -> Colour -> Bool
/= :: Colour -> Colour -> Bool
Eq, (forall x. Colour -> Rep Colour x)
-> (forall x. Rep Colour x -> Colour) -> Generic Colour
forall x. Rep Colour x -> Colour
forall x. Colour -> Rep Colour x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Colour -> Rep Colour x
from :: forall x. Colour -> Rep Colour x
$cto :: forall x. Rep Colour x -> Colour
to :: forall x. Rep Colour x -> Colour
Generic)

-- | Constructor pattern.
--
-- > Colour red green blue alpha
pattern Colour :: Double -> Double -> Double -> Double -> Colour
pattern $mColour :: forall {r}.
Colour
-> (Double -> Double -> Double -> Double -> r) -> ((# #) -> r) -> r
$bColour :: Double -> Double -> Double -> Double -> Colour
Colour r g b a = Colour' (ColorRGBA r g b a)

{-# COMPLETE Colour #-}

instance Show Colour where
  show :: Colour -> String
show (Colour Double
r Double
g Double
b Double
a) =
    Text -> String
Text.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$
      Text
"Colour "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Maybe Int -> Double -> Text
fixed (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
2) Double
r
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Maybe Int -> Double -> Text
fixed (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
2) Double
g
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Maybe Int -> Double -> Text
fixed (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
2) Double
b
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Maybe Int -> Double -> Text
fixed (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
2) Double
a

-- | CSS-style representation
showRGBA :: Colour -> ByteString
showRGBA :: Colour -> ByteString
showRGBA (Colour Double
r' Double
g' Double
b' Double
a') =
  [i|rgba(#{r}, #{g}, #{b}, #{a})|]
  where
    r :: Text
r = (SigFig -> Text) -> Maybe Int -> Double -> Text
percent (Maybe Int -> SigFig -> Text
fixedSF (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
0)) (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
2) Double
r'
    g :: Text
g = (SigFig -> Text) -> Maybe Int -> Double -> Text
percent (Maybe Int -> SigFig -> Text
fixedSF (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
0)) (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
2) Double
g'
    b :: Text
b = (SigFig -> Text) -> Maybe Int -> Double -> Text
percent (Maybe Int -> SigFig -> Text
fixedSF (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
0)) (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
2) Double
b'
    a :: Text
a = Maybe Int -> Double -> Text
fixed (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
2) Double
a'

-- | CSS-style representation
showRGB :: Colour -> ByteString
showRGB :: Colour -> ByteString
showRGB (Colour Double
r' Double
g' Double
b' Double
_) =
  [i|rgb(#{r}, #{g}, #{b})|]
  where
    r :: Text
r = (SigFig -> Text) -> Maybe Int -> Double -> Text
percent (Maybe Int -> SigFig -> Text
fixedSF (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
0)) (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
2) Double
r'
    g :: Text
g = (SigFig -> Text) -> Maybe Int -> Double -> Text
percent (Maybe Int -> SigFig -> Text
fixedSF (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
0)) (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
2) Double
g'
    b :: Text
b = (SigFig -> Text) -> Maybe Int -> Double -> Text
percent (Maybe Int -> SigFig -> Text
fixedSF (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
0)) (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
2) Double
b'

-- | Is Colour in-gamut?
--
-- >>> validColour (Colour 1 1 1.01 1)
-- False
validColour :: Colour -> Bool
validColour :: Colour -> Bool
validColour (Colour Double
r Double
g Double
b Double
o) = Double
r Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>= Double
0 Bool -> Bool -> Bool
&& Double
r Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= Double
1 Bool -> Bool -> Bool
&& Double
g Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>= Double
0 Bool -> Bool -> Bool
&& Double
g Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= Double
1 Bool -> Bool -> Bool
&& Double
b Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>= Double
0 Bool -> Bool -> Bool
&& Double
b Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= Double
1 Bool -> Bool -> Bool
&& Double
o Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>= Double
0 Bool -> Bool -> Bool
&& Double
o Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= Double
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 -> Colour
trimColour (Colour Double
r Double
g Double
b Double
a) = Double -> Double -> Double -> Double -> Colour
Colour (Double -> Double
forall {a}. (Ord a, Num a) => a -> a
trim Double
r) (Double -> Double
forall {a}. (Ord a, Num a) => a -> a
trim Double
g) (Double -> Double
forall {a}. (Ord a, Num a) => a -> a
trim Double
b) (Double -> Double
forall {a}. (Ord a, Num a) => a -> a
trim Double
a)
  where
    trim :: a -> a
trim a
x = a -> a -> a
forall a. Ord a => a -> a -> a
max a
0 (a -> a) -> a -> a
forall a b. (a -> b) -> a -> b
$ a -> a -> a
forall a. Ord a => a -> a -> a
min a
1 a
x

-- | Validate that the Colout is in-gamut.
--
-- >>> validate (Colour 1 1 1.01 1)
-- Nothing
validate :: Colour -> Maybe Colour
validate :: Colour -> Maybe Colour
validate Colour
c = Maybe Colour -> Maybe Colour -> Bool -> Maybe Colour
forall a. a -> a -> Bool -> a
bool Maybe Colour
forall a. Maybe a
Nothing (Colour -> Maybe Colour
forall a. a -> Maybe a
Just Colour
c) (Colour -> Bool
validColour Colour
c)

-- | Opacity or alpha
opac :: Colour -> Double
opac :: Colour -> Double
opac (Colour Double
_ Double
_ Double
_ Double
o) = Double
o

-- | CSS-style representation
showOpacity :: Colour -> ByteString
showOpacity :: Colour -> ByteString
showOpacity Colour
c =
  [i|#{o}|]
  where
    o :: Text
o = FormatStyle -> Maybe Int -> Double -> Text
formatOrShow (Int -> FormatStyle
FixedStyle Int
2) Maybe Int
forall a. Maybe a
Nothing (Colour -> Double
opac Colour
c)

-- | lens for opacity (or alpha channel)
opac' :: Lens' Colour Double
opac' :: Lens' Colour Double
opac' = (Colour -> Double)
-> (Colour -> Double -> Colour) -> Lens' Colour Double
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens Colour -> Double
opac (\(Colour Double
r Double
g Double
b Double
_) Double
o -> Double -> Double -> Double -> Double -> Colour
Colour Double
r Double
g Double
b Double
o)

-- | Sets RGB color but not opacity
rgb :: Colour -> Colour -> Colour
rgb :: Colour -> Colour -> Colour
rgb (Colour Double
r Double
g Double
b Double
_) (Colour Double
_ Double
_ Double
_ Double
o) = Double -> Double -> Double -> Double -> Colour
Colour Double
r Double
g Double
b Double
o

-- | Select a Colour from the palette
--
-- >>> palette 0
-- Colour 0.02 0.73 0.80 1.00
--
-- ![wheel](other/wheel.svg)
palette :: Int -> Colour
palette :: Int -> Colour
palette Int
x = [Colour] -> [Colour]
forall a. HasCallStack => [a] -> [a]
cycle [Colour]
palette1_ [Colour] -> Int -> Colour
forall a. HasCallStack => [a] -> Int -> a
List.!! Int
x

palette1LCHA_ :: [LCHA]
palette1LCHA_ :: [LCHA]
palette1LCHA_ = [Double -> Double -> Double -> Double -> LCHA
LCHA Double
0.72 Double
0.123 Double
207 Double
1, Double -> Double -> Double -> Double -> LCHA
LCHA Double
0.40 Double
0.10 Double
246 Double
1, Double -> Double -> Double -> Double -> LCHA
LCHA Double
0.50 Double
0.21 Double
338 Double
1, Double -> Double -> Double -> Double -> LCHA
LCHA Double
0.8 Double
0.15 Double
331 Double
1, Double -> Double -> Double -> Double -> LCHA
LCHA Double
0.83 Double
0.14 Double
69 Double
1, Double -> Double -> Double -> Double -> LCHA
LCHA Double
0.57 Double
0.15 Double
50 Double
1, Double -> Double -> Double -> Double -> LCHA
LCHA Double
0.38 Double
0.085 Double
128 Double
1, Double -> Double -> Double -> Double -> LCHA
LCHA Double
0.60 Double
0.08 Double
104 Double
1]

-- | Finite list of Colours
--
-- Swatched to the oklab color model:
--
-- ![palette](other/palette.svg)
palette1_ :: [Colour]
palette1_ :: [Colour]
palette1_ = Colour -> Colour
trimColour (Colour -> Colour) -> (LCHA -> Colour) -> LCHA -> Colour
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Optic' An_Iso '[] LCHA Colour -> LCHA -> Colour
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' An_Iso '[] LCHA Colour
lcha2colour' (LCHA -> Colour) -> [LCHA] -> [Colour]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [LCHA]
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 :: Int -> Double -> Colour
paletteO Int
x Double
a = Lens' Colour Double -> Double -> Colour -> Colour
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
set Lens' Colour Double
opac' Double
a (Colour -> Colour) -> Colour -> Colour
forall a b. (a -> b) -> a -> b
$ [Colour] -> [Colour]
forall a. HasCallStack => [a] -> [a]
cycle [Colour]
palette1_ [Colour] -> Int -> Colour
forall a. HasCallStack => [a] -> Int -> a
List.!! Int
x

-- | black
--
-- >>> black
-- Colour 0.00 0.00 0.00 1.00
black :: Colour
black :: Colour
black = Double -> Double -> Double -> Double -> Colour
Colour Double
0 Double
0 Double
0 Double
1

-- | white
--
-- >>> white
-- Colour 0.99 0.99 0.99 1.00
white :: Colour
white :: Colour
white = Double -> Double -> Double -> Double -> Colour
Colour Double
0.99 Double
0.99 Double
0.99 Double
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
light = Double -> Double -> Double -> Double -> Colour
Colour Double
0.94 Double
0.94 Double
0.94 Double
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
dark = Double -> Double -> Double -> Double -> Colour
Colour Double
0.05 Double
0.05 Double
0.05 Double
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 :: Double -> Double -> Colour
grey Double
g Double
a = Double -> Double -> Double -> Double -> Colour
Colour Double
g Double
g Double
g Double
a

-- | Zero-opacity black
--
-- >>> transparent
-- Colour 0.00 0.00 0.00 0.00
transparent :: Colour
transparent :: Colour
transparent = Double -> Double -> Double -> Double -> Colour
Colour Double
0 Double
0 Double
0 Double
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 (LCH a -> LCH a -> Bool
(LCH a -> LCH a -> Bool) -> (LCH a -> LCH a -> Bool) -> Eq (LCH a)
forall a. Eq a => LCH a -> LCH a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => LCH a -> LCH a -> Bool
== :: LCH a -> LCH a -> Bool
$c/= :: forall a. Eq a => LCH a -> LCH a -> Bool
/= :: LCH a -> LCH a -> Bool
Eq, Int -> LCH a -> ShowS
[LCH a] -> ShowS
LCH a -> String
(Int -> LCH a -> ShowS)
-> (LCH a -> String) -> ([LCH a] -> ShowS) -> Show (LCH a)
forall a. Show a => Int -> LCH a -> ShowS
forall a. Show a => [LCH a] -> ShowS
forall a. Show a => LCH a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> LCH a -> ShowS
showsPrec :: Int -> LCH a -> ShowS
$cshow :: forall a. Show a => LCH a -> String
show :: LCH a -> String
$cshowList :: forall a. Show a => [LCH a] -> ShowS
showList :: [LCH a] -> ShowS
Show, (forall a b. (a -> b) -> LCH a -> LCH b)
-> (forall a b. a -> LCH b -> LCH a) -> Functor LCH
forall a b. a -> LCH b -> LCH a
forall a b. (a -> b) -> LCH a -> LCH b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> LCH a -> LCH b
fmap :: forall a b. (a -> b) -> LCH a -> LCH b
$c<$ :: forall a b. a -> LCH b -> LCH a
<$ :: forall a b. a -> LCH b -> LCH a
Functor)

instance ArrayAs LCH '[3] a where
  arrayAs :: KnownNats '[3] => Array '[3] a -> LCH a
arrayAs Array '[3] a
a = a -> a -> a -> LCH a
forall a. a -> a -> a -> LCH a
LCH (Array '[3] a
a Array '[3] a -> [Int] -> a
forall (s :: [Natural]) a. KnownNats s => Array s a -> [Int] -> a
! [Int
0]) (Array '[3] a
a Array '[3] a -> [Int] -> a
forall (s :: [Natural]) a. KnownNats s => Array s a -> [Int] -> a
! [Int
1]) (Array '[3] a
a Array '[3] a -> [Int] -> a
forall (s :: [Natural]) a. KnownNats s => Array s a -> [Int] -> a
! [Int
2])

-- | Lightness lens for LCH
lLCH' :: Lens' (LCH Double) Double
lLCH' :: Lens' (LCH Double) Double
lLCH' = (LCH Double -> Double)
-> (LCH Double -> Double -> LCH Double)
-> Lens' (LCH Double) Double
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens (\(LCH Double
l Double
_ Double
_) -> Double
l) (\(LCH Double
_ Double
c Double
h) Double
l -> Double -> Double -> Double -> LCH Double
forall a. a -> a -> a -> LCH a
LCH Double
l Double
c Double
h)

-- | Chromacity lens for LCH
cLCH' :: Lens' (LCH Double) Double
cLCH' :: Lens' (LCH Double) Double
cLCH' = (LCH Double -> Double)
-> (LCH Double -> Double -> LCH Double)
-> Lens' (LCH Double) Double
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens (\(LCH Double
_ Double
c Double
_) -> Double
c) (\(LCH Double
l Double
_ Double
h) Double
c -> Double -> Double -> Double -> LCH Double
forall a. a -> a -> a -> LCH a
LCH Double
l Double
c Double
h)

-- | Hue lens for LCH
hLCH' :: Lens' (LCH Double) Double
hLCH' :: Lens' (LCH Double) Double
hLCH' = (LCH Double -> Double)
-> (LCH Double -> Double -> LCH Double)
-> Lens' (LCH Double) Double
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens (\(LCH Double
_ Double
_ Double
h) -> Double
h) (\(LCH Double
l Double
c Double
_) Double
h -> Double -> Double -> Double -> LCH Double
forall a. a -> a -> a -> LCH a
LCH Double
l Double
c Double
h)

-- | LCHA representation, including an alpha channel.
data LCHA = LCHA' {LCHA -> LCH Double
_lch :: LCH Double, LCHA -> Double
_alpha :: Double} deriving (LCHA -> LCHA -> Bool
(LCHA -> LCHA -> Bool) -> (LCHA -> LCHA -> Bool) -> Eq LCHA
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: LCHA -> LCHA -> Bool
== :: LCHA -> LCHA -> Bool
$c/= :: LCHA -> LCHA -> Bool
/= :: LCHA -> LCHA -> Bool
Eq, Int -> LCHA -> ShowS
[LCHA] -> ShowS
LCHA -> String
(Int -> LCHA -> ShowS)
-> (LCHA -> String) -> ([LCHA] -> ShowS) -> Show LCHA
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LCHA -> ShowS
showsPrec :: Int -> LCHA -> ShowS
$cshow :: LCHA -> String
show :: LCHA -> String
$cshowList :: [LCHA] -> ShowS
showList :: [LCHA] -> ShowS
Show)

-- | LCH lens for LCHA
lch' :: Lens' LCHA (LCH Double)
lch' :: Lens' LCHA (LCH Double)
lch' = (LCHA -> LCH Double)
-> (LCHA -> LCH Double -> LCHA) -> Lens' LCHA (LCH Double)
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens (\(LCHA' LCH Double
lch Double
_) -> LCH Double
lch) (\(LCHA' LCH Double
_ Double
a) LCH Double
lch -> LCH Double -> Double -> LCHA
LCHA' LCH Double
lch Double
a)

-- | Alpha lens for LCHA
alpha' :: Lens' LCHA Double
alpha' :: Lens' LCHA Double
alpha' = (LCHA -> Double) -> (LCHA -> Double -> LCHA) -> Lens' LCHA Double
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens (\(LCHA' LCH Double
_ Double
a) -> Double
a) (\(LCHA' LCH Double
lch Double
_) Double
a -> LCH Double -> Double -> LCHA
LCHA' LCH Double
lch Double
a)

-- | LCHA pattern
pattern LCHA :: Double -> Double -> Double -> Double -> LCHA
pattern $mLCHA :: forall {r}.
LCHA
-> (Double -> Double -> Double -> Double -> r) -> ((# #) -> r) -> r
$bLCHA :: Double -> Double -> Double -> Double -> LCHA
LCHA l c h a <-
  LCHA' (LCH l c h) a
  where
    LCHA Double
l Double
c Double
h Double
a = LCH Double -> Double -> LCHA
LCHA' (Double -> Double -> Double -> LCH Double
forall a. a -> a -> a -> LCH a
LCH Double
l Double
c Double
h) Double
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 (RGB3 a -> RGB3 a -> Bool
(RGB3 a -> RGB3 a -> Bool)
-> (RGB3 a -> RGB3 a -> Bool) -> Eq (RGB3 a)
forall a. Eq a => RGB3 a -> RGB3 a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => RGB3 a -> RGB3 a -> Bool
== :: RGB3 a -> RGB3 a -> Bool
$c/= :: forall a. Eq a => RGB3 a -> RGB3 a -> Bool
/= :: RGB3 a -> RGB3 a -> Bool
Eq, Int -> RGB3 a -> ShowS
[RGB3 a] -> ShowS
RGB3 a -> String
(Int -> RGB3 a -> ShowS)
-> (RGB3 a -> String) -> ([RGB3 a] -> ShowS) -> Show (RGB3 a)
forall a. Show a => Int -> RGB3 a -> ShowS
forall a. Show a => [RGB3 a] -> ShowS
forall a. Show a => RGB3 a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> RGB3 a -> ShowS
showsPrec :: Int -> RGB3 a -> ShowS
$cshow :: forall a. Show a => RGB3 a -> String
show :: RGB3 a -> String
$cshowList :: forall a. Show a => [RGB3 a] -> ShowS
showList :: [RGB3 a] -> ShowS
Show, (forall a b. (a -> b) -> RGB3 a -> RGB3 b)
-> (forall a b. a -> RGB3 b -> RGB3 a) -> Functor RGB3
forall a b. a -> RGB3 b -> RGB3 a
forall a b. (a -> b) -> RGB3 a -> RGB3 b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> RGB3 a -> RGB3 b
fmap :: forall a b. (a -> b) -> RGB3 a -> RGB3 b
$c<$ :: forall a b. a -> RGB3 b -> RGB3 a
<$ :: forall a b. a -> RGB3 b -> RGB3 a
Functor)

instance ArrayAs RGB3 '[3] a where
  arrayAs :: KnownNats '[3] => Array '[3] a -> RGB3 a
arrayAs Array '[3] a
a = a -> a -> a -> RGB3 a
forall a. a -> a -> a -> RGB3 a
RGB3 (Array '[3] a
a Array '[3] a -> [Int] -> a
forall (s :: [Natural]) a. KnownNats s => Array s a -> [Int] -> a
! [Int
0]) (Array '[3] a
a Array '[3] a -> [Int] -> a
forall (s :: [Natural]) a. KnownNats s => Array s a -> [Int] -> a
! [Int
1]) (Array '[3] a
a Array '[3] a -> [Int] -> a
forall (s :: [Natural]) a. KnownNats s => Array s a -> [Int] -> a
! [Int
2])

-- | Lens for conversion between Double and Word8 RGB triples.
rgbd' :: Iso' (RGB3 Double) (RGB3 Word8)
rgbd' :: Iso' (RGB3 Double) (RGB3 Word8)
rgbd' = (RGB3 Double -> RGB3 Word8)
-> (RGB3 Word8 -> RGB3 Double) -> Iso' (RGB3 Double) (RGB3 Word8)
forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso ((Double -> Word8) -> RGB3 Double -> RGB3 Word8
forall a b. (a -> b) -> RGB3 a -> RGB3 b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Double -> Word8
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (Double -> Word8) -> (Double -> Double) -> Double -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
256))) ((Word8 -> Double) -> RGB3 Word8 -> RGB3 Double
forall a b. (a -> b) -> RGB3 a -> RGB3 b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Word8
x -> Word8 -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
x Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
256.0))

-- | Lens for conversion between an (RGB3, alpha) pair and Colour
rgb32colour' :: Iso' (RGB3 Double, Double) Colour
rgb32colour' :: Iso' (RGB3 Double, Double) Colour
rgb32colour' = ((RGB3 Double, Double) -> Colour)
-> (Colour -> (RGB3 Double, Double))
-> Iso' (RGB3 Double, Double) Colour
forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso (\(RGB3 Double
r Double
g Double
b, Double
a) -> Double -> Double -> Double -> Double -> Colour
Colour Double
r Double
g Double
b Double
a) (\(Colour Double
r Double
g Double
b Double
a) -> (Double -> Double -> Double -> RGB3 Double
forall a. a -> a -> a -> RGB3 a
RGB3 Double
r Double
g Double
b, Double
a))

-- * LAB colour representation

-- | LAB colour representation. a is green-red and b is blue-yellow
data LAB a = LAB a a a deriving (LAB a -> LAB a -> Bool
(LAB a -> LAB a -> Bool) -> (LAB a -> LAB a -> Bool) -> Eq (LAB a)
forall a. Eq a => LAB a -> LAB a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => LAB a -> LAB a -> Bool
== :: LAB a -> LAB a -> Bool
$c/= :: forall a. Eq a => LAB a -> LAB a -> Bool
/= :: LAB a -> LAB a -> Bool
Eq, Int -> LAB a -> ShowS
[LAB a] -> ShowS
LAB a -> String
(Int -> LAB a -> ShowS)
-> (LAB a -> String) -> ([LAB a] -> ShowS) -> Show (LAB a)
forall a. Show a => Int -> LAB a -> ShowS
forall a. Show a => [LAB a] -> ShowS
forall a. Show a => LAB a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> LAB a -> ShowS
showsPrec :: Int -> LAB a -> ShowS
$cshow :: forall a. Show a => LAB a -> String
show :: LAB a -> String
$cshowList :: forall a. Show a => [LAB a] -> ShowS
showList :: [LAB a] -> ShowS
Show, (forall a b. (a -> b) -> LAB a -> LAB b)
-> (forall a b. a -> LAB b -> LAB a) -> Functor LAB
forall a b. a -> LAB b -> LAB a
forall a b. (a -> b) -> LAB a -> LAB b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> LAB a -> LAB b
fmap :: forall a b. (a -> b) -> LAB a -> LAB b
$c<$ :: forall a b. a -> LAB b -> LAB a
<$ :: forall a b. a -> LAB b -> LAB a
Functor)

instance ArrayAs LAB '[3] a where
  arrayAs :: KnownNats '[3] => Array '[3] a -> LAB a
arrayAs Array '[3] a
a = a -> a -> a -> LAB a
forall a. a -> a -> a -> LAB a
LAB (Array '[3] a
a Array '[3] a -> [Int] -> a
forall (s :: [Natural]) a. KnownNats s => Array s a -> [Int] -> a
! [Int
0]) (Array '[3] a
a Array '[3] a -> [Int] -> a
forall (s :: [Natural]) a. KnownNats s => Array s a -> [Int] -> a
! [Int
1]) (Array '[3] a
a Array '[3] a -> [Int] -> a
forall (s :: [Natural]) a. KnownNats s => Array s a -> [Int] -> a
! [Int
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' :: Optic' An_Iso '[] LCHA Colour
lcha2colour' =
  (LCHA -> Colour)
-> (Colour -> LCHA) -> Optic' An_Iso '[] LCHA Colour
forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso
    (\(LCHA' LCH Double
lch Double
a) -> let (RGB3 Double
r Double
g Double
b) = Optic' An_Iso '[] (LCH Double) (RGB3 Double)
-> LCH Double -> RGB3 Double
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view (Optic
  An_Iso '[] (LAB Double) (LAB Double) (LCH Double) (LCH Double)
-> Optic
     (ReversedOptic An_Iso)
     '[]
     (LCH Double)
     (LCH Double)
     (LAB Double)
     (LAB Double)
forall (is :: IxList) s t a b.
AcceptsEmptyIndices "re" is =>
Optic An_Iso is s t a b -> Optic (ReversedOptic An_Iso) is b a t s
forall k (is :: IxList) s t a b.
(ReversibleOptic k, AcceptsEmptyIndices "re" is) =>
Optic k is s t a b -> Optic (ReversedOptic k) is b a t s
re Optic
  An_Iso '[] (LAB Double) (LAB Double) (LCH Double) (LCH Double)
lab2lch' Optic
  An_Iso '[] (LCH Double) (LCH Double) (LAB Double) (LAB Double)
-> Optic
     An_Iso '[] (LAB Double) (LAB Double) (RGB3 Double) (RGB3 Double)
-> Optic' An_Iso '[] (LCH Double) (RGB3 Double)
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic
  An_Iso '[] (RGB3 Double) (RGB3 Double) (LAB Double) (LAB Double)
-> Optic
     (ReversedOptic An_Iso)
     '[]
     (LAB Double)
     (LAB Double)
     (RGB3 Double)
     (RGB3 Double)
forall (is :: IxList) s t a b.
AcceptsEmptyIndices "re" is =>
Optic An_Iso is s t a b -> Optic (ReversedOptic An_Iso) is b a t s
forall k (is :: IxList) s t a b.
(ReversibleOptic k, AcceptsEmptyIndices "re" is) =>
Optic k is s t a b -> Optic (ReversedOptic k) is b a t s
re Optic
  An_Iso '[] (RGB3 Double) (RGB3 Double) (LAB Double) (LAB Double)
rgb2lab') LCH Double
lch in Double -> Double -> Double -> Double -> Colour
Colour Double
r Double
g Double
b Double
a)
    (\c :: Colour
c@(Colour Double
_ Double
_ Double
_ Double
a) -> LCH Double -> Double -> LCHA
LCHA' (Optic' A_Lens '[] Colour (LCH Double) -> Colour -> LCH Double
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view (Iso' (RGB3 Double, Double) Colour
-> Optic
     (ReversedOptic An_Iso)
     '[]
     Colour
     Colour
     (RGB3 Double, Double)
     (RGB3 Double, Double)
forall (is :: IxList) s t a b.
AcceptsEmptyIndices "re" is =>
Optic An_Iso is s t a b -> Optic (ReversedOptic An_Iso) is b a t s
forall k (is :: IxList) s t a b.
(ReversibleOptic k, AcceptsEmptyIndices "re" is) =>
Optic k is s t a b -> Optic (ReversedOptic k) is b a t s
re Iso' (RGB3 Double, Double) Colour
rgb32colour' Optic
  An_Iso
  '[]
  Colour
  Colour
  (RGB3 Double, Double)
  (RGB3 Double, Double)
-> Optic
     A_Lens
     '[]
     (RGB3 Double, Double)
     (RGB3 Double, Double)
     (RGB3 Double)
     (RGB3 Double)
-> Optic A_Lens '[] Colour Colour (RGB3 Double) (RGB3 Double)
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic
  A_Lens
  '[]
  (RGB3 Double, Double)
  (RGB3 Double, Double)
  (RGB3 Double)
  (RGB3 Double)
forall s t a b. Field1 s t a b => Lens s t a b
_1 Optic A_Lens '[] Colour Colour (RGB3 Double) (RGB3 Double)
-> Optic
     An_Iso '[] (RGB3 Double) (RGB3 Double) (LAB Double) (LAB Double)
-> Optic A_Lens '[] Colour Colour (LAB Double) (LAB Double)
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic
  An_Iso '[] (RGB3 Double) (RGB3 Double) (LAB Double) (LAB Double)
rgb2lab' Optic A_Lens '[] Colour Colour (LAB Double) (LAB Double)
-> Optic
     An_Iso '[] (LAB Double) (LAB Double) (LCH Double) (LCH Double)
-> Optic' A_Lens '[] Colour (LCH Double)
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic
  An_Iso '[] (LAB Double) (LAB Double) (LCH Double) (LCH Double)
lab2lch') Colour
c) Double
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' (Double, Double) (Double, Double)
xy2ch' =
  ((Double, Double) -> (Double, Double))
-> ((Double, Double) -> (Double, Double))
-> Iso' (Double, Double) (Double, Double)
forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso
    (\(Double
x, Double
y) -> (Point Double -> Mag (Point Double)
forall a. Basis a => a -> Mag a
magnitude (Double -> Double -> Point Double
forall a. a -> a -> Point a
Point Double
x Double
y), Double
180 Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
forall a. Floating a => a
pi Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double -> Double -> Double
mod_ (Point Double -> Dir (Point Double)
forall coord. Direction coord => coord -> Dir coord
angle (Double -> Double -> Point Double
forall a. a -> a -> Point a
Point Double
x Double
y)) (Double
2 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
forall a. Floating a => a
pi)))
    (\(Double
c, Double
h) -> let (Point Double
x Double
y) = (Double -> Double) -> Point Double -> Point Double
forall a b. (a -> b) -> Point a -> Point b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Double
c *) (Dir (Point Double) -> Point Double
forall coord. Direction coord => Dir coord -> coord
ray (Double
forall a. Floating a => a
pi Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
180 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
h)) in (Double
x, Double
y))

mod_ :: Double -> Double -> Double
mod_ :: Double -> Double -> Double
mod_ Double
x Double
d = Double
x Double -> Double -> Double
forall a. Num a => a -> a -> a
- Integer -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Double -> Integer
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (Double
x Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
d) :: Integer) Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
d

-- | Lens between LAB and LCH
lab2lch' :: Iso' (LAB Double) (LCH Double)
lab2lch' :: Optic
  An_Iso '[] (LAB Double) (LAB Double) (LCH Double) (LCH Double)
lab2lch' =
  (LAB Double -> LCH Double)
-> (LCH Double -> LAB Double)
-> Optic
     An_Iso '[] (LAB Double) (LAB Double) (LCH Double) (LCH Double)
forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso
    (\(LAB Double
l Double
a Double
b) -> let (Double
c, Double
h) = Iso' (Double, Double) (Double, Double)
-> (Double, Double) -> (Double, Double)
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Iso' (Double, Double) (Double, Double)
xy2ch' (Double
a, Double
b) in Double -> Double -> Double -> LCH Double
forall a. a -> a -> a -> LCH a
LCH Double
l Double
c Double
h)
    (\(LCH Double
l Double
c Double
h) -> let (Double
a, Double
b) = Iso' (Double, Double) (Double, Double)
-> (Double, Double) -> (Double, Double)
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view (Iso' (Double, Double) (Double, Double)
-> Optic
     (ReversedOptic An_Iso)
     '[]
     (Double, Double)
     (Double, Double)
     (Double, Double)
     (Double, Double)
forall (is :: IxList) s t a b.
AcceptsEmptyIndices "re" is =>
Optic An_Iso is s t a b -> Optic (ReversedOptic An_Iso) is b a t s
forall k (is :: IxList) s t a b.
(ReversibleOptic k, AcceptsEmptyIndices "re" is) =>
Optic k is s t a b -> Optic (ReversedOptic k) is b a t s
re Iso' (Double, Double) (Double, Double)
xy2ch') (Double
c, Double
h) in Double -> Double -> Double -> LAB Double
forall a. a -> a -> a -> LAB a
LAB Double
l Double
a Double
b)

-- * rgb to lab

-- | Lens between RGB3 and LAB
rgb2lab' :: Iso' (RGB3 Double) (LAB Double)
rgb2lab' :: Optic
  An_Iso '[] (RGB3 Double) (RGB3 Double) (LAB Double) (LAB Double)
rgb2lab' =
  (RGB3 Double -> LAB Double)
-> (LAB Double -> RGB3 Double)
-> Optic
     An_Iso '[] (RGB3 Double) (RGB3 Double) (LAB Double) (LAB Double)
forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso
    (\(RGB3 Double
r Double
g Double
b) -> Array '[3] Double -> LAB Double
forall (f :: * -> *) (s :: [Natural]) a.
(ArrayAs f s a, KnownNats s) =>
Array s a -> f a
arrayAs (Array '[3] Double -> LAB Double)
-> (Array '[3] Double -> Array '[3] Double)
-> Array '[3] Double
-> LAB Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Array '[3] Double -> Array '[3] Double
xyz2lab_ (Array '[3] Double -> Array '[3] Double)
-> (Array '[3] Double -> Array '[3] Double)
-> Array '[3] Double
-> Array '[3] Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Array '[3] Double -> Array '[3] Double
rgb2xyz_ (Array '[3] Double -> LAB Double)
-> Array '[3] Double -> LAB Double
forall a b. (a -> b) -> a -> b
$ [Double] -> Array '[3] Double
forall (s :: [Natural]) a t.
(KnownNats s, FromVector t a) =>
t -> Array s a
array [Double
r, Double
g, Double
b])
    (\(LAB Double
l Double
a Double
b) -> Array '[3] Double -> RGB3 Double
forall (f :: * -> *) (s :: [Natural]) a.
(ArrayAs f s a, KnownNats s) =>
Array s a -> f a
arrayAs (Array '[3] Double -> RGB3 Double)
-> (Array '[3] Double -> Array '[3] Double)
-> Array '[3] Double
-> RGB3 Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Array '[3] Double -> Array '[3] Double
xyz2rgb_ (Array '[3] Double -> Array '[3] Double)
-> (Array '[3] Double -> Array '[3] Double)
-> Array '[3] Double
-> Array '[3] Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Array '[3] Double -> Array '[3] Double
lab2xyz_ (Array '[3] Double -> RGB3 Double)
-> Array '[3] Double -> RGB3 Double
forall a b. (a -> b) -> a -> b
$ [Double] -> Array '[3] Double
forall (s :: [Natural]) a t.
(KnownNats s, FromVector t a) =>
t -> Array s a
array [Double
l, Double
a, Double
b])

-- * rgb to xyz

xyz2rgb_ :: F.Array '[3] Double -> F.Array '[3] Double
xyz2rgb_ :: Array '[3] Double -> Array '[3] Double
xyz2rgb_ Array '[3] Double
a = [Double] -> Array '[3] Double
forall (s :: [Natural]) a t.
(KnownNats s, FromVector t a) =>
t -> Array s a
array [Double
r, Double
g, Double
b]
  where
    (S.ColorSRGB Double
r Double
g Double
b) = Color (XYZ D65) Double -> Color (SRGB 'NonLinear) Double
forall {k} (cs :: Linearity -> *) (i :: k) e.
(RedGreenBlue cs i, ColorSpace (cs 'NonLinear) i e,
 ColorSpace (cs 'Linear) i e, RealFloat e) =>
Color (XYZ i) e -> Color (cs 'NonLinear) e
S.xyz2rgb (Double -> Double -> Double -> Color (XYZ D65) Double
forall {k} e (i :: k). e -> e -> e -> Color (XYZ i) e
S.ColorXYZ (Array '[3] Double
a Array '[3] Double -> [Int] -> Double
forall (s :: [Natural]) a. KnownNats s => Array s a -> [Int] -> a
! [Int
0]) (Array '[3] Double
a Array '[3] Double -> [Int] -> Double
forall (s :: [Natural]) a. KnownNats s => Array s a -> [Int] -> a
! [Int
1]) (Array '[3] Double
a Array '[3] Double -> [Int] -> Double
forall (s :: [Natural]) a. KnownNats s => Array s a -> [Int] -> a
! [Int
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_ :: Array '[3] Double -> Array '[3] Double
rgb2xyz_ Array '[3] Double
a = [Double] -> Array '[3] Double
forall (s :: [Natural]) a t.
(KnownNats s, FromVector t a) =>
t -> Array s a
array [Double
x, Double
y, Double
z]
  where
    (S.ColorXYZ Double
x Double
y Double
z) = Color (SRGB 'NonLinear) Double -> Color (XYZ D65) Double
forall {k} (cs :: Linearity -> *) (i :: k) e.
(RedGreenBlue cs i, ColorSpace (cs 'NonLinear) i e,
 ColorSpace (cs 'Linear) i e, RealFloat e) =>
Color (cs 'NonLinear) e -> Color (XYZ i) e
S.rgb2xyz (Double -> Double -> Double -> Color (SRGB 'NonLinear) Double
forall e (l :: Linearity). e -> e -> e -> Color (SRGB l) e
S.ColorSRGB (Array '[3] Double
a Array '[3] Double -> [Int] -> Double
forall (s :: [Natural]) a. KnownNats s => Array s a -> [Int] -> a
! [Int
0]) (Array '[3] Double
a Array '[3] Double -> [Int] -> Double
forall (s :: [Natural]) a. KnownNats s => Array s a -> [Int] -> a
! [Int
1]) (Array '[3] Double
a Array '[3] Double -> [Int] -> Double
forall (s :: [Natural]) a. KnownNats s => Array s a -> [Int] -> a
! [Int
2])) :: Color (S.XYZ S.D65) Double

-- * xyz to lab

m1 :: F.Array '[3, 3] Double
m1 :: Array '[3, 3] Double
m1 =
  [Double] -> Array '[3, 3] Double
forall (s :: [Natural]) a t.
(KnownNats s, FromVector t a) =>
t -> Array s a
array
    [ Double
0.8189330101,
      Double
0.3618667424,
      -Double
0.1288597137,
      Double
0.0329845436,
      Double
0.9293118715,
      Double
0.0361456387,
      Double
0.0482003018,
      Double
0.2643662691,
      Double
0.6338517070
    ]

m2 :: F.Array '[3, 3] Double
m2 :: Array '[3, 3] Double
m2 =
  [Double] -> Array '[3, 3] Double
forall (s :: [Natural]) a t.
(KnownNats s, FromVector t a) =>
t -> Array s a
array
    [ Double
0.2104542553,
      Double
0.7936177850,
      -Double
0.0040720468,
      Double
1.9779984951,
      -Double
2.4285922050,
      Double
0.4505937099,
      Double
0.0259040371,
      Double
0.7827717662,
      -Double
0.8086757660
    ]

cubicroot :: (Floating a, Ord a) => a -> a
cubicroot :: forall a. (Floating a, Ord a) => a -> a
cubicroot a
x = a -> a -> Bool -> a
forall a. a -> a -> Bool -> a
bool ((-a
1) a -> a -> a
forall a. Num a => a -> a -> a
* (-a
x) a -> a -> a
forall a. Floating a => a -> a -> a
** (a
1 a -> a -> a
forall a. Fractional a => a -> a -> a
/ a
3.0)) (a
x a -> a -> a
forall a. Floating a => a -> a -> a
** (a
1 a -> a -> a
forall a. Fractional a => a -> a -> a
/ a
3.0)) (a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= a
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_ :: Array '[3] Double -> Array '[3] Double
xyz2lab_ Array '[3] Double
xyz =
  (Array (Eval (Map (Flip GetDim '[3, 3]) '[1])) Double -> Double)
-> (Double -> Double -> Double)
-> Array '[3, 3] Double
-> Array
     (Eval
        (Foldl'
           (Flip DeleteDim)
           '[3, 3]
           (Eval (Rev (Eval (PreDeletePositionsGo '[1] '[])) '[])))
      <> Eval
           (Foldl'
              (Flip DeleteDim)
              '[3]
              (Eval (Rev (Eval (PreDeletePositionsGo '[0] '[])) '[]))))
     Double
-> Array '[3] Double
forall a b c d (ds0 :: [Natural]) (ds1 :: [Natural])
       (s0 :: [Natural]) (s1 :: [Natural]) (so0 :: [Natural])
       (so1 :: [Natural]) (st :: [Natural]) (si :: [Natural]).
(KnownNats s0, KnownNats s1, KnownNats ds0, KnownNats ds1,
 KnownNats so0, KnownNats so1, KnownNats st, KnownNats si,
 so0 ~ Eval (DeleteDims ds0 s0), so1 ~ Eval (DeleteDims ds1 s1),
 si ~ Eval (GetDims ds0 s0), si ~ Eval (GetDims ds1 s1),
 st ~ Eval (so0 ++ so1), ds0 ~ '[Eval (Eval (Rank s0) - 1)],
 ds1 ~ '[0]) =>
(Array si c -> d)
-> (a -> b -> c) -> Array s0 a -> Array s1 b -> Array st d
F.dot Array (Eval (Map (Flip GetDim '[3, 3]) '[1])) Double -> Double
forall a.
Num a =>
Array (Eval (Map (Flip GetDim '[3, 3]) '[1])) a -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum Double -> Double -> Double
forall a. Num a => a -> a -> a
(*) Array '[3, 3] Double
m2 (Double -> Double
forall a. (Floating a, Ord a) => a -> a
cubicroot (Double -> Double)
-> Array
     (Eval
        (Foldl'
           (Flip DeleteDim)
           '[3, 3]
           (Eval (Rev (Eval (PreDeletePositionsGo '[1] '[])) '[])))
      <> Eval
           (Foldl'
              (Flip DeleteDim)
              '[3]
              (Eval (Rev (Eval (PreDeletePositionsGo '[0] '[])) '[]))))
     Double
-> Array
     (Eval
        (Foldl'
           (Flip DeleteDim)
           '[3, 3]
           (Eval (Rev (Eval (PreDeletePositionsGo '[1] '[])) '[])))
      <> Eval
           (Foldl'
              (Flip DeleteDim)
              '[3]
              (Eval (Rev (Eval (PreDeletePositionsGo '[0] '[])) '[]))))
     Double
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Array (Eval (Map (Flip GetDim '[3, 3]) '[1])) Double -> Double)
-> (Double -> Double -> Double)
-> Array '[3, 3] Double
-> Array '[3] Double
-> Array
     (Eval
        (Foldl'
           (Flip DeleteDim)
           '[3, 3]
           (Eval (Rev (Eval (PreDeletePositionsGo '[1] '[])) '[])))
      <> Eval
           (Foldl'
              (Flip DeleteDim)
              '[3]
              (Eval (Rev (Eval (PreDeletePositionsGo '[0] '[])) '[]))))
     Double
forall a b c d (ds0 :: [Natural]) (ds1 :: [Natural])
       (s0 :: [Natural]) (s1 :: [Natural]) (so0 :: [Natural])
       (so1 :: [Natural]) (st :: [Natural]) (si :: [Natural]).
(KnownNats s0, KnownNats s1, KnownNats ds0, KnownNats ds1,
 KnownNats so0, KnownNats so1, KnownNats st, KnownNats si,
 so0 ~ Eval (DeleteDims ds0 s0), so1 ~ Eval (DeleteDims ds1 s1),
 si ~ Eval (GetDims ds0 s0), si ~ Eval (GetDims ds1 s1),
 st ~ Eval (so0 ++ so1), ds0 ~ '[Eval (Eval (Rank s0) - 1)],
 ds1 ~ '[0]) =>
(Array si c -> d)
-> (a -> b -> c) -> Array s0 a -> Array s1 b -> Array st d
F.dot Array (Eval (Map (Flip GetDim '[3, 3]) '[1])) Double -> Double
forall a.
Num a =>
Array (Eval (Map (Flip GetDim '[3, 3]) '[1])) a -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum Double -> Double -> Double
forall a. Num a => a -> a -> a
(*) Array '[3, 3] Double
m1 Array '[3] Double
xyz)

m1' :: F.Array '[3, 3] Double
m1' :: Array '[3, 3] Double
m1' =
  [Double] -> Array '[3, 3] Double
forall (s :: [Natural]) a t.
(KnownNats s, FromVector t a) =>
t -> Array s a
array
    [ Double
1.227013851103521026,
      -Double
0.5577999806518222383,
      Double
0.28125614896646780758,
      -Double
0.040580178423280593977,
      Double
1.1122568696168301049,
      -Double
0.071676678665601200577,
      -Double
0.076381284505706892869,
      -Double
0.42148197841801273055,
      Double
1.5861632204407947575
    ]

m2' :: F.Array '[3, 3] Double
m2' :: Array '[3, 3] Double
m2' =
  [Double] -> Array '[3, 3] Double
forall (s :: [Natural]) a t.
(KnownNats s, FromVector t a) =>
t -> Array s a
array
    [ Double
0.99999999845051981432,
      Double
0.39633779217376785678,
      Double
0.21580375806075880339,
      Double
1.0000000088817607767,
      -Double
0.1055613423236563494,
      -Double
0.063854174771705903402,
      Double
1.0000000546724109177,
      -Double
0.089484182094965759684,
      -Double
1.2914855378640917399
    ]

lab2xyz_ :: F.Array '[3] Double -> F.Array '[3] Double
lab2xyz_ :: Array '[3] Double -> Array '[3] Double
lab2xyz_ Array '[3] Double
lab =
  (Array (Eval (Map (Flip GetDim '[3, 3]) '[1])) Double -> Double)
-> (Double -> Double -> Double)
-> Array '[3, 3] Double
-> Array
     (Eval
        (Foldl'
           (Flip DeleteDim)
           '[3, 3]
           (Eval (Rev (Eval (PreDeletePositionsGo '[1] '[])) '[])))
      <> Eval
           (Foldl'
              (Flip DeleteDim)
              '[3]
              (Eval (Rev (Eval (PreDeletePositionsGo '[0] '[])) '[]))))
     Double
-> Array '[3] Double
forall a b c d (ds0 :: [Natural]) (ds1 :: [Natural])
       (s0 :: [Natural]) (s1 :: [Natural]) (so0 :: [Natural])
       (so1 :: [Natural]) (st :: [Natural]) (si :: [Natural]).
(KnownNats s0, KnownNats s1, KnownNats ds0, KnownNats ds1,
 KnownNats so0, KnownNats so1, KnownNats st, KnownNats si,
 so0 ~ Eval (DeleteDims ds0 s0), so1 ~ Eval (DeleteDims ds1 s1),
 si ~ Eval (GetDims ds0 s0), si ~ Eval (GetDims ds1 s1),
 st ~ Eval (so0 ++ so1), ds0 ~ '[Eval (Eval (Rank s0) - 1)],
 ds1 ~ '[0]) =>
(Array si c -> d)
-> (a -> b -> c) -> Array s0 a -> Array s1 b -> Array st d
F.dot Array (Eval (Map (Flip GetDim '[3, 3]) '[1])) Double -> Double
forall a.
Num a =>
Array (Eval (Map (Flip GetDim '[3, 3]) '[1])) a -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum Double -> Double -> Double
forall a. Num a => a -> a -> a
(*) Array '[3, 3] Double
m1' ((Double -> Double -> Double
forall a. Floating a => a -> a -> a
** Double
3.0) (Double -> Double)
-> Array
     (Eval
        (Foldl'
           (Flip DeleteDim)
           '[3, 3]
           (Eval (Rev (Eval (PreDeletePositionsGo '[1] '[])) '[])))
      <> Eval
           (Foldl'
              (Flip DeleteDim)
              '[3]
              (Eval (Rev (Eval (PreDeletePositionsGo '[0] '[])) '[]))))
     Double
-> Array
     (Eval
        (Foldl'
           (Flip DeleteDim)
           '[3, 3]
           (Eval (Rev (Eval (PreDeletePositionsGo '[1] '[])) '[])))
      <> Eval
           (Foldl'
              (Flip DeleteDim)
              '[3]
              (Eval (Rev (Eval (PreDeletePositionsGo '[0] '[])) '[]))))
     Double
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Array (Eval (Map (Flip GetDim '[3, 3]) '[1])) Double -> Double)
-> (Double -> Double -> Double)
-> Array '[3, 3] Double
-> Array '[3] Double
-> Array
     (Eval
        (Foldl'
           (Flip DeleteDim)
           '[3, 3]
           (Eval (Rev (Eval (PreDeletePositionsGo '[1] '[])) '[])))
      <> Eval
           (Foldl'
              (Flip DeleteDim)
              '[3]
              (Eval (Rev (Eval (PreDeletePositionsGo '[0] '[])) '[]))))
     Double
forall a b c d (ds0 :: [Natural]) (ds1 :: [Natural])
       (s0 :: [Natural]) (s1 :: [Natural]) (so0 :: [Natural])
       (so1 :: [Natural]) (st :: [Natural]) (si :: [Natural]).
(KnownNats s0, KnownNats s1, KnownNats ds0, KnownNats ds1,
 KnownNats so0, KnownNats so1, KnownNats st, KnownNats si,
 so0 ~ Eval (DeleteDims ds0 s0), so1 ~ Eval (DeleteDims ds1 s1),
 si ~ Eval (GetDims ds0 s0), si ~ Eval (GetDims ds1 s1),
 st ~ Eval (so0 ++ so1), ds0 ~ '[Eval (Eval (Rank s0) - 1)],
 ds1 ~ '[0]) =>
(Array si c -> d)
-> (a -> b -> c) -> Array s0 a -> Array s1 b -> Array st d
F.dot Array (Eval (Map (Flip GetDim '[3, 3]) '[1])) Double -> Double
forall a.
Num a =>
Array (Eval (Map (Flip GetDim '[3, 3]) '[1])) a -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum Double -> Double -> Double
forall a. Num a => a -> a -> a
(*) Array '[3, 3] Double
m2' Array '[3] Double
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 :: Double -> Colour -> Colour -> Colour
mix Double
x Colour
c0 Colour
c1 = Optic' An_Iso '[] LCHA Colour -> LCHA -> Colour
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' An_Iso '[] LCHA Colour
lcha2colour' (Double -> LCHA -> LCHA -> LCHA
mixLCHA Double
x (Optic' An_Iso '[] LCHA Colour -> Colour -> LCHA
forall k (is :: IxList) t b.
Is k A_Review =>
Optic' k is t b -> b -> t
review Optic' An_Iso '[] LCHA Colour
lcha2colour' Colour
c0) (Optic' An_Iso '[] LCHA Colour -> Colour -> LCHA
forall k (is :: IxList) t b.
Is k A_Review =>
Optic' k is t b -> b -> t
review Optic' An_Iso '[] LCHA Colour
lcha2colour' Colour
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 :: Double -> Colour -> Colour -> Colour
mixTrim Double
x Colour
c0 Colour
c1 = Colour -> Colour
trimColour (Double -> Colour -> Colour -> Colour
mix Double
x Colour
c0 Colour
c1)

-- | Mix two LCHA specified colours.
mixLCHA :: Double -> LCHA -> LCHA -> LCHA
mixLCHA :: Double -> LCHA -> LCHA -> LCHA
mixLCHA Double
x (LCHA Double
l Double
c Double
h Double
a) (LCHA Double
l' Double
c' Double
h' Double
a') = Double -> Double -> Double -> Double -> LCHA
LCHA Double
l'' Double
c'' Double
h'' Double
a''
  where
    l'' :: Double
l'' = Double
l Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
x Double -> Double -> Double
forall a. Num a => a -> a -> a
* (Double
l' Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
l)
    c'' :: Double
c'' = Double
c Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
x Double -> Double -> Double
forall a. Num a => a -> a -> a
* (Double
c' Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
c)
    h'' :: Double
h'' = Double
h Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
x Double -> Double -> Double
forall a. Num a => a -> a -> a
* (Double
h' Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
h)
    a'' :: Double
a'' = Double
a Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
x Double -> Double -> Double
forall a. Num a => a -> a -> a
* (Double
a' Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
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 :: Double -> [Colour] -> Colour
mixes Double
_ [] = Colour
light
mixes Double
_ [Colour
c] = Colour
c
mixes Double
x [Colour]
cs = Double -> Colour -> Colour -> Colour
mix Double
r ([Colour]
cs [Colour] -> Int -> Colour
forall a. HasCallStack => [a] -> Int -> a
List.!! Int
i') ([Colour]
cs [Colour] -> Int -> Colour
forall a. HasCallStack => [a] -> Int -> a
List.!! (Int
i' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1))
  where
    l :: Int
l = [Colour] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Colour]
cs Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
    x' :: Double
x' = Double
x Double -> Double -> Double
forall a. Num a => a -> a -> a
* Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
l
    i' :: Int
i' = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor Double
x') (Int
l Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1))
    r :: Double
r = Double
x' Double -> Double -> Double
forall a. Num a => a -> a -> a
- Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
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 :: Colour -> Colour
greyed = Lens' Colour Double -> (Double -> Double) -> Colour -> Colour
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> (a -> b) -> s -> t
over Lens' Colour Double
chroma' (Double -> Double -> Double
forall a b. a -> b -> a
const Double
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' :: Lens' Colour Double
lightness' = Optic' An_Iso '[] LCHA Colour
-> Optic (ReversedOptic An_Iso) '[] Colour Colour LCHA LCHA
forall (is :: IxList) s t a b.
AcceptsEmptyIndices "re" is =>
Optic An_Iso is s t a b -> Optic (ReversedOptic An_Iso) is b a t s
forall k (is :: IxList) s t a b.
(ReversibleOptic k, AcceptsEmptyIndices "re" is) =>
Optic k is s t a b -> Optic (ReversedOptic k) is b a t s
re Optic' An_Iso '[] LCHA Colour
lcha2colour' Optic An_Iso '[] Colour Colour LCHA LCHA
-> Lens' LCHA (LCH Double) -> Optic' A_Lens '[] Colour (LCH Double)
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Lens' LCHA (LCH Double)
lch' Optic' A_Lens '[] Colour (LCH Double)
-> Lens' (LCH Double) Double -> Lens' Colour Double
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Lens' (LCH Double) Double
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' :: Lens' Colour Double
chroma' = Optic' An_Iso '[] LCHA Colour
-> Optic (ReversedOptic An_Iso) '[] Colour Colour LCHA LCHA
forall (is :: IxList) s t a b.
AcceptsEmptyIndices "re" is =>
Optic An_Iso is s t a b -> Optic (ReversedOptic An_Iso) is b a t s
forall k (is :: IxList) s t a b.
(ReversibleOptic k, AcceptsEmptyIndices "re" is) =>
Optic k is s t a b -> Optic (ReversedOptic k) is b a t s
re Optic' An_Iso '[] LCHA Colour
lcha2colour' Optic An_Iso '[] Colour Colour LCHA LCHA
-> Lens' LCHA (LCH Double) -> Optic' A_Lens '[] Colour (LCH Double)
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Lens' LCHA (LCH Double)
lch' Optic' A_Lens '[] Colour (LCH Double)
-> Lens' (LCH Double) Double -> Lens' Colour Double
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Lens' (LCH Double) Double
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' :: Lens' Colour Double
hue' = Optic' An_Iso '[] LCHA Colour
-> Optic (ReversedOptic An_Iso) '[] Colour Colour LCHA LCHA
forall (is :: IxList) s t a b.
AcceptsEmptyIndices "re" is =>
Optic An_Iso is s t a b -> Optic (ReversedOptic An_Iso) is b a t s
forall k (is :: IxList) s t a b.
(ReversibleOptic k, AcceptsEmptyIndices "re" is) =>
Optic k is s t a b -> Optic (ReversedOptic k) is b a t s
re Optic' An_Iso '[] LCHA Colour
lcha2colour' Optic An_Iso '[] Colour Colour LCHA LCHA
-> Lens' LCHA (LCH Double) -> Optic' A_Lens '[] Colour (LCH Double)
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Lens' LCHA (LCH Double)
lch' Optic' A_Lens '[] Colour (LCH Double)
-> Lens' (LCH Double) Double -> Lens' Colour Double
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Lens' (LCH Double) Double
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 :: Text -> Colour -> Text
showSwatch Text
label Colour
c =
  [i|<div class=swatch style="background:#{rgba};">#{label}</div>|]
  where
    rgba :: ByteString
rgba = Colour -> ByteString
showRGBA Colour
c

-- | Show multiple colors with embedded text.
showSwatches :: Text -> Text -> [(Text, Colour)] -> Text
showSwatches :: Text -> Text -> [(Text, Colour)] -> Text
showSwatches Text
pref Text
suff [(Text, Colour)]
hs =
  [i|<div>
 #{pref}
 #{divs}
 #{suff}
</div>
|]
  where
    divs :: Text
divs = Text -> [Text] -> Text
Text.intercalate Text
"\n" ((Text -> Colour -> Text) -> (Text, Colour) -> Text
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Text -> Colour -> Text
showSwatch ((Text, Colour) -> Text) -> [(Text, Colour)] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Text, Colour)]
hs)

-- * random colors

instance Uniform (RGB3 Double) where
  uniformM :: forall g (m :: * -> *). StatefulGen g m => g -> m (RGB3 Double)
uniformM g
gen = do
    Double
r <- (Double, Double) -> g -> m Double
forall a g (m :: * -> *).
(UniformRange a, StatefulGen g m) =>
(a, a) -> g -> m a
forall g (m :: * -> *).
StatefulGen g m =>
(Double, Double) -> g -> m Double
uniformRM (Double
0, Double
1) g
gen
    Double
g <- (Double, Double) -> g -> m Double
forall a g (m :: * -> *).
(UniformRange a, StatefulGen g m) =>
(a, a) -> g -> m a
forall g (m :: * -> *).
StatefulGen g m =>
(Double, Double) -> g -> m Double
uniformRM (Double
0, Double
1) g
gen
    Double
b <- (Double, Double) -> g -> m Double
forall a g (m :: * -> *).
(UniformRange a, StatefulGen g m) =>
(a, a) -> g -> m a
forall g (m :: * -> *).
StatefulGen g m =>
(Double, Double) -> g -> m Double
uniformRM (Double
0, Double
1) g
gen
    RGB3 Double -> m (RGB3 Double)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Double -> Double -> Double -> RGB3 Double
forall a. a -> a -> a -> RGB3 a
RGB3 Double
r Double
g Double
b)

instance Uniform Colour where
  uniformM :: forall g (m :: * -> *). StatefulGen g m => g -> m Colour
uniformM g
gen = do
    Double
r <- (Double, Double) -> g -> m Double
forall a g (m :: * -> *).
(UniformRange a, StatefulGen g m) =>
(a, a) -> g -> m a
forall g (m :: * -> *).
StatefulGen g m =>
(Double, Double) -> g -> m Double
uniformRM (Double
0, Double
1) g
gen
    Double
g <- (Double, Double) -> g -> m Double
forall a g (m :: * -> *).
(UniformRange a, StatefulGen g m) =>
(a, a) -> g -> m a
forall g (m :: * -> *).
StatefulGen g m =>
(Double, Double) -> g -> m Double
uniformRM (Double
0, Double
1) g
gen
    Double
b <- (Double, Double) -> g -> m Double
forall a g (m :: * -> *).
(UniformRange a, StatefulGen g m) =>
(a, a) -> g -> m a
forall g (m :: * -> *).
StatefulGen g m =>
(Double, Double) -> g -> m Double
uniformRM (Double
0, Double
1) g
gen
    Double
a <- (Double, Double) -> g -> m Double
forall a g (m :: * -> *).
(UniformRange a, StatefulGen g m) =>
(a, a) -> g -> m a
forall g (m :: * -> *).
StatefulGen g m =>
(Double, Double) -> g -> m Double
uniformRM (Double
0, Double
1) g
gen
    Colour -> m Colour
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Double -> Double -> Double -> Double -> Colour
Colour Double
r Double
g Double
b Double
a)

-- | Random variates of a uniform
rvs :: (Uniform a) => [a]
rvs :: forall a. Uniform a => [a]
rvs = StdGen -> [a]
forall {t} {a}. (RandomGen t, Uniform a) => t -> [a]
go StdGen
g0
  where
    g0 :: StdGen
g0 = Int -> StdGen
mkStdGen Int
42
    go :: t -> [a]
go t
g = let (a
x, t
g') = t -> (a, t)
forall g a. (RandomGen g, Uniform a) => g -> (a, g)
uniform t
g in a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: t -> [a]
go t
g'

-- | Random list of RGB3s
rvRGB3 :: [RGB3 Double]
rvRGB3 :: [RGB3 Double]
rvRGB3 = [RGB3 Double]
forall a. Uniform a => [a]
rvs

-- | Random list of Colours
rvColour :: [Colour]
rvColour :: [Colour]
rvColour = [Colour]
forall a. Uniform a => [a]
rvs

-- | Random Colours with an opacity of 1 that are not too extreme in terms of lightness or chromacity.
paletteR :: [Colour]
paletteR :: [Colour]
paletteR = StdGen -> [Colour]
forall {t}. RandomGen t => t -> [Colour]
go StdGen
g0
  where
    g0 :: StdGen
g0 = Int -> StdGen
mkStdGen Int
42
    go :: t -> [Colour]
go t
g = let (Colour
x, t
g') = t -> (StateGenM t -> State t Colour) -> (Colour, t)
forall g a.
RandomGen g =>
g -> (StateGenM g -> State g a) -> (a, g)
runStateGen t
g StateGenM t -> State t Colour
forall g (m :: * -> *). StatefulGen g m => g -> m Colour
rvSensible in Colour
x Colour -> [Colour] -> [Colour]
forall a. a -> [a] -> [a]
: t -> [Colour]
go t
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 :: forall g (m :: * -> *). StatefulGen g m => g -> m Colour
rvSensible g
gen = do
  Double
l <- (Double, Double) -> g -> m Double
forall a g (m :: * -> *).
(UniformRange a, StatefulGen g m) =>
(a, a) -> g -> m a
forall g (m :: * -> *).
StatefulGen g m =>
(Double, Double) -> g -> m Double
uniformRM (Double
0.3, Double
0.75) g
gen
  Double
c <- (Double, Double) -> g -> m Double
forall a g (m :: * -> *).
(UniformRange a, StatefulGen g m) =>
(a, a) -> g -> m a
forall g (m :: * -> *).
StatefulGen g m =>
(Double, Double) -> g -> m Double
uniformRM (Double
0.05, Double
0.24) g
gen
  Double
h <- (Double, Double) -> g -> m Double
forall a g (m :: * -> *).
(UniformRange a, StatefulGen g m) =>
(a, a) -> g -> m a
forall g (m :: * -> *).
StatefulGen g m =>
(Double, Double) -> g -> m Double
uniformRM (Double
0, Double
360) g
gen
  Colour -> m Colour
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Colour -> Colour
trimColour (Colour -> Colour) -> (LCHA -> Colour) -> LCHA -> Colour
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Optic' An_Iso '[] LCHA Colour -> LCHA -> Colour
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' An_Iso '[] LCHA Colour
lcha2colour') (Double -> Double -> Double -> Double -> LCHA
LCHA Double
l Double
c Double
h Double
1))