{-# 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'
  { Colour -> Color (Alpha RGB) Double
color' :: Color (Alpha RGB) Double
  }
  deriving (Colour -> Colour -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Colour -> Colour -> Bool
$c/= :: Colour -> Colour -> Bool
== :: Colour -> Colour -> Bool
$c== :: Colour -> Colour -> Bool
Eq, 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
$cto :: forall x. Rep Colour x -> Colour
$cfrom :: forall x. Colour -> Rep Colour x
Generic)

-- | Constructor pattern.
--
-- > Colour red green blue alpha
--
pattern Colour :: Double -> Double -> Double -> Double -> Colour
pattern $bColour :: Double -> Double -> Double -> Double -> Colour
$mColour :: forall {r}.
Colour
-> (Double -> Double -> Double -> Double -> r) -> ((# #) -> r) -> r
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 forall a b. (a -> b) -> a -> b
$
      Text
"Colour "
        forall a. Semigroup a => a -> a -> a
<> Maybe Int -> Double -> Text
fixed (forall a. a -> Maybe a
Just Int
2) Double
r
        forall a. Semigroup a => a -> a -> a
<> Text
" "
        forall a. Semigroup a => a -> a -> a
<> Maybe Int -> Double -> Text
fixed (forall a. a -> Maybe a
Just Int
2) Double
g
        forall a. Semigroup a => a -> a -> a
<> Text
" "
        forall a. Semigroup a => a -> a -> a
<> Maybe Int -> Double -> Text
fixed (forall a. a -> Maybe a
Just Int
2) Double
b
        forall a. Semigroup a => a -> a -> a
<> Text
" "
        forall a. Semigroup a => a -> a -> a
<> Maybe Int -> Double -> Text
fixed (forall a. a -> Maybe a
Just Int
2) Double
a

-- | CSS-style representation
showRGBA :: Colour -> Text
showRGBA :: Colour -> Text
showRGBA (Colour Double
r' Double
g' Double
b' Double
a') =
  [trimming|rgba($r, $g, $b, $a)|]
  where
    r :: Text
r = (SigFig -> Text) -> Maybe Int -> Double -> Text
percent (Maybe Int -> SigFig -> Text
fixedSF (forall a. a -> Maybe a
Just Int
0)) (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 (forall a. a -> Maybe a
Just Int
0)) (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 (forall a. a -> Maybe a
Just Int
0)) (forall a. a -> Maybe a
Just Int
2) Double
b'
    a :: Text
a = Maybe Int -> Double -> Text
fixed (forall a. a -> Maybe a
Just Int
2) Double
a'

-- | CSS-style representation
showRGB :: Colour -> Text
showRGB :: Colour -> Text
showRGB (Colour Double
r' Double
g' Double
b' Double
_) =
  [trimming|rgb($r, $g, $b)|]
  where
    r :: Text
r = (SigFig -> Text) -> Maybe Int -> Double -> Text
percent (Maybe Int -> SigFig -> Text
fixedSF (forall a. a -> Maybe a
Just Int
0)) (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 (forall a. a -> Maybe a
Just Int
0)) (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 (forall a. a -> Maybe a
Just Int
0)) (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 forall a. Ord a => a -> a -> Bool
>= Double
0 Bool -> Bool -> Bool
&& Double
r forall a. Ord a => a -> a -> Bool
<= Double
1 Bool -> Bool -> Bool
&& Double
g forall a. Ord a => a -> a -> Bool
>= Double
0 Bool -> Bool -> Bool
&& Double
g forall a. Ord a => a -> a -> Bool
<= Double
1 Bool -> Bool -> Bool
&& Double
b forall a. Ord a => a -> a -> Bool
>= Double
0 Bool -> Bool -> Bool
&& Double
b forall a. Ord a => a -> a -> Bool
<= Double
1 Bool -> Bool -> Bool
&& Double
o forall a. Ord a => a -> a -> Bool
>= Double
0 Bool -> Bool -> Bool
&& Double
o 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 (forall {a}. (Ord a, Num a) => a -> a
trim Double
r) (forall {a}. (Ord a, Num a) => a -> a
trim Double
g) (forall {a}. (Ord a, Num a) => a -> a
trim Double
b) (forall {a}. (Ord a, Num a) => a -> a
trim Double
a)
  where
    trim :: a -> a
trim a
x = forall a. Ord a => a -> a -> a
max a
0 forall a b. (a -> b) -> a -> b
$ 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 = forall a. a -> a -> Bool -> a
bool forall a. Maybe a
Nothing (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

-- | lens for opacity (or alpha channel)
opac' :: Lens' Colour Double
opac' :: Lens' Colour Double
opac' = 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)

-- | Convert to CSS hex representation.
hex :: Colour -> Text
hex :: Colour -> Text
hex Colour
c = Colour -> Text
toHex Colour
c

-- | 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

-- | Parse CSS hex text.
parseHex :: A.Parser (Color RGB Double)
parseHex :: Parser (Color RGB Double)
parseHex =
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall e. Elevator e => e -> Double
toDouble
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. ( \((Int
r, Int
g), Int
b) ->
          forall e. e -> e -> e -> Color RGB e
ColorRGB (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
r) (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
g) (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
b) :: Color RGB Word8
      )
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\(Int
f, Int
b) -> (Int
f forall a. Integral a => a -> a -> (a, a)
`divMod` (Int
256 :: Int), Int
b))
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Integral a => a -> a -> (a, a)
`divMod` Int
256)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Text -> Parser Text
A.string Text
"#" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall a. (Integral a, Bits a) => Parser a
A.hexadecimal)

-- | Convert CSS hex to Colour
fromHex :: Text -> Either Text (Color RGB Double)
fromHex :: Text -> Either Text (Color RGB Double)
fromHex = forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first String -> Text
pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Parser a -> Text -> Either String a
A.parseOnly Parser (Color RGB Double)
parseHex

-- | Convert CSS hex to Colour, unsafely.
unsafeFromHex :: Text -> Color RGB Double
unsafeFromHex :: Text -> Color RGB Double
unsafeFromHex Text
t = forall b a. b -> Either a b -> b
fromRight (forall e. e -> e -> e -> Color RGB e
ColorRGB Double
0 Double
0 Double
0) forall a b. (a -> b) -> a -> b
$ forall a. Parser a -> Text -> Either String a
A.parseOnly Parser (Color RGB Double)
parseHex Text
t

-- | Convert from 'Colour' to CSS hex (#xxxxxx)
toHex :: Colour -> Text
toHex :: Colour -> Text
toHex Colour
c =
  Text
"#"
    forall a. Semigroup a => a -> a -> a
<> Int -> Char -> Text -> Text
Text.justifyRight Int
2 Char
'0' (Int -> Text
hex' Int
r)
    forall a. Semigroup a => a -> a -> a
<> Int -> Char -> Text -> Text
Text.justifyRight Int
2 Char
'0' (Int -> Text
hex' Int
g)
    forall a. Semigroup a => a -> a -> a
<> Int -> Char -> Text -> Text
Text.justifyRight Int
2 Char
'0' (Int -> Text
hex' Int
b)
  where
    (ColorRGBA Int
r Int
g Int
b Int
_) = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. Elevator e => e -> Word8
toWord8 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Colour -> Color (Alpha RGB) Double
color' Colour
c

-- |
hex' :: Int -> Text
hex' :: Int -> Text
hex' Int
i
  | Int
i forall a. Ord a => a -> a -> Bool
< Int
0 = Text
"-" forall a. Semigroup a => a -> a -> a
<> Int -> Text
go (-Int
i)
  | Bool
otherwise = Int -> Text
go Int
i
  where
    go :: Int -> Text
go Int
n
      | Int
n forall a. Ord a => a -> a -> Bool
< Int
16 = Int -> Text
hexDigit Int
n
      | Bool
otherwise = Int -> Text
go (Int
n forall a. Integral a => a -> a -> a
`quot` Int
16) forall a. Semigroup a => a -> a -> a
<> Int -> Text
hexDigit (Int
n forall a. Integral a => a -> a -> a
`rem` Int
16)

-- |
hexDigit :: Int -> Text
hexDigit :: Int -> Text
hexDigit Int
n
  | Int
n forall a. Ord a => a -> a -> Bool
<= Int
9 = Char -> Text
Text.singleton forall a b. (a -> b) -> a -> b
$! Int -> Char
i2d Int
n
  | Bool
otherwise = Char -> Text
Text.singleton forall a b. (a -> b) -> a -> b
$! forall a. Enum a => Int -> a
toEnum (Int
n forall a. Num a => a -> a -> a
+ Int
87)

-- |
i2d :: Int -> Char
i2d :: Int -> Char
i2d Int
i = Int -> Char
chr (Char -> Int
ord Char
'0' forall a. Num a => a -> a -> a
+ Int
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 :: Int -> Colour
palette1 Int
x = forall a. [a] -> [a]
cycle [Colour]
palette1_ forall a. [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:
--
-- ![palette1](other/palette1.svg)
palette1_ :: [Colour]
palette1_ :: [Colour]
palette1_ = Colour -> Colour
trimColour forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Iso' LCHA Colour
lcha2colour' forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [LCHA]
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 :: Int -> Double -> Colour
palette1a Int
x Double
a = 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 forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
cycle [Colour]
palette1_ forall a. [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

-- | 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
newtype LCH a = LCH' {forall a. LCH a -> Array '[3] a
lchArray :: Array '[3] a} deriving (LCH a -> LCH a -> Bool
forall a. Eq a => LCH a -> LCH a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LCH a -> LCH a -> Bool
$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
Eq, Int -> LCH a -> ShowS
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
showList :: [LCH a] -> ShowS
$cshowList :: forall a. Show a => [LCH a] -> ShowS
show :: LCH a -> String
$cshow :: forall a. Show a => LCH a -> String
showsPrec :: Int -> LCH a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> LCH a -> ShowS
Show, Int -> [Item (LCH a)] -> LCH a
[Item (LCH a)] -> LCH a
LCH a -> [Item (LCH a)]
forall a. Int -> [Item (LCH a)] -> LCH a
forall a. [Item (LCH a)] -> LCH a
forall a. LCH a -> [Item (LCH a)]
forall l.
([Item l] -> l)
-> (Int -> [Item l] -> l) -> (l -> [Item l]) -> IsList l
toList :: LCH a -> [Item (LCH a)]
$ctoList :: forall a. LCH a -> [Item (LCH a)]
fromListN :: Int -> [Item (LCH a)] -> LCH a
$cfromListN :: forall a. Int -> [Item (LCH a)] -> LCH a
fromList :: [Item (LCH a)] -> LCH a
$cfromList :: forall a. [Item (LCH a)] -> LCH a
IsList, 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
<$ :: forall a b. a -> LCH b -> LCH a
$c<$ :: forall a b. a -> LCH b -> LCH a
fmap :: forall a b. (a -> b) -> LCH a -> LCH b
$cfmap :: forall a b. (a -> b) -> LCH a -> LCH b
Functor)

-- | LCH colour pattern
pattern LCH :: a -> a -> a -> LCH a
pattern $bLCH :: forall a. a -> a -> a -> LCH a
$mLCH :: forall {r} {a}. LCH a -> (a -> a -> a -> r) -> ((# #) -> r) -> r
LCH l c h <-
  LCH' [l, c, h]
  where
    LCH a
l a
c a
h = forall a. Array '[3] a -> LCH a
LCH' [a
l, a
c, a
h]

{-# COMPLETE LCH #-}

-- | Lightness lens for LCH
lLCH' :: Lens' (LCH Double) Double
lLCH' :: Lens' (LCH Double) Double
lLCH' = 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 -> 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' = 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 -> 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' = 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 -> 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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LCHA -> LCHA -> Bool
$c/= :: LCHA -> LCHA -> Bool
== :: LCHA -> LCHA -> Bool
$c== :: LCHA -> LCHA -> Bool
Eq, Int -> LCHA -> ShowS
[LCHA] -> ShowS
LCHA -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LCHA] -> ShowS
$cshowList :: [LCHA] -> ShowS
show :: LCHA -> String
$cshow :: LCHA -> String
showsPrec :: Int -> LCHA -> ShowS
$cshowsPrec :: Int -> LCHA -> ShowS
Show)

-- | LCH lens for LCHA
lch' :: Lens' LCHA (LCH Double)
lch' :: Lens' LCHA (LCH Double)
lch' = 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' = 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 $bLCHA :: Double -> Double -> Double -> Double -> LCHA
$mLCHA :: forall {r}.
LCHA
-> (Double -> Double -> Double -> Double -> r) -> ((# #) -> r) -> r
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' (forall a. Array '[3] 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'
newtype RGB3 a = RGB3' {forall a. RGB3 a -> Array '[3] a
rgb3Array :: Array '[3] a} deriving (RGB3 a -> RGB3 a -> Bool
forall a. Eq a => RGB3 a -> RGB3 a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RGB3 a -> RGB3 a -> Bool
$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
Eq, Int -> RGB3 a -> ShowS
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
showList :: [RGB3 a] -> ShowS
$cshowList :: forall a. Show a => [RGB3 a] -> ShowS
show :: RGB3 a -> String
$cshow :: forall a. Show a => RGB3 a -> String
showsPrec :: Int -> RGB3 a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> RGB3 a -> ShowS
Show, Int -> [Item (RGB3 a)] -> RGB3 a
[Item (RGB3 a)] -> RGB3 a
RGB3 a -> [Item (RGB3 a)]
forall a. Int -> [Item (RGB3 a)] -> RGB3 a
forall a. [Item (RGB3 a)] -> RGB3 a
forall a. RGB3 a -> [Item (RGB3 a)]
forall l.
([Item l] -> l)
-> (Int -> [Item l] -> l) -> (l -> [Item l]) -> IsList l
toList :: RGB3 a -> [Item (RGB3 a)]
$ctoList :: forall a. RGB3 a -> [Item (RGB3 a)]
fromListN :: Int -> [Item (RGB3 a)] -> RGB3 a
$cfromListN :: forall a. Int -> [Item (RGB3 a)] -> RGB3 a
fromList :: [Item (RGB3 a)] -> RGB3 a
$cfromList :: forall a. [Item (RGB3 a)] -> RGB3 a
IsList, 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
<$ :: forall a b. a -> RGB3 b -> RGB3 a
$c<$ :: forall a b. a -> RGB3 b -> RGB3 a
fmap :: forall a b. (a -> b) -> RGB3 a -> RGB3 b
$cfmap :: forall a b. (a -> b) -> RGB3 a -> RGB3 b
Functor)

-- | The RGB3 pattern
pattern RGB3 :: a -> a -> a -> RGB3 a
pattern $bRGB3 :: forall a. a -> a -> a -> RGB3 a
$mRGB3 :: forall {r} {a}. RGB3 a -> (a -> a -> a -> r) -> ((# #) -> r) -> r
RGB3 r g b <-
  RGB3' [r, g, b]
  where
    RGB3 a
r a
g a
b = forall a. Array '[3] a -> RGB3 a
RGB3' [a
r, a
g, a
b]

{-# COMPLETE RGB3 #-}

-- | Lens for conversion between Double and Word8 RGB triples.
rgbd' :: Iso' (RGB3 Double) (RGB3 Word8)
rgbd' :: Iso' (RGB3 Double) (RGB3 Word8)
rgbd' = forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. (RealFrac a, Integral b) => a -> b
floor forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Num a => a -> a -> a
* Double
256))) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Word8
x -> forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
x 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' = 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) -> (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
newtype LAB a = LAB' {forall a. LAB a -> Array '[3] a
labArray :: Array '[3] a} deriving (LAB a -> LAB a -> Bool
forall a. Eq a => LAB a -> LAB a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LAB a -> LAB a -> Bool
$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
Eq, Int -> LAB a -> ShowS
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
showList :: [LAB a] -> ShowS
$cshowList :: forall a. Show a => [LAB a] -> ShowS
show :: LAB a -> String
$cshow :: forall a. Show a => LAB a -> String
showsPrec :: Int -> LAB a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> LAB a -> ShowS
Show, Int -> [Item (LAB a)] -> LAB a
[Item (LAB a)] -> LAB a
LAB a -> [Item (LAB a)]
forall a. Int -> [Item (LAB a)] -> LAB a
forall a. [Item (LAB a)] -> LAB a
forall a. LAB a -> [Item (LAB a)]
forall l.
([Item l] -> l)
-> (Int -> [Item l] -> l) -> (l -> [Item l]) -> IsList l
toList :: LAB a -> [Item (LAB a)]
$ctoList :: forall a. LAB a -> [Item (LAB a)]
fromListN :: Int -> [Item (LAB a)] -> LAB a
$cfromListN :: forall a. Int -> [Item (LAB a)] -> LAB a
fromList :: [Item (LAB a)] -> LAB a
$cfromList :: forall a. [Item (LAB a)] -> LAB a
IsList, 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
<$ :: forall a b. a -> LAB b -> LAB a
$c<$ :: forall a b. a -> LAB b -> LAB a
fmap :: forall a b. (a -> b) -> LAB a -> LAB b
$cfmap :: forall a b. (a -> b) -> LAB a -> LAB b
Functor)

-- | LAB pattern
pattern LAB :: a -> a -> a -> LAB a
pattern $bLAB :: forall a. a -> a -> a -> LAB a
$mLAB :: forall {r} {a}. LAB a -> (a -> a -> a -> r) -> ((# #) -> r) -> r
LAB l a b <-
  LAB' [l, a, b]
  where
    LAB a
l a
a a
b = forall a. Array '[3] a -> LAB a
LAB' [a
l, a
a, 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 Colour
lcha2colour' =
  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) = forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view (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' (LAB Double) (LCH Double)
lab2lch' 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
% 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) (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' (forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view (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' 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
% forall s t a b. Field1 s t a b => Lens s t a b
_1 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
% Iso' (RGB3 Double) (LAB Double)
rgb2lab' 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
% Iso' (LAB Double) (LCH Double)
lab2lch') Colour
c) Double
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' (Double, Double) (Double, Double)
xy2ch' =
  forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso
    (\(Double
x, Double
y) -> (forall a b. Norm a b => a -> b
norm (forall a. a -> a -> Point a
Point Double
x Double
y), Double
180 forall a. Fractional a => a -> a -> a
/ forall a. Floating a => a
pi forall a. Num a => a -> a -> a
* Double -> Double -> Double
mod_ (forall coord dir. Direction coord dir => coord -> dir
angle (forall a. a -> a -> Point a
Point Double
x Double
y)) (Double
2 forall a. Num a => a -> a -> a
* forall a. Floating a => a
pi)))
    (\(Double
c, Double
h) -> let (Point Double
x Double
y) = forall coord mag dir.
(MultiplicativeAction coord mag, Direction coord dir) =>
Polar mag dir -> coord
coord (forall mag dir. mag -> dir -> Polar mag dir
Polar Double
c (forall a. Floating a => a
pi forall a. Fractional a => a -> a -> a
/ Double
180 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 forall a. Num a => a -> a -> a
- forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a b. (RealFrac a, Integral b) => a -> b
floor (Double
x forall a. Fractional a => a -> a -> a
/ Double
d) :: Integer) forall a. Num a => a -> a -> a
* Double
d

-- | Lens between LAB and LCH
lab2lch' :: Iso' (LAB Double) (LCH Double)
lab2lch' :: Iso' (LAB Double) (LCH Double)
lab2lch' =
  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) = 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 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) = forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view (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 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' :: Iso' (RGB3 Double) (LAB Double)
rgb2lab' =
  forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso
    (\(RGB3' Array '[3] Double
a) -> forall a. Array '[3] a -> LAB a
LAB' forall b c a. (b -> c) -> (a -> b) -> a -> c
. Array '[3] Double -> Array '[3] Double
xyz2lab_ forall b c a. (b -> c) -> (a -> b) -> a -> c
. Array '[3] Double -> Array '[3] Double
rgb2xyz_ forall a b. (a -> b) -> a -> b
$ Array '[3] Double
a)
    (\(LAB' Array '[3] Double
a) -> forall a. Array '[3] a -> RGB3 a
RGB3' forall b c a. (b -> c) -> (a -> b) -> a -> c
. Array '[3] Double -> Array '[3] Double
xyz2rgb_ forall b c a. (b -> c) -> (a -> b) -> a -> c
. Array '[3] Double -> Array '[3] Double
lab2xyz_ forall a b. (a -> b) -> a -> b
$ Array '[3] Double
a)

-- * rgb to xyz

xyz2rgb_ :: Array '[3] Double -> Array '[3] Double
xyz2rgb_ :: Array '[3] Double -> Array '[3] Double
xyz2rgb_ Array '[3] Double
a = forall l. IsList l => [Item l] -> l
fromList [Double
r, Double
g, Double
b]
  where
    (S.ColorSRGB Double
r Double
g Double
b) = 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 (forall {k} e (i :: k). e -> e -> e -> Color (XYZ i) e
S.ColorXYZ (Array '[3] Double
a forall (f :: * -> *) a. Representable f => f a -> Rep f -> a
`index` [Int
0]) (Array '[3] Double
a forall (f :: * -> *) a. Representable f => f a -> Rep f -> a
`index` [Int
1]) (Array '[3] Double
a forall (f :: * -> *) a. Representable f => f a -> Rep f -> a
`index` [Int
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_ :: Array '[3] Double -> Array '[3] Double
rgb2xyz_ Array '[3] Double
a = forall l. IsList l => [Item l] -> l
fromList [Double
x, Double
y, Double
z]
  where
    (S.ColorXYZ Double
x Double
y Double
z) = 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 (forall e (l :: Linearity). e -> e -> e -> Color (SRGB l) e
S.ColorSRGB (Array '[3] Double
a forall (f :: * -> *) a. Representable f => f a -> Rep f -> a
`index` [Int
0]) (Array '[3] Double
a forall (f :: * -> *) a. Representable f => f a -> Rep f -> a
`index` [Int
1]) (Array '[3] Double
a forall (f :: * -> *) a. Representable f => f a -> Rep f -> a
`index` [Int
2])) :: Color (S.XYZ S.D65) Double

-- * xyz to lab

m1 :: Array '[3, 3] Double
m1 :: Array '[3, 3] Double
m1 =
  [ 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 :: Array '[3, 3] Double
m2 :: Array '[3, 3] Double
m2 =
  [ 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 = forall a. a -> a -> Bool -> a
bool (-a
1 forall a. Num a => a -> a -> a
* (-a
x) forall a. Floating a => a -> a -> a
** (a
1 forall a. Fractional a => a -> a -> a
/ a
3.0)) (a
x forall a. Floating a => a -> a -> a
** (a
1 forall a. Fractional a => a -> a -> a
/ a
3.0)) (a
x 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_ :: Array '[3] Double -> Array '[3] Double
xyz2lab_ :: Array '[3] Double -> Array '[3] Double
xyz2lab_ Array '[3] Double
xyz =
  forall a b c d (sa :: [Natural]) (sb :: [Natural])
       (s' :: [Natural]) (ss :: [Natural]) (se :: [Natural]).
(HasShape sa, HasShape sb, HasShape (sa ++ sb),
 se ~ TakeIndexes (sa ++ sb) '[Rank sa - 1, Rank sa], HasShape se,
 KnownNat (Minimum se), KnownNat (Rank sa - 1), KnownNat (Rank sa),
 ss ~ '[Minimum se], HasShape ss,
 s' ~ DropIndexes (sa ++ sb) '[Rank sa - 1, Rank sa],
 HasShape s') =>
(Array ss c -> d)
-> (a -> b -> c) -> Array sa a -> Array sb b -> Array s' d
dot forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum forall a. Num a => a -> a -> a
(*) Array '[3, 3] Double
m2 (forall a. (Floating a, Ord a) => a -> a
cubicroot forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a b c d (sa :: [Natural]) (sb :: [Natural])
       (s' :: [Natural]) (ss :: [Natural]) (se :: [Natural]).
(HasShape sa, HasShape sb, HasShape (sa ++ sb),
 se ~ TakeIndexes (sa ++ sb) '[Rank sa - 1, Rank sa], HasShape se,
 KnownNat (Minimum se), KnownNat (Rank sa - 1), KnownNat (Rank sa),
 ss ~ '[Minimum se], HasShape ss,
 s' ~ DropIndexes (sa ++ sb) '[Rank sa - 1, Rank sa],
 HasShape s') =>
(Array ss c -> d)
-> (a -> b -> c) -> Array sa a -> Array sb b -> Array s' d
dot forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum forall a. Num a => a -> a -> a
(*) Array '[3, 3] Double
m1 Array '[3] Double
xyz)

m1' :: Array '[3, 3] Double
m1' :: Array '[3, 3] Double
m1' =
  [ 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' :: Array '[3, 3] Double
m2' :: Array '[3, 3] Double
m2' =
  [ 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_ :: Array '[3] Double -> Array '[3] Double
lab2xyz_ :: Array '[3] Double -> Array '[3] Double
lab2xyz_ Array '[3] Double
lab =
  forall a b c d (sa :: [Natural]) (sb :: [Natural])
       (s' :: [Natural]) (ss :: [Natural]) (se :: [Natural]).
(HasShape sa, HasShape sb, HasShape (sa ++ sb),
 se ~ TakeIndexes (sa ++ sb) '[Rank sa - 1, Rank sa], HasShape se,
 KnownNat (Minimum se), KnownNat (Rank sa - 1), KnownNat (Rank sa),
 ss ~ '[Minimum se], HasShape ss,
 s' ~ DropIndexes (sa ++ sb) '[Rank sa - 1, Rank sa],
 HasShape s') =>
(Array ss c -> d)
-> (a -> b -> c) -> Array sa a -> Array sb b -> Array s' d
dot forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum forall a. Num a => a -> a -> a
(*) Array '[3, 3] Double
m1' ((forall a. Floating a => a -> a -> a
** Double
3.0) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a b c d (sa :: [Natural]) (sb :: [Natural])
       (s' :: [Natural]) (ss :: [Natural]) (se :: [Natural]).
(HasShape sa, HasShape sb, HasShape (sa ++ sb),
 se ~ TakeIndexes (sa ++ sb) '[Rank sa - 1, Rank sa], HasShape se,
 KnownNat (Minimum se), KnownNat (Rank sa - 1), KnownNat (Rank sa),
 ss ~ '[Minimum se], HasShape ss,
 s' ~ DropIndexes (sa ++ sb) '[Rank sa - 1, Rank sa],
 HasShape s') =>
(Array ss c -> d)
-> (a -> b -> c) -> Array sa a -> Array sb b -> Array s' d
dot forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum 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 = forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Iso' LCHA Colour
lcha2colour' (Double -> LCHA -> LCHA -> LCHA
mixLCHA Double
x (forall k (is :: IxList) t b.
Is k A_Review =>
Optic' k is t b -> b -> t
review Iso' LCHA Colour
lcha2colour' Colour
c0) (forall k (is :: IxList) t b.
Is k A_Review =>
Optic' k is t b -> b -> t
review 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 forall a. Num a => a -> a -> a
+ Double
x forall a. Num a => a -> a -> a
* (Double
l' forall a. Num a => a -> a -> a
- Double
l)
    c'' :: Double
c'' = Double
c forall a. Num a => a -> a -> a
+ Double
x forall a. Num a => a -> a -> a
* (Double
c' forall a. Num a => a -> a -> a
- Double
c)
    h'' :: Double
h'' = Double
h forall a. Num a => a -> a -> a
+ Double
x forall a. Num a => a -> a -> a
* (Double
h' forall a. Num a => a -> a -> a
- Double
h)
    a'' :: Double
a'' = Double
a forall a. Num a => a -> a -> a
+ Double
x forall a. Num a => a -> a -> a
* (Double
a' 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
_ [Item [Colour]
c] = Item [Colour]
c
mixes Double
x [Colour]
cs = Double -> Colour -> Colour -> Colour
mix Double
r ([Colour]
cs forall a. [a] -> Int -> a
List.!! Int
i) ([Colour]
cs forall a. [a] -> Int -> a
List.!! (Int
i forall a. Num a => a -> a -> a
+ Int
1))
  where
    l :: Int
l = forall (t :: * -> *) a. Foldable t => t a -> Int
length [Colour]
cs forall a. Num a => a -> a -> a
- Int
1
    x' :: Double
x' = Double
x forall a. Num a => a -> a -> a
* forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
l
    i :: Int
i = forall a. Ord a => a -> a -> a
max Int
0 (forall a. Ord a => a -> a -> a
min (forall a b. (RealFrac a, Integral b) => a -> b
floor Double
x') (Int
l forall a. Num a => a -> a -> a
- Int
1))
    r :: Double
r = Double
x' forall a. Num a => a -> a -> a
- 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 = 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' (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' = 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' LCHA Colour
lcha2colour' 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' 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' = 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' LCHA Colour
lcha2colour' 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' 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' = 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' LCHA Colour
lcha2colour' 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' 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 =
  [trimming|<div class=swatch style="background:$rgba;">$label</div>|]
  where
    rgba :: Text
rgba = Colour -> Text
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 =
  [trimming|<div>
$pref
$divs
$suff
</div>
|]
  where
    divs :: Text
divs = Text -> [Text] -> Text
Text.intercalate Text
"\n" (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Text -> Colour -> Text
showSwatch 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 <- forall a g (m :: * -> *).
(UniformRange a, StatefulGen g m) =>
(a, a) -> g -> m a
uniformRM (Double
0, Double
1) g
gen
    Double
g <- forall a g (m :: * -> *).
(UniformRange a, StatefulGen g m) =>
(a, a) -> g -> m a
uniformRM (Double
0, Double
1) g
gen
    Double
b <- forall a g (m :: * -> *).
(UniformRange a, StatefulGen g m) =>
(a, a) -> g -> m a
uniformRM (Double
0, Double
1) g
gen
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (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 <- forall a g (m :: * -> *).
(UniformRange a, StatefulGen g m) =>
(a, a) -> g -> m a
uniformRM (Double
0, Double
1) g
gen
    Double
g <- forall a g (m :: * -> *).
(UniformRange a, StatefulGen g m) =>
(a, a) -> g -> m a
uniformRM (Double
0, Double
1) g
gen
    Double
b <- forall a g (m :: * -> *).
(UniformRange a, StatefulGen g m) =>
(a, a) -> g -> m a
uniformRM (Double
0, Double
1) g
gen
    Double
a <- forall a g (m :: * -> *).
(UniformRange a, StatefulGen g m) =>
(a, a) -> g -> m a
uniformRM (Double
0, Double
1) g
gen
    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 = 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') = forall g a. (RandomGen g, Uniform a) => g -> (a, g)
uniform t
g in a
x forall a. a -> [a] -> [a]
: t -> [a]
go t
g'

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

-- | Random list of Colours
rvColour :: [Colour]
rvColour :: [Colour]
rvColour = 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 = 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') = forall g a.
RandomGen g =>
g -> (StateGenM g -> State g a) -> (a, g)
runStateGen t
g forall g (m :: * -> *). StatefulGen g m => g -> m Colour
rvSensible in Colour
x 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 <- forall a g (m :: * -> *).
(UniformRange a, StatefulGen g m) =>
(a, a) -> g -> m a
uniformRM (Double
0.3, Double
0.75) g
gen
  Double
c <- forall a g (m :: * -> *).
(UniformRange a, StatefulGen g m) =>
(a, a) -> g -> m a
uniformRM (Double
0.05, Double
0.24) g
gen
  Double
h <- forall a g (m :: * -> *).
(UniformRange a, StatefulGen g m) =>
(a, a) -> g -> m a
uniformRM (Double
0, Double
360) g
gen
  forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Colour -> Colour
trimColour forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Iso' LCHA Colour
lcha2colour') (Double -> Double -> Double -> Double -> LCHA
LCHA Double
l Double
c Double
h Double
1))