{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wall #-}
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-}
{-# OPTIONS_GHC -fno-warn-type-defaults #-}

-- | Colour representations and combinations, based on <https://hackage.haskell.org/package/Color>
module Data.Colour
  ( Colour,
    pattern Colour,
    opac,
    setOpac,
    fromRGB,
    hex,
    palette,
    palette1,
    blend,
    blends,
    toHex,
    fromHex,
    unsafeFromHex,
    grayscale,
    colorText,
    transparent,
    black,
    white,
  )
where

import qualified Data.Attoparsec.Text as A
import Data.FormatN
import Data.Generics.Labels ()
import qualified Data.Text as Text
import Graphics.Color.Model
import NumHask.Prelude as NHP
import qualified Prelude as P

-- | Wrapper for '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.
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
"RGBA "
        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

-- | get opacity
opac :: Colour -> Double
opac :: Colour -> Double
opac Colour
c = Color (Alpha RGB) Double -> Double
forall cs e. Color (Alpha cs) e -> e
getAlpha (Colour -> Color (Alpha RGB) Double
color' Colour
c)

-- | set opacity
setOpac :: Double -> Colour -> Colour
setOpac :: Double -> Colour -> Colour
setOpac Double
o (Colour Double
r Double
g Double
b Double
_) = Double -> Double -> Double -> Double -> Colour
Colour Double
r Double
g Double
b Double
o

-- |
fromRGB :: Color RGB Double -> Double -> Colour
fromRGB :: Color RGB Double -> Double -> Colour
fromRGB (ColorRGB Double
r Double
b Double
g) Double
o = Color (Alpha RGB) Double -> Colour
Colour' (Color (Alpha RGB) Double -> Colour)
-> Color (Alpha RGB) Double -> Colour
forall a b. (a -> b) -> a -> b
$ Double -> Double -> Double -> Double -> Color (Alpha RGB) Double
forall e. e -> e -> e -> e -> Color (Alpha RGB) e
ColorRGBA Double
r Double
b Double
g Double
o

-- |
hex :: Colour -> Text
hex :: Colour -> Text
hex Colour
c = Colour -> Text
toHex Colour
c

-- | interpolate between 2 colors
blend :: Double -> Colour -> Colour -> Colour
blend :: Double -> Colour -> Colour -> Colour
blend Double
c (Colour Double
r Double
g Double
b Double
a) (Colour Double
r' Double
g' Double
b' Double
a') = Double -> Double -> Double -> Double -> Colour
Colour Double
r'' Double
g'' Double
b'' Double
a''
  where
    r'' :: Double
r'' = Double
r Double -> Double -> Double
forall a. Additive a => a -> a -> a
+ Double
c Double -> Double -> Double
forall a. Multiplicative a => a -> a -> a
* (Double
r' Double -> Double -> Double
forall a. Subtractive a => a -> a -> a
- Double
r)
    g'' :: Double
g'' = Double
g Double -> Double -> Double
forall a. Additive a => a -> a -> a
+ Double
c Double -> Double -> Double
forall a. Multiplicative a => a -> a -> a
* (Double
g' Double -> Double -> Double
forall a. Subtractive a => a -> a -> a
- Double
g)
    b'' :: Double
b'' = Double
b Double -> Double -> Double
forall a. Additive a => a -> a -> a
+ Double
c Double -> Double -> Double
forall a. Multiplicative a => a -> a -> a
* (Double
b' Double -> Double -> Double
forall a. Subtractive a => a -> a -> a
- Double
b)
    a'' :: Double
a'' = Double
a Double -> Double -> Double
forall a. Additive a => a -> a -> a
+ Double
c Double -> Double -> Double
forall a. Multiplicative a => a -> a -> a
* (Double
a' Double -> Double -> Double
forall a. Subtractive a => a -> a -> a
- Double
a)

-- | interpolate across a list of Colours, with input being in Range 0 1
--
-- >>> blends 0 [black, (Colour 0.2 0.6 0.8 0.5), white] == black
-- True
--
-- >>> blends 1 [black, (Colour 0.2 0.6 0.8 0.5), white] == white
-- True
--
-- >>> blends 0.6 [black, (Colour 0.2 0.6 0.8 0.5), white]
-- RGBA 0.16 0.48 0.64 0.60
blends :: Double -> [Colour] -> Colour
blends :: Double -> [Colour] -> Colour
blends Double
_ [] = Colour
black
blends Double
_ [Colour
c] = Colour
c
blends Double
x [Colour]
cs = Double -> Colour -> Colour -> Colour
blend Double
r ([Colour]
cs [Colour] -> Int -> Colour
forall a. [a] -> Int -> a
P.!! Int
i) ([Colour]
cs [Colour] -> Int -> Colour
forall a. [a] -> Int -> a
P.!! (Int
iInt -> Int -> Int
forall a. Additive 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. Subtractive a => a -> a -> a
- Int
1
    x' :: Double
x' = Double
x Double -> Double -> Double
forall a. Multiplicative a => a -> a -> a
* Int -> Double
forall a b. FromIntegral a b => b -> a
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. QuotientField a b => a -> b
floor Double
x') (Int
l Int -> Int -> Int
forall a. Subtractive a => a -> a -> a
- Int
1))
    r :: Double
r = Double
x' Double -> Double -> Double
forall a. Subtractive a => a -> a -> a
- Int -> Double
forall a b. FromIntegral a b => b -> a
fromIntegral Int
i

-- |
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 k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat 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. FromIntegral a b => b -> a
fromIntegral Int
r) (Int -> Word8
forall a b. FromIntegral a b => b -> a
fromIntegral Int
g) (Int -> Word8
forall a b. FromIntegral a b => b -> a
fromIntegral Int
b) :: Color RGB Word8
      )
    (((Int, Int), Int) -> Color RGB Word8)
