{-# 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,
    transparent,
    black,
    white,
    light,
    dark,
    grey,
  )
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'
  { color' :: Color (Alpha RGB) Double
  } deriving (Eq, Generic)

-- | Constructor pattern.
pattern Colour :: Double -> Double -> Double -> Double -> Colour
pattern Colour r g b a = Colour' (ColorRGBA r g b a)

{-# COMPLETE Colour #-}

instance Show Colour where
  show (Colour r g b a) =
    Text.unpack $
      "Colour "
        <> fixed (Just 2) r
        <> " "
        <> fixed (Just 2) g
        <> " "
        <> fixed (Just 2) b
        <> " "
        <> fixed (Just 2) a

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

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

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

-- | interpolate between 2 colors
blend :: Double -> Colour -> Colour -> Colour
blend c (Colour r g b a) (Colour r' g' b' a') = Colour r'' g'' b'' a''
  where
    r'' = r + c * (r' - r)
    g'' = g + c * (g' - g)
    b'' = b + c * (b' - b)
    a'' = a + c * (a' - 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 _ [] = light
blends _ [c] = c
blends x cs = blend r (cs P.!! i) (cs P.!! (i+1))
  where
    l = length cs - 1
    x' = x * fromIntegral l
    i = max 0 (min (floor x') (l - 1))
    r = x' - fromIntegral i

-- |
parseHex :: A.Parser (Color RGB Double)
parseHex =
  fmap toDouble
    . ( \((r, g), b) ->
          ColorRGB (fromIntegral r) (fromIntegral g) (fromIntegral b) :: Color RGB Word8
      )
    . (\(f, b) -> (f `divMod` (256 :: Int), b))
    . (`divMod` 256)
    <$> (A.string "#" *> A.hexadecimal)

-- |
fromHex :: Text -> Either Text (Color RGB Double)
fromHex = first pack . A.parseOnly parseHex

-- |
unsafeFromHex :: Text -> Color RGB Double
unsafeFromHex t = either (const (ColorRGB 0 0 0)) id $ A.parseOnly parseHex t

-- | convert from 'Colour' to #xxxxxx
toHex :: Colour -> Text
toHex c =
  "#"
    <> Text.justifyRight 2 '0' (hex' r)
    <> Text.justifyRight 2 '0' (hex' g)
    <> Text.justifyRight 2 '0' (hex' b)
  where
    (ColorRGBA r g b _) = toIntegral . toWord8 <$> color' c

-- |
hex' :: Int -> Text
hex' i
  | i < 0 = "-" <> go (- i)
  | otherwise = go i
  where
    go n
      | n < 16 = hexDigit n
      | otherwise = go (n `quot` 16) <> hexDigit (n `rem` 16)

-- |
hexDigit :: Int -> Text
hexDigit n
  | n <= 9 = Text.singleton P.$! i2d n
  | otherwise = Text.singleton P.$! toEnum (n + 87)

-- |
i2d :: Int -> Char
i2d i = chr (ord '0' + i)

-- | some RGBA colors
palette1 :: [Colour]
palette1 =
  [ Colour 0.69 0.35 0.16 1.00,
    Colour 0.65 0.81 0.89 1.00,
    Colour 0.12 0.47 0.71 1.00,
    Colour 0.89 0.10 0.11 1.00,
    Colour 0.70 0.87 0.54 1.00,
    Colour 0.20 0.63 0.17 1.00,
    Colour 0.98 0.60 0.60 1.00,
    Colour 0.99 0.75 0.44 1.00,
    Colour 1.00 0.50 0.00 1.00,
    Colour 0.99 0.99 0.99 1.00,
    Colour 0.00 0.00 0.00 1.00,
    Colour 1.00 1.00 0.60 1.00,
    Colour 0.69 0.35 0.16 1.00
  ]

-- |
black :: Colour
black = Colour 0 0 0 1

-- |
white :: Colour
white = Colour 0.99 0.99 0.99 1

-- |
light :: Colour
light = Colour 0.94 0.94 0.94 1

-- |
dark :: Colour
dark = Colour 0.05 0.05 0.05 1

grey :: Colour
grey = Colour 0.5 0.5 0.5 1

-- |
transparent :: Colour
transparent = Colour 0 0 0 0