{-# 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
(Colour -> Colour -> Bool)
-> (Colour -> Colour -> Bool) -> Eq Colour
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. 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
$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) -> (Void# -> 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 (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 -> 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 (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 -> 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 (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

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

-- | 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 =
  (Word8 -> Double) -> Color RGB Word8 -> Color RGB Double
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Word8 -> Double
forall e. Elevator e => e -> Double
toDouble
    (Color RGB Word8 -> Color RGB Double)
-> (Int -> Color RGB Word8) -> Int -> Color RGB Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ( \((Int
r, Int
g), Int
b) ->
          Word8 -> Word8 -> Word8 -> Color RGB Word8
forall e. e -> e -> e -> Color RGB e
ColorRGB (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
r) (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
g) (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
b) :: Color RGB Word8
      )
    (((Int, Int), Int) -> Color RGB Word8)
-> (Int -> ((Int, Int), Int)) -> Int -> Color RGB Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\(Int
f, Int
b) -> (Int
f Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
`divMod` (Int
256 :: Int), Int
b))
    ((Int, Int) -> ((Int, Int), Int))
-> (Int -> (Int, Int)) -> Int -> ((Int, Int), Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
`divMod` Int
256)
    (Int -> Color RGB Double)
-> Parser Text Int -> Parser (Color RGB Double)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Text -> Parser Text
A.string Text
"#" Parser Text -> Parser Text Int -> Parser Text Int
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text Int
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 = (String -> Text)
-> Either String (Color RGB Double)
-> Either Text (Color RGB Double)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first String -> Text
pack (Either String (Color RGB Double)
 -> Either Text (Color RGB Double))
-> (Text -> Either String (Color RGB Double))
-> Text
-> Either Text (Color RGB Double)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser (Color RGB Double)
-> Text -> Either String (Color RGB Double)
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 = Color RGB Double
-> Either String (Color RGB Double) -> Color RGB Double
forall b a. b -> Either a b -> b
fromRight (Double -> Double -> Double -> Color RGB Double
forall e. e -> e -> e -> Color RGB e
ColorRGB Double
0 Double
0 Double
0) (Either String (Color RGB Double) -> Color RGB Double)
-> Either String (Color RGB Double) -> Color RGB Double
forall a b. (a -> b) -> a -> b
$ Parser (Color RGB Double)
-> Text -> Either String (Color RGB Double)
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
"#"
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Char -> Text -> Text
Text.justifyRight Int
2 Char
'0' (Int -> Text
hex' Int
r)
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Char -> Text -> Text
Text.justifyRight Int
2 Char
'0' (Int -> Text
hex' Int
g)
    Text -> Text -> Text
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
_) = Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> Int) -> (Double -> Word8) -> Double -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Word8
forall e. Elevator e => e -> Word8
toWord8 (Double -> Int)
-> Color (Alpha RGB) Double -> Color (Alpha RGB) Int
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 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 = Text
"-" Text -> Text -> 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 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
16 = Int -> Text
hexDigit Int
n
      | Bool
otherwise = Int -> Text
go (Int
n Int -> Int -> Int
forall a. Integral a => a -> a -> a
`quot` Int
16) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
hexDigit (Int
n Int -> Int -> Int
forall a. Integral a => a -> a -> a
`rem` Int
16)

-- |
hexDigit :: Int -> Text
hexDigit :: Int -> Text
hexDigit Int
n
  | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
9 = Char -> Text
Text.singleton (Char -> Text) -> Char -> Text
forall a b. (a -> b) -> a -> b
$! Int -> Char
i2d Int
n
  | Bool