-> (Int -> ((Int, Int), Int)) -> Int -> Color RGB Word8
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat 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 k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat 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)

-- |
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 k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat 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

-- |
unsafeFromHex :: Text -> Color RGB Double
unsafeFromHex :: Text -> Color RGB Double
unsafeFromHex Text
t = (String -> Color RGB Double)
-> (Color RGB Double -> Color RGB Double)
-> Either String (Color RGB Double)
-> Color RGB Double
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Color RGB Double -> String -> Color RGB Double
forall a b. a -> b -> a
const (Double -> Double -> Double -> Color RGB Double
forall e. e -> e -> e -> Color RGB e
ColorRGB Double
0 Double
0 Double
0)) Color RGB Double -> Color RGB Double
forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id (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 #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. ToIntegral a b => a -> b
toIntegral (Word8 -> Int) -> (Double -> Word8) -> Double -> Int
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat 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
P.$! Int -> Char
i2d Int
n
  | Bool
otherwise = Char -> Text
Text.singleton (Char -> Text) -> Char -> Text
forall a b. (a -> b) -> a -> b
P.$! Int -> Char
forall a. Enum a => Int -> a
toEnum (Int
n Int -> Int -> Int
forall a. Additive 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. Additive a => a -> a -> a
+ Int
i)

-- | some RGB colors to work with
palette :: [Color RGB Double]
palette :: [Color RGB Double]
palette = Text -> Color RGB Double
unsafeFromHex (Text -> Color RGB Double) -> [Text] -> [Color RGB Double]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text
"#a6cee3", Text
"#1f78b4", Text
"#e31a1c", Text
"#b2df8a", Text
"#33a02c", Text
"#fb9a99", Text
"#fdbf6f", Text
"#ff7f00", Text
"#cab2d6", Text
"#6a3d9a", Text
"#ffff99", Text
"#b15928"]

-- | some RGBA colors
palette1 :: [Colour]
palette1 :: [Colour]
palette1 = (\Color RGB Double
c -> Color RGB Double -> Double -> Colour
fromRGB Color RGB Double
c Double
1) (Color RGB Double -> Colour) -> [Color RGB Double] -> [Colour]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Color RGB Double]
palette

-- | gray with 1 opacity
grayscale :: Double -> Color RGB Double
grayscale :: Double -> Color RGB Double
grayscale Double
n = Double -> Double -> Double -> Color RGB Double
forall e. e -> e -> e -> Color RGB e
ColorRGB Double
n Double
n Double
n

-- | standard text color
colorText :: Colour
colorText :: Colour
colorText = Color RGB Double -> Double -> Colour
fromRGB (Double -> Color RGB Double
grayscale Double
0.2) Double
1

-- |
black :: Colour
black :: Colour
black = Color RGB Double -> Double -> Colour
fromRGB (Double -> Color RGB Double
grayscale Double
0) Double
1

-- |
white :: Colour
white :: Colour
white = Color RGB Double -> Double -> Colour
fromRGB (Double -> Color RGB Double
grayscale Double
1) Double
1

-- |
transparent :: Colour
transparent :: Colour
transparent = Double -> Double -> Double -> Double -> Colour
Colour Double
0 Double
0 Double
0 Double
0