{-# 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,
    hex,
    blend,
    blends,
    toHex,
    fromHex,
    unsafeFromHex,
    palette1,
    palette1_,
    transparent,
    black,
    white,
    light,
    dark,
  )
where

import qualified Data.Attoparsec.Text as A
import Data.Bifunctor
import Data.Char
import Data.Either
import Data.FormatN
import Data.Generics.Labels ()
import qualified Data.List as List
import Data.Text (Text, pack)
import qualified Data.Text as Text
import GHC.Generics hiding (prec)
import Graphics.Color.Model

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

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

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

-- |
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. Num a => a -> a -> a
+ Double
c Double -> Double -> Double
forall a. Num a => a -> a -> a
* (Double
r' Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
r)
    g'' :: Double
g'' = Double
g Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
c Double -> Double -> Double
forall a. Num a => a -> a -> a
* (Double
g' Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
g)
    b'' :: Double
b'' = Double
b Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
c Double -> Double -> Double
forall a. Num a => a -> a -> a
* (Double
b' Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
b)
    a'' :: Double
a'' = Double
a Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
c 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
--
-- >>> 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]
-- Colour 0.36 0.68 0.84 0.60
blends :: Double -> [Colour] -> Colour
blends :: Double -> [Colour] -> Colour
blends Double
_ [] = Colour
light
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
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

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

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

-- |
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 #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.69 0.35 0.16 1.00
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

-- | finite list of Colours
palette1_ :: [Colour]
palette1_ :: [Colour]
palette1_ =
  [ Double -> Double -> Double -> Double -> Colour
Colour Double
0.69 Double
0.35 Double
0.16 Double
1.00,
    Double -> Double -> Double -> Double -> Colour
Colour Double
0.65 Double
0.81 Double
0.89 Double
1.00,
    Double -> Double -> Double -> Double -> Colour
Colour Double
0.12 Double
0.47 Double
0.71 Double
1.00,
    Double -> Double -> Double -> Double -> Colour
Colour Double
0.89 Double
0.10 Double
0.11 Double
1.00,
    Double -> Double -> Double -> Double -> Colour
Colour Double
0.70 Double
0.87 Double
0.54 Double
1.00,
    Double -> Double -> Double -> Double -> Colour
Colour Double
0.20 Double
0.63 Double
0.17 Double
1.00,
    Double -> Double -> Double -> Double -> Colour
Colour Double
0.98 Double
0.60 Double
0.60 Double
1.00,
    Double -> Double -> Double -> Double -> Colour
Colour Double
0.99 Double
0.75 Double
0.44 Double
1.00,
    Double -> Double -> Double -> Double -> Colour
Colour Double
1.00 Double
0.50 Double
0.00 Double
1.00,
    Double -> Double -> Double -> Double -> Colour
Colour Double
0.99 Double
0.99 Double
0.99 Double
1.00,
    Double -> Double -> Double -> Double -> Colour
Colour Double
0.00 Double
0.00 Double
0.00 Double
1.00,
    Double -> Double -> Double -> Double -> Colour
Colour Double
1.00 Double
1.00 Double
0.60 Double
1.00,
    Double -> Double -> Double -> Double -> Colour
Colour Double
0.69 Double
0.35 Double
0.16 Double
1.00
  ]

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

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

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