otherwise = Char -> Text
Text.singleton (Char -> Text) -> Char -> Text
forall a b. (a -> b) -> a -> b
$! Int -> Char
forall a. Enum a => Int -> a
toEnum (Int
n Int -> Int -> Int
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' Int -> Int -> Int
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 = [Colour] -> [Colour]
forall a. [a] -> [a]
cycle [Colour]
palette1_ [Colour] -> Int -> Colour
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 (Colour -> Colour) -> (LCHA -> Colour) -> LCHA -> Colour
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Optic' An_Iso NoIx 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 NoIx 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
--
-- >>> 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 = 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. [a] -> [a]
cycle [Colour]
palette1_ [Colour] -> Int -> Colour
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' {LCH a -> Array '[3] a
lchArray :: Array '[3] 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
/= :: 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
[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
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)]
([Item (LCH a)] -> LCH a)
-> (Int -> [Item (LCH a)] -> LCH a)
-> (LCH a -> [Item (LCH a)])
-> IsList (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, a -> LCH b -> LCH a
(a -> b) -> LCH a -> LCH b
(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
<$ :: a -> LCH b -> LCH a
$c<$ :: forall a b. a -> LCH b -> LCH a
fmap :: (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 :: a -> a -> a -> LCH a
$mLCH :: forall r a. LCH a -> (a -> a -> a -> r) -> (Void# -> r) -> r
LCH l c h <-
  LCH' [l, c, h]
  where
    LCH a
l a
c a
h = Array '[3] a -> LCH a
forall a. Array '[3] a -> LCH a
LCH' [a
Item (Array '[3] a)
l, a
Item (Array '[3] a)
c, a
Item (Array '[3] a)
h]

{-# COMPLETE LCH #-}

-- | 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
/= :: LCHA -> LCHA -> Bool
$c/= :: LCHA -> LCHA -> Bool
== :: LCHA -> LCHA -> Bool
$c== :: 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
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' = (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 $bLCHA :: Double -> Double -> Double -> Double -> LCHA
$mLCHA :: forall r.
LCHA
-> (Double -> Double -> Double -> Double -> r) -> (Void# -> 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' (Array '[3] Double -> LCH Double
forall a. Array '[3] a -> LCH a
LCH' [Double
Item (Array '[3] Double)
l, Double
Item (Array '[3] Double)
c, Double
Item (Array '[3] 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' {RGB3 a -> Array '[3] a
rgb3Array :: Array '[3] 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
/= :: 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
[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
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)]
([Item (RGB3 a)] -> RGB3 a)
-> (Int -> [Item (RGB3 a)] -> RGB3 a)
-> (RGB3 a -> [Item (RGB3 a)])
-> IsList (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, a -> RGB3 b -> RGB3 a
(a -> b) -> RGB3 a -> RGB3 b
(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
<$ :: a -> RGB3 b -> RGB3 a
$c<$ :: forall a b. a -> RGB3 b -> RGB3 a
fmap :: (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 :: a -> a -> a -> RGB3 a
$mRGB3 :: forall r a. RGB3 a -> (a -> a -> a -> r) -> (Void# -> r) -> r
RGB3 r g b <-
  RGB3' [r, g, b]
  where
    RGB3 a
r a
g a
b = Array '[3] a -> RGB3 a
forall a. Array '[3] a -> RGB3 a
RGB3' [a
Item (Array '[3] a)
r, a
Item (Array '[3] a)
g, a
Item (Array '[3] 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' = (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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Double -> Word8
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 (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
newtype LAB a = LAB' {LAB a -> Array '[3] a
labArray :: Array '[3] 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
/= :: 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
[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
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)]
([Item (LAB a)] -> LAB a)
-> (Int -> [Item (LAB a)] -> LAB a)
-> (LAB a -> [Item (LAB a)])
-> IsList (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, a -> LAB b -> LAB a
(a -> b) -> LAB a -> LAB b
(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
<$ :: a -> LAB b -> LAB a
$c<$ :: forall a b. a -> LAB b -> LAB a
fmap :: (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 :: a -> a -> a -> LAB a
$mLAB :: forall r a. LAB a -> (a -> a -> a -> r) -> (Void# -> r) -> r
LAB l a b <-
  LAB' [l, a, b]
  where
    LAB a
l a
a a
b = Array '[3] a -> LAB a
forall a. Array '[3] a -> LAB a
LAB' [a
Item (Array '[3] a)
l, a
Item (Array '[3] a)
a, a
Item (Array '[3] 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' :: Optic' An_Iso NoIx LCHA Colour
lcha2colour' =
  (LCHA -> Colour)
-> (Colour -> LCHA) -> Optic' An_Iso NoIx 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 NoIx (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 NoIx (LAB Double) (LAB Double) (LCH Double) (LCH Double)
-> Optic
     (ReversedOptic An_Iso)
     NoIx
     (LCH Double)
     (LCH Double)
     (LAB Double)
     (LAB Double)
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 NoIx (LAB Double) (LAB Double) (LCH Double) (LCH Double)
lab2lch' Optic
  An_Iso NoIx (LCH Double) (LCH Double) (LAB Double) (LAB Double)
-> Optic
     An_Iso NoIx (LAB Double) (LAB Double) (RGB3 Double) (RGB3 Double)
-> Optic' An_Iso NoIx (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 NoIx (RGB3 Double) (RGB3 Double) (LAB Double) (LAB Double)
-> Optic
     (ReversedOptic An_Iso)
     NoIx
     (LAB Double)
     (LAB Double)
     (RGB3 Double)
     (RGB3 Double)
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 NoIx (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 NoIx 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)
     NoIx
     Colour
     Colour
     (RGB3 Double, Double)
     (RGB3 Double, Double)
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
  NoIx
  Colour
  Colour
  (RGB3 Double, Double)
  (RGB3 Double, Double)
-> Optic
     A_Lens
     NoIx
     (RGB3 Double, Double)
     (RGB3 Double, Double)
     (RGB3 Double)
     (RGB3 Double)
-> Optic A_Lens NoIx 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
  NoIx
  (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 NoIx Colour Colour (RGB3 Double) (RGB3 Double)
-> Optic
     An_Iso NoIx (RGB3 Double) (RGB3 Double) (LAB Double) (LAB Double)
-> Optic A_Lens NoIx 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 NoIx (RGB3 Double) (RGB3 Double) (LAB Double) (LAB Double)
rgb2lab' Optic A_Lens NoIx Colour Colour (LAB Double) (LAB Double)
-> Optic
     An_Iso NoIx (LAB Double) (LAB Double) (LCH Double) (LCH Double)
-> Optic' A_Lens NoIx 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 NoIx (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 version 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 -> Double
forall a b. Norm a b => a -> b
norm (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 -> Double
forall coord dir. Direction coord dir => coord -> dir
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) = Polar Double Double -> Point Double
forall coord mag dir.
(MultiplicativeAction coord mag, Direction coord dir) =>
Polar mag dir -> coord
coord (Double -> Double -> Polar Double Double
forall mag dir. mag -> dir -> Polar mag dir
Polar Double
c (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 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 NoIx (LAB Double) (LAB Double) (LCH Double) (LCH Double)
lab2lch' =
  (LAB Double -> LCH Double)
-> (LCH Double -> LAB Double)
-> Optic
     An_Iso NoIx (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)
     NoIx
     (Double, Double)
     (Double, Double)
     (Double, Double)
     (Double, Double)
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 NoIx (RGB3 Double) (RGB3 Double) (LAB Double) (LAB Double)
rgb2lab' =
  (RGB3 Double -> LAB Double)
-> (LAB Double -> RGB3 Double)
-> Optic
     An_Iso NoIx (RGB3 Double) (RGB3 Double) (LAB Double) (LAB Double)
forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso
    (\(RGB3' Array '[3] Double
a) -> Array '[3] Double -> LAB Double
forall a. Array '[3] a -> LAB a
LAB' (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
$ Array '[3] Double
a)
    (\(LAB' Array '[3] Double
a) -> Array '[3] Double -> RGB3 Double
forall a. Array '[3] a -> RGB3 a
RGB3' (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
$ 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 = [Item (Array '[3] Double)] -> Array '[3] Double
forall l. IsList l => [Item l] -> l
fromList [Double
Item [Double]
r, Double
Item [Double]
g, Double
Item [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 -> Rep (Array '[3]) -> Double
forall (f :: * -> *) a. Representable f => f a -> Rep f -> a
`index` [Item [Int]
0]) (Array '[3] Double
a Array '[3] Double -> Rep (Array '[3]) -> Double
forall (f :: * -> *) a. Representable f => f a -> Rep f -> a
`index` [Item [Int]
1]) (Array '[3] Double
a Array '[3] Double -> Rep (Array '[3]) -> Double
forall (f :: * -> *) a. Representable f => f a -> Rep f -> a
`index` [Item [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 = [Item (Array '[3] Double)] -> Array '[3] Double
forall l. IsList l => [Item l] -> l
fromList [Double
Item [Double]
x, Double
Item [Double]
y, Double
Item [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 -> Rep (Array '[3]) -> Double
forall (f :: * -> *) a. Representable f => f a -> Rep f -> a
`index` [Item [Int]
0]) (Array '[3] Double
a Array '[3] Double -> Rep (Array '[3]) -> Double
forall (f :: * -> *) a. Representable f => f a -> Rep f -> a
`index` [Item [Int]
1]) (Array '[3] Double
a Array '[3] Double -> Rep (Array '[3]) -> Double
forall (f :: * -> *) a. Representable f => f a -> Rep f -> a
`index` [Item [Int]
2])) :: Color (S.XYZ S.D65) Double

-- * xyz to lab

m1 :: Array '[3, 3] Double
m1 :: Array '[3, 3] Double
m1 =
  [ Item (Array '[3, 3] Double)
0.8189330101,
    Item (Array '[3, 3] Double)
0.3618667424,
    -Double
0.1288597137,
    Item (Array '[3, 3] Double)
0.0329845436,
    Item (Array '[3, 3] Double)
0.9293118715,
    Item (Array '[3, 3] Double)
0.0361456387,
    Item (Array '[3, 3] Double)
0.0482003018,
    Item (Array '[3, 3] Double)
0.2643662691,
    Item (Array '[3, 3] Double)
0.6338517070
  ]

m2 :: Array '[3, 3] Double
m2 :: Array '[3, 3] Double
m2 =
  [ Item (Array '[3, 3] Double)
0.2104542553,
    Item (Array '[3, 3] Double)
0.7936177850,
    -Double
0.0040720468,
    Item (Array '[3, 3] Double)
1.9779984951,
    -Double
2.4285922050,
    Item (Array '[3, 3] Double)
0.4505937099,
    Item (Array '[3, 3] Double)
0.0259040371,
    Item (Array '[3, 3] Double)
0.7827717662,
    -Double
0.8086757660
  ]

cubicroot :: (Floating a, Ord a) => a -> a
cubicroot :: 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_ :: Array '[3] Double -> Array '[3] Double
xyz2lab_ :: Array '[3] Double -> Array '[3] Double
xyz2lab_ Array '[3] Double
xyz =
  (Array '[3] Double -> Double)
-> (Double -> Double -> Double)
-> Array '[3, 3] Double
-> Array '[3] Double
-> Array '[3] Double
forall a b c d (sa :: [Nat]) (sb :: [Nat]) (s' :: [Nat])
       (ss :: [Nat]) (se :: [Nat]).
(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 Array '[3] Double -> Double
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 '[3] Double -> Array '[3] Double
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Array '[3] Double -> Double)
-> (Double -> Double -> Double)
-> Array '[3, 3] Double
-> Array '[3] Double
-> Array '[3] Double
forall a b c d (sa :: [Nat]) (sb :: [Nat]) (s' :: [Nat])
       (ss :: [Nat]) (se :: [Nat]).
(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 Array '[3] Double -> Double
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' :: Array '[3, 3] Double
m1' :: Array '[3, 3] Double
m1' =
  [ Item (Array '[3, 3] Double)
1.227013851103521026,
    -Double
0.5577999806518222383,
    Item (Array '[3, 3] Double)
0.28125614896646780758,
    -Double
0.040580178423280593977,
    Item (Array '[3, 3] Double)
1.1122568696168301049,
    -Double
0.071676678665601200577,
    -Double
0.076381284505706892869,
    -Double
0.42148197841801273055,
    Item (Array '[3, 3] Double)
1.5861632204407947575
  ]

m2' :: Array '[3, 3] Double
m2' :: Array '[3, 3] Double
m2' =
  [ Item (Array '[3, 3] Double)
0.99999999845051981432,
    Item (Array '[3, 3] Double)
0.39633779217376785678,
    Item (Array '[3, 3] Double)
0.21580375806075880339,
    Item (Array '[3, 3] Double)
1.0000000088817607767,
    -Double
0.1055613423236563494,
    -Double
0.063854174771705903402,
    Item (Array '[3, 3] 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 =
  (Array '[3] Double -> Double)
-> (Double -> Double -> Double)
-> Array '[3, 3] Double
-> Array '[3] Double
-> Array '[3] Double
forall a b c d (sa :: [Nat]) (sb :: [Nat]) (s' :: [Nat])
       (ss :: [Nat]) (se :: [Nat]).
(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 Array '[3] Double -> Double
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 '[3] Double -> Array '[3] Double
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Array '[3] Double -> Double)
-> (Double -> Double -> Double)
-> Array '[3, 3] Double
-> Array '[3] Double
-> Array '[3] Double
forall a b c d (sa :: [Nat]) (sb :: [Nat]) (s' :: [Nat])
       (ss :: [Nat]) (se :: [Nat]).
(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 Array '[3] Double -> Double
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 NoIx 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 NoIx LCHA Colour
lcha2colour' (Double -> LCHA -> LCHA -> LCHA
mixLCHA Double
x (Optic' An_Iso NoIx 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 NoIx LCHA Colour
lcha2colour' Colour
c0) (Optic' An_Iso NoIx 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 NoIx 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
_ [Item [Colour]
c] = Item [Colour]
Colour
c
mixes Double
x [Colour]
cs = Double -> Colour -> Colour -> Colour
mix Double
r ([Colour]
cs [Colour] -> Int -> Colour
forall a. [a] -> Int -> a
List.!! Int
i) ([Colour]
cs [Colour] -> Int -> Colour
forall a. [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 (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 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 NoIx LCHA Colour
-> Optic (ReversedOptic An_Iso) NoIx Colour Colour LCHA LCHA
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 NoIx LCHA Colour
lcha2colour' Optic An_Iso NoIx Colour Colour LCHA LCHA
-> Lens' LCHA (LCH Double)
-> Optic' A_Lens NoIx 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 NoIx 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 NoIx LCHA Colour
-> Optic (ReversedOptic An_Iso) NoIx Colour Colour LCHA LCHA
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 NoIx LCHA Colour
lcha2colour' Optic An_Iso NoIx Colour Colour LCHA LCHA
-> Lens' LCHA (LCH Double)
-> Optic' A_Lens NoIx 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 NoIx 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 NoIx LCHA Colour
-> Optic (ReversedOptic An_Iso) NoIx Colour Colour LCHA LCHA
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 NoIx LCHA Colour
lcha2colour' Optic An_Iso NoIx Colour Colour LCHA LCHA
-> Lens' LCHA (LCH Double)
-> Optic' A_Lens NoIx 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 NoIx 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 =
  [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" ((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 :: 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
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
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
uniformRM (Double
0, Double
1) g
gen
    RGB3 Double -> m (RGB3 Double)
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 :: 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
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
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
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
uniformRM (Double
0, Double
1) g
gen
    Colour -> m Colour
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 :: [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 :: 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
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
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
uniformRM (Double
0, Double
360) g
gen
  Colour -> m Colour
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 NoIx 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 NoIx LCHA Colour
lcha2colour') (Double -> Double -> Double -> Double -> LCHA
LCHA Double
l Double
c Double
h Double
1))