-- | Haskell port of the perceptually-uniform HSLuv colorspace model (http://www.hsluv.org/).
module HSLuv where

import           Constants           (epsilon, kappa, m, minv, refU, refV, refY)
import           Control.Applicative (liftA2)
import           Data.Colour.CIE     (Colour, cieXYZ, cieXYZView)
import           Data.Fixed          (mod')
import qualified Geometry            as G
import           Numeric             (readHex, showHex)
import           Util                (fromLinear, toLinear, tripleDotProduct)

-- | Value in [0, 1].
newtype RGBRed =
  RGBRed Double
  deriving (RGBRed -> RGBRed -> Bool
(RGBRed -> RGBRed -> Bool)
-> (RGBRed -> RGBRed -> Bool) -> Eq RGBRed
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RGBRed -> RGBRed -> Bool
== :: RGBRed -> RGBRed -> Bool
$c/= :: RGBRed -> RGBRed -> Bool
/= :: RGBRed -> RGBRed -> Bool
Eq, Int -> RGBRed -> ShowS
[RGBRed] -> ShowS
RGBRed -> String
(Int -> RGBRed -> ShowS)
-> (RGBRed -> String) -> ([RGBRed] -> ShowS) -> Show RGBRed
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RGBRed -> ShowS
showsPrec :: Int -> RGBRed -> ShowS
$cshow :: RGBRed -> String
show :: RGBRed -> String
$cshowList :: [RGBRed] -> ShowS
showList :: [RGBRed] -> ShowS
Show)

-- | Value in [0, 1].
newtype RGBGreen =
  RGBGreen Double
  deriving (RGBGreen -> RGBGreen -> Bool
(RGBGreen -> RGBGreen -> Bool)
-> (RGBGreen -> RGBGreen -> Bool) -> Eq RGBGreen
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RGBGreen -> RGBGreen -> Bool
== :: RGBGreen -> RGBGreen -> Bool
$c/= :: RGBGreen -> RGBGreen -> Bool
/= :: RGBGreen -> RGBGreen -> Bool
Eq, Int -> RGBGreen -> ShowS
[RGBGreen] -> ShowS
RGBGreen -> String
(Int -> RGBGreen -> ShowS)
-> (RGBGreen -> String) -> ([RGBGreen] -> ShowS) -> Show RGBGreen
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RGBGreen -> ShowS
showsPrec :: Int -> RGBGreen -> ShowS
$cshow :: RGBGreen -> String
show :: RGBGreen -> String
$cshowList :: [RGBGreen] -> ShowS
showList :: [RGBGreen] -> ShowS
Show)

-- | Value in [0, 1].
newtype RGBBlue =
  RGBBlue Double
  deriving (RGBBlue -> RGBBlue -> Bool
(RGBBlue -> RGBBlue -> Bool)
-> (RGBBlue -> RGBBlue -> Bool) -> Eq RGBBlue
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RGBBlue -> RGBBlue -> Bool
== :: RGBBlue -> RGBBlue -> Bool
$c/= :: RGBBlue -> RGBBlue -> Bool
/= :: RGBBlue -> RGBBlue -> Bool
Eq, Int -> RGBBlue -> ShowS
[RGBBlue] -> ShowS
RGBBlue -> String
(Int -> RGBBlue -> ShowS)
-> (RGBBlue -> String) -> ([RGBBlue] -> ShowS) -> Show RGBBlue
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RGBBlue -> ShowS
showsPrec :: Int -> RGBBlue -> ShowS
$cshow :: RGBBlue -> String
show :: RGBBlue -> String
$cshowList :: [RGBBlue] -> ShowS
showList :: [RGBBlue] -> ShowS
Show)

-- | Values in [0, 1].
data RGB =
  RGB RGBRed
      RGBGreen
      RGBBlue
  deriving (RGB -> RGB -> Bool
(RGB -> RGB -> Bool) -> (RGB -> RGB -> Bool) -> Eq RGB
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RGB -> RGB -> Bool
== :: RGB -> RGB -> Bool
$c/= :: RGB -> RGB -> Bool
/= :: RGB -> RGB -> Bool
Eq, Int -> RGB -> ShowS
[RGB] -> ShowS
RGB -> String
(Int -> RGB -> ShowS)
-> (RGB -> String) -> ([RGB] -> ShowS) -> Show RGB
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RGB -> ShowS
showsPrec :: Int -> RGB -> ShowS
$cshow :: RGB -> String
show :: RGB -> String
$cshowList :: [RGB] -> ShowS
showList :: [RGB] -> ShowS
Show)

-- | Value in [0, 1].
newtype XYZX =
  XYZX Double
  deriving (XYZX -> XYZX -> Bool
(XYZX -> XYZX -> Bool) -> (XYZX -> XYZX -> Bool) -> Eq XYZX
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: XYZX -> XYZX -> Bool
== :: XYZX -> XYZX -> Bool
$c/= :: XYZX -> XYZX -> Bool
/= :: XYZX -> XYZX -> Bool
Eq, Int -> XYZX -> ShowS
[XYZX] -> ShowS
XYZX -> String
(Int -> XYZX -> ShowS)
-> (XYZX -> String) -> ([XYZX] -> ShowS) -> Show XYZX
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> XYZX -> ShowS
showsPrec :: Int -> XYZX -> ShowS
$cshow :: XYZX -> String
show :: XYZX -> String
$cshowList :: [XYZX] -> ShowS
showList :: [XYZX] -> ShowS
Show)

-- | Value in [0, 1].
newtype XYZY =
  XYZY Double
  deriving (XYZY -> XYZY -> Bool
(XYZY -> XYZY -> Bool) -> (XYZY -> XYZY -> Bool) -> Eq XYZY
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: XYZY -> XYZY -> Bool
== :: XYZY -> XYZY -> Bool
$c/= :: XYZY -> XYZY -> Bool
/= :: XYZY -> XYZY -> Bool
Eq, Int -> XYZY -> ShowS
[XYZY] -> ShowS
XYZY -> String
(Int -> XYZY -> ShowS)
-> (XYZY -> String) -> ([XYZY] -> ShowS) -> Show XYZY
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> XYZY -> ShowS
showsPrec :: Int -> XYZY -> ShowS
$cshow :: XYZY -> String
show :: XYZY -> String
$cshowList :: [XYZY] -> ShowS
showList :: [XYZY] -> ShowS
Show)

-- | Value in [0, 1].
newtype XYZZ =
  XYZZ Double
  deriving (XYZZ -> XYZZ -> Bool
(XYZZ -> XYZZ -> Bool) -> (XYZZ -> XYZZ -> Bool) -> Eq XYZZ
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: XYZZ -> XYZZ -> Bool
== :: XYZZ -> XYZZ -> Bool
$c/= :: XYZZ -> XYZZ -> Bool
/= :: XYZZ -> XYZZ -> Bool
Eq, Int -> XYZZ -> ShowS
[XYZZ] -> ShowS
XYZZ -> String
(Int -> XYZZ -> ShowS)
-> (XYZZ -> String) -> ([XYZZ] -> ShowS) -> Show XYZZ
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> XYZZ -> ShowS
showsPrec :: Int -> XYZZ -> ShowS
$cshow :: XYZZ -> String
show :: XYZZ -> String
$cshowList :: [XYZZ] -> ShowS
showList :: [XYZZ] -> ShowS
Show)

-- | Values in [0, 1].
data XYZ =
  XYZ XYZX
      XYZY
      XYZZ
  deriving (XYZ -> XYZ -> Bool
(XYZ -> XYZ -> Bool) -> (XYZ -> XYZ -> Bool) -> Eq XYZ
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: XYZ -> XYZ -> Bool
== :: XYZ -> XYZ -> Bool
$c/= :: XYZ -> XYZ -> Bool
/= :: XYZ -> XYZ -> Bool
Eq, Int -> XYZ -> ShowS
[XYZ] -> ShowS
XYZ -> String
(Int -> XYZ -> ShowS)
-> (XYZ -> String) -> ([XYZ] -> ShowS) -> Show XYZ
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> XYZ -> ShowS
showsPrec :: Int -> XYZ -> ShowS
$cshow :: XYZ -> String
show :: XYZ -> String
$cshowList :: [XYZ] -> ShowS
showList :: [XYZ] -> ShowS
Show)

newtype LUVLightness =
  LUVLightness Double
  deriving (LUVLightness -> LUVLightness -> Bool
(LUVLightness -> LUVLightness -> Bool)
-> (LUVLightness -> LUVLightness -> Bool) -> Eq LUVLightness
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: LUVLightness -> LUVLightness -> Bool
== :: LUVLightness -> LUVLightness -> Bool
$c/= :: LUVLightness -> LUVLightness -> Bool
/= :: LUVLightness -> LUVLightness -> Bool
Eq, Int -> LUVLightness -> ShowS
[LUVLightness] -> ShowS
LUVLightness -> String
(Int -> LUVLightness -> ShowS)
-> (LUVLightness -> String)
-> ([LUVLightness] -> ShowS)
-> Show LUVLightness
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LUVLightness -> ShowS
showsPrec :: Int -> LUVLightness -> ShowS
$cshow :: LUVLightness -> String
show :: LUVLightness -> String
$cshowList :: [LUVLightness] -> ShowS
showList :: [LUVLightness] -> ShowS
Show)

newtype LUVU =
  LUVU Double
  deriving (LUVU -> LUVU -> Bool
(LUVU -> LUVU -> Bool) -> (LUVU -> LUVU -> Bool) -> Eq LUVU
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: LUVU -> LUVU -> Bool
== :: LUVU -> LUVU -> Bool
$c/= :: LUVU -> LUVU -> Bool
/= :: LUVU -> LUVU -> Bool
Eq, Int -> LUVU -> ShowS
[LUVU] -> ShowS
LUVU -> String
(Int -> LUVU -> ShowS)
-> (LUVU -> String) -> ([LUVU] -> ShowS) -> Show LUVU
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LUVU -> ShowS
showsPrec :: Int -> LUVU -> ShowS
$cshow :: LUVU -> String
show :: LUVU -> String
$cshowList :: [LUVU] -> ShowS
showList :: [LUVU] -> ShowS
Show)

newtype LUVV =
  LUVV Double
  deriving (LUVV -> LUVV -> Bool
(LUVV -> LUVV -> Bool) -> (LUVV -> LUVV -> Bool) -> Eq LUVV
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: LUVV -> LUVV -> Bool
== :: LUVV -> LUVV -> Bool
$c/= :: LUVV -> LUVV -> Bool
/= :: LUVV -> LUVV -> Bool
Eq, Int -> LUVV -> ShowS
[LUVV] -> ShowS
LUVV -> String
(Int -> LUVV -> ShowS)
-> (LUVV -> String) -> ([LUVV] -> ShowS) -> Show LUVV
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LUVV -> ShowS
showsPrec :: Int -> LUVV -> ShowS
$cshow :: LUVV -> String
show :: LUVV -> String
$cshowList :: [LUVV] -> ShowS
showList :: [LUVV] -> ShowS
Show)

data LUV =
  LUV LUVLightness
      LUVU
      LUVV
  deriving (LUV -> LUV -> Bool
(LUV -> LUV -> Bool) -> (LUV -> LUV -> Bool) -> Eq LUV
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: LUV -> LUV -> Bool
== :: LUV -> LUV -> Bool
$c/= :: LUV -> LUV -> Bool
/= :: LUV -> LUV -> Bool
Eq, Int -> LUV -> ShowS
[LUV] -> ShowS
LUV -> String
(Int -> LUV -> ShowS)
-> (LUV -> String) -> ([LUV] -> ShowS) -> Show LUV
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LUV -> ShowS
showsPrec :: Int -> LUV -> ShowS
$cshow :: LUV -> String
show :: LUV -> String
$cshowList :: [LUV] -> ShowS
showList :: [LUV] -> ShowS
Show)

newtype LCHLightness =
  LCHLightness Double
  deriving (LCHLightness -> LCHLightness -> Bool
(LCHLightness -> LCHLightness -> Bool)
-> (LCHLightness -> LCHLightness -> Bool) -> Eq LCHLightness
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: LCHLightness -> LCHLightness -> Bool
== :: LCHLightness -> LCHLightness -> Bool
$c/= :: LCHLightness -> LCHLightness -> Bool
/= :: LCHLightness -> LCHLightness -> Bool
Eq, Int -> LCHLightness -> ShowS
[LCHLightness] -> ShowS
LCHLightness -> String
(Int -> LCHLightness -> ShowS)
-> (LCHLightness -> String)
-> ([LCHLightness] -> ShowS)
-> Show LCHLightness
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LCHLightness -> ShowS
showsPrec :: Int -> LCHLightness -> ShowS
$cshow :: LCHLightness -> String
show :: LCHLightness -> String
$cshowList :: [LCHLightness] -> ShowS
showList :: [LCHLightness] -> ShowS
Show)

newtype LCHChroma =
  LCHChroma Double
  deriving (LCHChroma -> LCHChroma -> Bool
(LCHChroma -> LCHChroma -> Bool)
-> (LCHChroma -> LCHChroma -> Bool) -> Eq LCHChroma
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: LCHChroma -> LCHChroma -> Bool
== :: LCHChroma -> LCHChroma -> Bool
$c/= :: LCHChroma -> LCHChroma -> Bool
/= :: LCHChroma -> LCHChroma -> Bool
Eq, Int -> LCHChroma -> ShowS
[LCHChroma] -> ShowS
LCHChroma -> String
(Int -> LCHChroma -> ShowS)
-> (LCHChroma -> String)
-> ([LCHChroma] -> ShowS)
-> Show LCHChroma
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LCHChroma -> ShowS
showsPrec :: Int -> LCHChroma -> ShowS
$cshow :: LCHChroma -> String
show :: LCHChroma -> String
$cshowList :: [LCHChroma] -> ShowS
showList :: [LCHChroma] -> ShowS
Show)

newtype LCHHue =
  LCHHue Double
  deriving (LCHHue -> LCHHue -> Bool
(LCHHue -> LCHHue -> Bool)
-> (LCHHue -> LCHHue -> Bool) -> Eq LCHHue
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: LCHHue -> LCHHue -> Bool
== :: LCHHue -> LCHHue -> Bool
$c/= :: LCHHue -> LCHHue -> Bool
/= :: LCHHue -> LCHHue -> Bool
Eq, Int -> LCHHue -> ShowS
[LCHHue] -> ShowS
LCHHue -> String
(Int -> LCHHue -> ShowS)
-> (LCHHue -> String) -> ([LCHHue] -> ShowS) -> Show LCHHue
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LCHHue -> ShowS
showsPrec :: Int -> LCHHue -> ShowS
$cshow :: LCHHue -> String
show :: LCHHue -> String
$cshowList :: [LCHHue] -> ShowS
showList :: [LCHHue] -> ShowS
Show)

data LCH =
  LCH LCHLightness
      LCHChroma
      LCHHue
  deriving (LCH -> LCH -> Bool
(LCH -> LCH -> Bool) -> (LCH -> LCH -> Bool) -> Eq LCH
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: LCH -> LCH -> Bool
== :: LCH -> LCH -> Bool
$c/= :: LCH -> LCH -> Bool
/= :: LCH -> LCH -> Bool
Eq, Int -> LCH -> ShowS
[LCH] -> ShowS
LCH -> String
(Int -> LCH -> ShowS)
-> (LCH -> String) -> ([LCH] -> ShowS) -> Show LCH
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LCH -> ShowS
showsPrec :: Int -> LCH -> ShowS
$cshow :: LCH -> String
show :: LCH -> String
$cshowList :: [LCH] -> ShowS
showList :: [LCH] -> ShowS
Show)

-- | Value in [0, 360].
newtype HSLuvHue =
  HSLuvHue Double
  deriving (HSLuvHue -> HSLuvHue -> Bool
(HSLuvHue -> HSLuvHue -> Bool)
-> (HSLuvHue -> HSLuvHue -> Bool) -> Eq HSLuvHue
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: HSLuvHue -> HSLuvHue -> Bool
== :: HSLuvHue -> HSLuvHue -> Bool
$c/= :: HSLuvHue -> HSLuvHue -> Bool
/= :: HSLuvHue -> HSLuvHue -> Bool
Eq, Int -> HSLuvHue -> ShowS
[HSLuvHue] -> ShowS
HSLuvHue -> String
(Int -> HSLuvHue -> ShowS)
-> (HSLuvHue -> String) -> ([HSLuvHue] -> ShowS) -> Show HSLuvHue
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> HSLuvHue -> ShowS
showsPrec :: Int -> HSLuvHue -> ShowS
$cshow :: HSLuvHue -> String
show :: HSLuvHue -> String
$cshowList :: [HSLuvHue] -> ShowS
showList :: [HSLuvHue] -> ShowS
Show)

-- | Value in [0, 100].
newtype HSLuvSaturation =
  HSLuvSaturation Double
  deriving (HSLuvSaturation -> HSLuvSaturation -> Bool
(HSLuvSaturation -> HSLuvSaturation -> Bool)
-> (HSLuvSaturation -> HSLuvSaturation -> Bool)
-> Eq HSLuvSaturation
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: HSLuvSaturation -> HSLuvSaturation -> Bool
== :: HSLuvSaturation -> HSLuvSaturation -> Bool
$c/= :: HSLuvSaturation -> HSLuvSaturation -> Bool
/= :: HSLuvSaturation -> HSLuvSaturation -> Bool
Eq, Int -> HSLuvSaturation -> ShowS
[HSLuvSaturation] -> ShowS
HSLuvSaturation -> String
(Int -> HSLuvSaturation -> ShowS)
-> (HSLuvSaturation -> String)
-> ([HSLuvSaturation] -> ShowS)
-> Show HSLuvSaturation
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> HSLuvSaturation -> ShowS
showsPrec :: Int -> HSLuvSaturation -> ShowS
$cshow :: HSLuvSaturation -> String
show :: HSLuvSaturation -> String
$cshowList :: [HSLuvSaturation] -> ShowS
showList :: [HSLuvSaturation] -> ShowS
Show)

-- | Value in [0, 100].
newtype HSLuvLightness =
  HSLuvLightness Double
  deriving (HSLuvLightness -> HSLuvLightness -> Bool
(HSLuvLightness -> HSLuvLightness -> Bool)
-> (HSLuvLightness -> HSLuvLightness -> Bool) -> Eq HSLuvLightness
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: HSLuvLightness -> HSLuvLightness -> Bool
== :: HSLuvLightness -> HSLuvLightness -> Bool
$c/= :: HSLuvLightness -> HSLuvLightness -> Bool
/= :: HSLuvLightness -> HSLuvLightness -> Bool
Eq, Int -> HSLuvLightness -> ShowS
[HSLuvLightness] -> ShowS
HSLuvLightness -> String
(Int -> HSLuvLightness -> ShowS)
-> (HSLuvLightness -> String)
-> ([HSLuvLightness] -> ShowS)
-> Show HSLuvLightness
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> HSLuvLightness -> ShowS
showsPrec :: Int -> HSLuvLightness -> ShowS
$cshow :: HSLuvLightness -> String
show :: HSLuvLightness -> String
$cshowList :: [HSLuvLightness] -> ShowS
showList :: [HSLuvLightness] -> ShowS
Show)

-- | Values in [0, 360]; [0, 100]; [0, 100].
data HSLuv =
  HSLuv HSLuvHue
        HSLuvSaturation
        HSLuvLightness
  deriving (HSLuv -> HSLuv -> Bool
(HSLuv -> HSLuv -> Bool) -> (HSLuv -> HSLuv -> Bool) -> Eq HSLuv
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: HSLuv -> HSLuv -> Bool
== :: HSLuv -> HSLuv -> Bool
$c/= :: HSLuv -> HSLuv -> Bool
/= :: HSLuv -> HSLuv -> Bool
Eq, Int -> HSLuv -> ShowS
[HSLuv] -> ShowS
HSLuv -> String
(Int -> HSLuv -> ShowS)
-> (HSLuv -> String) -> ([HSLuv] -> ShowS) -> Show HSLuv
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> HSLuv -> ShowS
showsPrec :: Int -> HSLuv -> ShowS
$cshow :: HSLuv -> String
show :: HSLuv -> String
$cshowList :: [HSLuv] -> ShowS
showList :: [HSLuv] -> ShowS
Show)

-- | Value in [0, 360].
newtype HPLuvHue =
  HPLuvHue Double
  deriving (HPLuvHue -> HPLuvHue -> Bool
(HPLuvHue -> HPLuvHue -> Bool)
-> (HPLuvHue -> HPLuvHue -> Bool) -> Eq HPLuvHue
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: HPLuvHue -> HPLuvHue -> Bool
== :: HPLuvHue -> HPLuvHue -> Bool
$c/= :: HPLuvHue -> HPLuvHue -> Bool
/= :: HPLuvHue -> HPLuvHue -> Bool
Eq, Int -> HPLuvHue -> ShowS
[HPLuvHue] -> ShowS
HPLuvHue -> String
(Int -> HPLuvHue -> ShowS)
-> (HPLuvHue -> String) -> ([HPLuvHue] -> ShowS) -> Show HPLuvHue
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> HPLuvHue -> ShowS
showsPrec :: Int -> HPLuvHue -> ShowS
$cshow :: HPLuvHue -> String
show :: HPLuvHue -> String
$cshowList :: [HPLuvHue] -> ShowS
showList :: [HPLuvHue] -> ShowS
Show)

-- | Value in [0, 100].
newtype HPLuvPastel =
  HPLuvPastel Double
  deriving (HPLuvPastel -> HPLuvPastel -> Bool
(HPLuvPastel -> HPLuvPastel -> Bool)
-> (HPLuvPastel -> HPLuvPastel -> Bool) -> Eq HPLuvPastel
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: HPLuvPastel -> HPLuvPastel -> Bool
== :: HPLuvPastel -> HPLuvPastel -> Bool
$c/= :: HPLuvPastel -> HPLuvPastel -> Bool
/= :: HPLuvPastel -> HPLuvPastel -> Bool
Eq, Int -> HPLuvPastel -> ShowS
[HPLuvPastel] -> ShowS
HPLuvPastel -> String
(Int -> HPLuvPastel -> ShowS)
-> (HPLuvPastel -> String)
-> ([HPLuvPastel] -> ShowS)
-> Show HPLuvPastel
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> HPLuvPastel -> ShowS
showsPrec :: Int -> HPLuvPastel -> ShowS
$cshow :: HPLuvPastel -> String
show :: HPLuvPastel -> String
$cshowList :: [HPLuvPastel] -> ShowS
showList :: [HPLuvPastel] -> ShowS
Show)

-- | Value in [0, 100].
newtype HPLuvLightness =
  HPLuvLightness Double
  deriving (HPLuvLightness -> HPLuvLightness -> Bool
(HPLuvLightness -> HPLuvLightness -> Bool)
-> (HPLuvLightness -> HPLuvLightness -> Bool) -> Eq HPLuvLightness
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: HPLuvLightness -> HPLuvLightness -> Bool
== :: HPLuvLightness -> HPLuvLightness -> Bool
$c/= :: HPLuvLightness -> HPLuvLightness -> Bool
/= :: HPLuvLightness -> HPLuvLightness -> Bool
Eq, Int -> HPLuvLightness -> ShowS
[HPLuvLightness] -> ShowS
HPLuvLightness -> String
(Int -> HPLuvLightness -> ShowS)
-> (HPLuvLightness -> String)
-> ([HPLuvLightness] -> ShowS)
-> Show HPLuvLightness
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> HPLuvLightness -> ShowS
showsPrec :: Int -> HPLuvLightness -> ShowS
$cshow :: HPLuvLightness -> String
show :: HPLuvLightness -> String
$cshowList :: [HPLuvLightness] -> ShowS
showList :: [HPLuvLightness] -> ShowS
Show)

-- | Values in [0, 360]; [0, 100]; [0, 100].
data HPLuv =
  HPLuv HPLuvHue
        HPLuvPastel
        HPLuvLightness
  deriving (HPLuv -> HPLuv -> Bool
(HPLuv -> HPLuv -> Bool) -> (HPLuv -> HPLuv -> Bool) -> Eq HPLuv
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: HPLuv -> HPLuv -> Bool
== :: HPLuv -> HPLuv -> Bool
$c/= :: HPLuv -> HPLuv -> Bool
/= :: HPLuv -> HPLuv -> Bool
Eq, Int -> HPLuv -> ShowS
[HPLuv] -> ShowS
HPLuv -> String
(Int -> HPLuv -> ShowS)
-> (HPLuv -> String) -> ([HPLuv] -> ShowS) -> Show HPLuv
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> HPLuv -> ShowS
showsPrec :: Int -> HPLuv -> ShowS
$cshow :: HPLuv -> String
show :: HPLuv -> String
$cshowList :: [HPLuv] -> ShowS
showList :: [HPLuv] -> ShowS
Show)

-- | For a given lightness, return a list of 6 lines in slope-intercept
-- form that represent the bounds in CIELUV, stepping over which will
-- push a value out of the RGB gamut.
getBounds :: HSLuvLightness -> [G.Line]
getBounds :: HSLuvLightness -> [Line]
getBounds (HSLuvLightness Double
l) =
  let sub1 :: Double
sub1 = ((Double
l Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
16) Double -> Double -> Double
forall a. Floating a => a -> a -> a
** Double
3) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
1560896
      sub2 :: Double
sub2 =
        if Double
sub1 Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
epsilon
          then Double
sub1
          else Double
l Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
kappa
  in ((Double, Double, Double) -> Double -> Line)
-> [(Double, Double, Double)] -> [Double] -> [Line]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (Double -> (Double, Double, Double) -> Double -> Line
bounds Double
sub2) [(Double, Double, Double)]
m [Double
0, Double
1]
  where
    bounds :: Double -> (Double, Double, Double) -> Double -> Line
bounds Double
sub2 (Double
m1, Double
m2, Double
m3) Double
t =
      let top1 :: Double
top1 = (Double
284517 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
m1 Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
94839 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
m3) Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
sub2
          top2 :: Double
top2 =
            (Double
838422 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
m3 Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
769860 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
m2 Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
731718 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
m1) Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
l Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
sub2 Double -> Double -> Double
forall a. Num a => a -> a -> a
-
            Double
769860 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
t Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
l
          bottom :: Double
bottom = (Double
632260 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
m3 Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
126452 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
m2) Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
sub2 Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
126452 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
t
      in G.Line {slope :: Double
G.slope = Double
top1 Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
bottom, intercept :: Double
G.intercept = Double
top2 Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
bottom}

-- | For given lightness, returns the maximum chroma. Keeping the chroma value
-- below this number will ensure that for any hue, the color is within the RGB
-- gamut.
maxSafeChromaForL :: HSLuvLightness -> LCHChroma
maxSafeChromaForL :: HSLuvLightness -> LCHChroma
maxSafeChromaForL HSLuvLightness
l' =
  Double -> LCHChroma
LCHChroma (Double -> LCHChroma) -> Double -> LCHChroma
forall a b. (a -> b) -> a -> b
$ [Double] -> Double
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum ([Double] -> Double) -> [Double] -> Double
forall a b. (a -> b) -> a -> b
$ (Line -> Double) -> [Line] -> [Double]
forall a b. (a -> b) -> [a] -> [b]
map Line -> Double
G.distanceLineFromOrigin ([Line] -> [Double]) -> [Line] -> [Double]
forall a b. (a -> b) -> a -> b
$ HSLuvLightness -> [Line]
getBounds HSLuvLightness
l'

maxChromaForLH :: HSLuvLightness -> HSLuvHue -> LCHChroma
maxChromaForLH :: HSLuvLightness -> HSLuvHue -> LCHChroma
maxChromaForLH HSLuvLightness
l' (HSLuvHue Double
h) =
  let hrad :: Angle
hrad = Double -> Angle
G.Radians (Double -> Angle) -> Double -> Angle
forall a b. (a -> b) -> a -> b
$ Double
h Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
360 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
forall a. Floating a => a
pi Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
2
  in Double -> LCHChroma
LCHChroma (Double -> LCHChroma) -> ([Line] -> Double) -> [Line] -> LCHChroma
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
     [Double] -> Double
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum ([Double] -> Double) -> ([Line] -> [Double]) -> [Line] -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
     (:) (Double
1 Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
0) ([Double] -> [Double])
-> ([Line] -> [Double]) -> [Line] -> [Double]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Double -> Bool) -> [Double] -> [Double]
forall a. (a -> Bool) -> [a] -> [a]
filter (Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>= Double
0) ([Double] -> [Double])
-> ([Line] -> [Double]) -> [Line] -> [Double]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Line -> Double) -> [Line] -> [Double]
forall a b. (a -> b) -> [a] -> [b]
map (Angle -> Line -> Double
G.lengthOfRayUntilIntersect Angle
hrad) ([Line] -> LCHChroma) -> [Line] -> LCHChroma
forall a b. (a -> b) -> a -> b
$
     HSLuvLightness -> [Line]
getBounds HSLuvLightness
l'

xyzToRgb :: XYZ -> RGB
xyzToRgb :: XYZ -> RGB
xyzToRgb (XYZ (XYZX Double
x) (XYZY Double
y) (XYZZ Double
z)) =
  let [Double
r, Double
g, Double
b] = ((Double, Double, Double) -> Double)
-> [(Double, Double, Double)] -> [Double]
forall a b. (a -> b) -> [a] -> [b]
map (Double -> Double
fromLinear (Double -> Double)
-> ((Double, Double, Double) -> Double)
-> (Double, Double, Double)
-> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Double, Double, Double) -> (Double, Double, Double) -> Double
tripleDotProduct (Double
x, Double
y, Double
z)) [(Double, Double, Double)]
m
  in RGBRed -> RGBGreen -> RGBBlue -> RGB
RGB (Double -> RGBRed
RGBRed Double
r) (Double -> RGBGreen
RGBGreen Double
g) (Double -> RGBBlue
RGBBlue Double
b)

rgbToXyz :: RGB -> XYZ
rgbToXyz :: RGB -> XYZ
rgbToXyz (RGB (RGBRed Double
r) (RGBGreen Double
g) (RGBBlue Double
b)) =
  let [Double
x, Double
y, Double
z] =
        ((Double, Double, Double) -> Double)
-> [(Double, Double, Double)] -> [Double]
forall a b. (a -> b) -> [a] -> [b]
map ((Double, Double, Double) -> (Double, Double, Double) -> Double
tripleDotProduct (Double -> Double
toLinear Double
r, Double -> Double
toLinear Double
g, Double -> Double
toLinear Double
b)) [(Double, Double, Double)]
minv
  in XYZX -> XYZY -> XYZZ -> XYZ
XYZ (Double -> XYZX
XYZX Double
x) (Double -> XYZY
XYZY Double
y) (Double -> XYZZ
XYZZ Double
z)

yToL :: XYZY -> LUVLightness
yToL :: XYZY -> LUVLightness
yToL (XYZY Double
y) =
  if Double
y Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= Double
epsilon
    then Double -> LUVLightness
LUVLightness (Double -> LUVLightness) -> Double -> LUVLightness
forall a b. (a -> b) -> a -> b
$ (Double
y Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
refY) Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
kappa
    else Double -> LUVLightness
LUVLightness (Double -> LUVLightness) -> Double -> LUVLightness
forall a b. (a -> b) -> a -> b
$ Double
116 Double -> Double -> Double
forall a. Num a => a -> a -> a
* ((Double
y Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
refY) Double -> Double -> Double
forall a. Floating a => a -> a -> a
** (Double
1 Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
3)) Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
16

lToY :: LUVLightness -> XYZY
lToY :: LUVLightness -> XYZY
lToY (LUVLightness Double
l) =
  if Double
l Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= Double
8
    then Double -> XYZY
XYZY (Double -> XYZY) -> Double -> XYZY
forall a b. (a -> b) -> a -> b
$ Double
refY Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
l Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
kappa
    else Double -> XYZY
XYZY (Double -> XYZY) -> Double -> XYZY
forall a b. (a -> b) -> a -> b
$ Double
refY Double -> Double -> Double
forall a. Num a => a -> a -> a
* (((Double
l Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
16) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
116) Double -> Double -> Double
forall a. Floating a => a -> a -> a
** Double
3)

xyzToLuv :: XYZ -> LUV
xyzToLuv :: XYZ -> LUV
xyzToLuv (XYZ (XYZX Double
x) y' :: XYZY
y'@(XYZY Double
y) (XYZZ Double
z)) =
  let divider :: Double
divider = (Double
x Double -> Double -> Double
forall a. Num a => a -> a -> a
+ (Double
15 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
y) Double -> Double -> Double
forall a. Num a => a -> a -> a
+ (Double
3 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
z))
      varU :: Double
varU = (Double
4 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
x) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
divider
      varV :: Double
varV = (Double
9 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
y) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
divider
      l' :: LUVLightness
l'@(LUVLightness Double
l) = XYZY -> LUVLightness
yToL XYZY
y'
      u :: Double
u = Double
13 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
l Double -> Double -> Double
forall a. Num a => a -> a -> a
* (Double
varU Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
refU)
      v :: Double
v = Double
13 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
l Double -> Double -> Double
forall a. Num a => a -> a -> a
* (Double
varV Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
refV)
  in if Double
l Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Double
0
       then LUVLightness -> LUVU -> LUVV -> LUV
LUV (Double -> LUVLightness
LUVLightness Double
0) (Double -> LUVU
LUVU Double
0) (Double -> LUVV
LUVV Double
0)
       else LUVLightness -> LUVU -> LUVV -> LUV
LUV LUVLightness
l' (Double -> LUVU
LUVU Double
u) (Double -> LUVV
LUVV Double
v)

luvToXyz :: LUV -> XYZ
luvToXyz :: LUV -> XYZ
luvToXyz (LUV (LUVLightness Double
0) LUVU
_ LUVV
_) = XYZX -> XYZY -> XYZZ -> XYZ
XYZ (Double -> XYZX
XYZX Double
0) (Double -> XYZY
XYZY Double
0) (Double -> XYZZ
XYZZ Double
0)
luvToXyz (LUV l' :: LUVLightness
l'@(LUVLightness Double
l) (LUVU Double
u) (LUVV Double
v)) =
  let varU :: Double
varU = Double
u Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ (Double
13 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
l) Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
refU
      varV :: Double
varV = Double
v Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ (Double
13 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
l) Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
refV
      (XYZY Double
y) = LUVLightness -> XYZY
lToY LUVLightness
l'
      x :: Double
x = -(Double
9 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
y Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
varU) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ ((Double
varU Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
4) Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
varV Double -> Double -> Double
forall a. Num a => a -> a -> a
- (Double
varU Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
varV))
      z :: Double
z = (Double
9 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
y Double -> Double -> Double
forall a. Num a => a -> a -> a
- (Double
15 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
varV Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
y) Double -> Double -> Double
forall a. Num a => a -> a -> a
- (Double
varV Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
x)) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ (Double
3 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
varV)
  in XYZX -> XYZY -> XYZZ -> XYZ
XYZ (Double -> XYZX
XYZX Double
x) (Double -> XYZY
XYZY Double
y) (Double -> XYZZ
XYZZ Double
z)

luvToLch :: LUV -> LCH
luvToLch :: LUV -> LCH
luvToLch (LUV (LUVLightness Double
l) (LUVU Double
u) (LUVV Double
v)) =
  let c :: Double
c = Double -> Double
forall a. Floating a => a -> a
sqrt (Double -> Double) -> Double -> Double
forall a b. (a -> b) -> a -> b
$ Double
u Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
u Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
v Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
v
      h :: Double
h =
        if Double
c Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
0.00000001
          then Double
0
          else (Double -> Double -> Double
forall a. RealFloat a => a -> a -> a
atan2 Double
v Double
u Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
180 Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
forall a. Floating a => a
pi) Double -> Double -> Double
forall a. Real a => a -> a -> a
`mod'` Double
360
  in LCHLightness -> LCHChroma -> LCHHue -> LCH
LCH (Double -> LCHLightness
LCHLightness Double
l) (Double -> LCHChroma
LCHChroma Double
c) (Double -> LCHHue
LCHHue Double
h)

lchToLuv :: LCH -> LUV
lchToLuv :: LCH -> LUV
lchToLuv (LCH (LCHLightness Double
l) (LCHChroma Double
c) (LCHHue Double
h)) =
  let hrad :: Double
hrad = Double
h Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
360 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
2 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
forall a. Floating a => a
pi
  in LUVLightness -> LUVU -> LUVV -> LUV
LUV (Double -> LUVLightness
LUVLightness Double
l) (Double -> LUVU
LUVU (Double -> LUVU) -> Double -> LUVU
forall a b. (a -> b) -> a -> b
$ Double
c Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double -> Double
forall a. Floating a => a -> a
cos Double
hrad) (Double -> LUVV
LUVV (Double -> LUVV) -> Double -> LUVV
forall a b. (a -> b) -> a -> b
$ Double
c Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double -> Double
forall a. Floating a => a -> a
sin Double
hrad)

hsluvToLchWith :: (HSLuvLightness -> HSLuvHue -> LCHChroma) -> HSLuv -> LCH
hsluvToLchWith :: (HSLuvLightness -> HSLuvHue -> LCHChroma) -> HSLuv -> LCH
hsluvToLchWith HSLuvLightness -> HSLuvHue -> LCHChroma
f (HSLuv h' :: HSLuvHue
h'@(HSLuvHue Double
h) (HSLuvSaturation Double
s) l' :: HSLuvLightness
l'@(HSLuvLightness Double
l))
  | Double
l Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
99.9999999 = LCHLightness -> LCHChroma -> LCHHue -> LCH
LCH (Double -> LCHLightness
LCHLightness Double
100) (Double -> LCHChroma
LCHChroma Double
0) (Double -> LCHHue
LCHHue Double
h)
  | Double
l Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
0.00000001 = LCHLightness -> LCHChroma -> LCHHue -> LCH
LCH (Double -> LCHLightness
LCHLightness Double
0) (Double -> LCHChroma
LCHChroma Double
0) (Double -> LCHHue
LCHHue Double
h)
  | Bool
otherwise =
    let (LCHChroma Double
c) = HSLuvLightness -> HSLuvHue -> LCHChroma
f HSLuvLightness
l' HSLuvHue
h'
    in LCHLightness -> LCHChroma -> LCHHue -> LCH
LCH (Double -> LCHLightness
LCHLightness Double
l) (Double -> LCHChroma
LCHChroma (Double
c Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
100 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
s)) (Double -> LCHHue
LCHHue Double
h)

lchToHsluvWith :: (HSLuvLightness -> HSLuvHue -> LCHChroma) -> LCH -> HSLuv
lchToHsluvWith :: (HSLuvLightness -> HSLuvHue -> LCHChroma) -> LCH -> HSLuv
lchToHsluvWith HSLuvLightness -> HSLuvHue -> LCHChroma
f (LCH (LCHLightness Double
l) (LCHChroma Double
c) (LCHHue Double
h))
  | Double
l Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
99.9999999 = HSLuvHue -> HSLuvSaturation -> HSLuvLightness -> HSLuv
HSLuv (Double -> HSLuvHue
HSLuvHue Double
h) (Double -> HSLuvSaturation
HSLuvSaturation Double
0) (Double -> HSLuvLightness
HSLuvLightness Double
100)
  | Double
l Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
0.00000001 = HSLuvHue -> HSLuvSaturation -> HSLuvLightness -> HSLuv
HSLuv (Double -> HSLuvHue
HSLuvHue Double
h) (Double -> HSLuvSaturation
HSLuvSaturation Double
0) (Double -> HSLuvLightness
HSLuvLightness Double
0)
  | Bool
otherwise =
    let (LCHChroma Double
maxC) = HSLuvLightness -> HSLuvHue -> LCHChroma
f (Double -> HSLuvLightness
HSLuvLightness Double
l) (Double -> HSLuvHue
HSLuvHue Double
h)
    in HSLuvHue -> HSLuvSaturation -> HSLuvLightness -> HSLuv
HSLuv (Double -> HSLuvHue
HSLuvHue Double
h) (Double -> HSLuvSaturation
HSLuvSaturation (Double
c Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
maxC Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
100)) (Double -> HSLuvLightness
HSLuvLightness Double
l)

hsluvToLch :: HSLuv -> LCH
hsluvToLch :: HSLuv -> LCH
hsluvToLch = (HSLuvLightness -> HSLuvHue -> LCHChroma) -> HSLuv -> LCH
hsluvToLchWith HSLuvLightness -> HSLuvHue -> LCHChroma
maxChromaForLH

lchToHsluv :: LCH -> HSLuv
lchToHsluv :: LCH -> HSLuv
lchToHsluv = (HSLuvLightness -> HSLuvHue -> LCHChroma) -> LCH -> HSLuv
lchToHsluvWith HSLuvLightness -> HSLuvHue -> LCHChroma
maxChromaForLH

hpluvToLch :: HPLuv -> LCH
hpluvToLch :: HPLuv -> LCH
hpluvToLch (HPLuv (HPLuvHue Double
h) (HPLuvPastel Double
p) (HPLuvLightness Double
l)) =
  (HSLuvLightness -> HSLuvHue -> LCHChroma) -> HSLuv -> LCH
hsluvToLchWith
    (\HSLuvLightness
l' HSLuvHue
_ -> HSLuvLightness -> LCHChroma
maxSafeChromaForL HSLuvLightness
l')
    (HSLuvHue -> HSLuvSaturation -> HSLuvLightness -> HSLuv
HSLuv (Double -> HSLuvHue
HSLuvHue Double
h) (Double -> HSLuvSaturation
HSLuvSaturation Double
p) (Double -> HSLuvLightness
HSLuvLightness Double
l))

lchToHpluv :: LCH -> HPLuv
lchToHpluv :: LCH -> HPLuv
lchToHpluv LCH
lch =
  let (HSLuv (HSLuvHue Double
h) (HSLuvSaturation Double
s) (HSLuvLightness Double
l)) =
        (HSLuvLightness -> HSLuvHue -> LCHChroma) -> LCH -> HSLuv
lchToHsluvWith (\HSLuvLightness
l' HSLuvHue
_ -> HSLuvLightness -> LCHChroma
maxSafeChromaForL HSLuvLightness
l') LCH
lch
  in HPLuvHue -> HPLuvPastel -> HPLuvLightness -> HPLuv
HPLuv (Double -> HPLuvHue
HPLuvHue Double
h) (Double -> HPLuvPastel
HPLuvPastel Double
s) (Double -> HPLuvLightness
HPLuvLightness Double
l)

rgbToHex :: RGB -> String
rgbToHex :: RGB -> String
rgbToHex (RGB (RGBRed Double
r) (RGBGreen Double
g) (RGBBlue Double
b)) =
  String
"#" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Double -> String
forall {a}. RealFrac a => a -> String
toHex Double
r String -> ShowS
forall a. [a] -> [a] -> [a]
++ Double -> String
forall {a}. RealFrac a => a -> String
toHex Double
g String -> ShowS
forall a. [a] -> [a] -> [a]
++ Double -> String
forall {a}. RealFrac a => a -> String
toHex Double
b
  where
    leftPad :: [a] -> Int -> a -> [a]
leftPad [a]
s Int
n a
c = Int -> a -> [a]
forall a. Int -> a -> [a]
replicate (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- [a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
s)) a
c [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
s
    toHex :: a -> String
toHex a
c = String -> Int -> Char -> String
forall {a}. [a] -> Int -> a -> [a]
leftPad (Integer -> ShowS
forall a. Integral a => a -> ShowS
showHex (a -> Integer
forall b. Integral b => a -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (a -> Integer) -> a -> Integer
forall a b. (a -> b) -> a -> b
$ a
c a -> a -> a
forall a. Num a => a -> a -> a
* a
255 :: Integer) String
"") Int
2 Char
'0'

hexToRgb :: String -> Maybe RGB
hexToRgb :: String -> Maybe RGB
hexToRgb [Char
'#', Char
a, Char
b, Char
c, Char
d, Char
e, Char
f] =
  case (ReadS Double
forall a. (Eq a, Num a) => ReadS a
readHex [Char
a, Char
b], ReadS Double
forall a. (Eq a, Num a) => ReadS a
readHex [Char
c, Char
d], ReadS Double
forall a. (Eq a, Num a) => ReadS a
readHex [Char
e, Char
f]) of
    ([(Double
rr, String
rr')], [(Double
rg, String
rg')], [(Double
rb, String
rb')]) ->
      if (String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
"") [String
rr', String
rg', String
rb']
        then Maybe RGB
forall a. Maybe a
Nothing
        else RGB -> Maybe RGB
forall a. a -> Maybe a
Just (RGB -> Maybe RGB) -> RGB -> Maybe RGB
forall a b. (a -> b) -> a -> b
$
             RGBRed -> RGBGreen -> RGBBlue -> RGB
RGB (Double -> RGBRed
RGBRed (Double
rr Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
255)) (Double -> RGBGreen
RGBGreen (Double
rg Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
255)) (Double -> RGBBlue
RGBBlue (Double
rb Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
255))
    ([(Double, String)], [(Double, String)], [(Double, String)])
_ -> Maybe RGB
forall a. Maybe a
Nothing
hexToRgb String
_ = Maybe RGB
forall a. Maybe a
Nothing

lchToRgb :: LCH -> RGB
lchToRgb :: LCH -> RGB
lchToRgb = XYZ -> RGB
xyzToRgb (XYZ -> RGB) -> (LCH -> XYZ) -> LCH -> RGB
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LUV -> XYZ
luvToXyz (LUV -> XYZ) -> (LCH -> LUV) -> LCH -> XYZ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LCH -> LUV
lchToLuv

rgbToLch :: RGB -> LCH
rgbToLch :: RGB -> LCH
rgbToLch = LUV -> LCH
luvToLch (LUV -> LCH) -> (RGB -> LUV) -> RGB -> LCH
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XYZ -> LUV
xyzToLuv (XYZ -> LUV) -> (RGB -> XYZ) -> RGB -> LUV
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RGB -> XYZ
rgbToXyz

hsluvToRgb :: HSLuv -> RGB
hsluvToRgb :: HSLuv -> RGB
hsluvToRgb = LCH -> RGB
lchToRgb (LCH -> RGB) -> (HSLuv -> LCH) -> HSLuv -> RGB
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HSLuv -> LCH
hsluvToLch

rgbToHsluv :: RGB -> HSLuv
rgbToHsluv :: RGB -> HSLuv
rgbToHsluv = LCH -> HSLuv
lchToHsluv (LCH -> HSLuv) -> (RGB -> LCH) -> RGB -> HSLuv
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RGB -> LCH
rgbToLch

hpluvToRgb :: HPLuv -> RGB
hpluvToRgb :: HPLuv -> RGB
hpluvToRgb = LCH -> RGB
lchToRgb (LCH -> RGB) -> (HPLuv -> LCH) -> HPLuv -> RGB
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HPLuv -> LCH
hpluvToLch

rgbToHpluv :: RGB -> HPLuv
rgbToHpluv :: RGB -> HPLuv
rgbToHpluv = LCH -> HPLuv
lchToHpluv (LCH -> HPLuv) -> (RGB -> LCH) -> RGB -> HPLuv
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RGB -> LCH
rgbToLch

hsluvToHex :: HSLuv -> String
hsluvToHex :: HSLuv -> String
hsluvToHex = RGB -> String
rgbToHex (RGB -> String) -> (HSLuv -> RGB) -> HSLuv -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HSLuv -> RGB
hsluvToRgb

hpluvToHex :: HPLuv -> String
hpluvToHex :: HPLuv -> String
hpluvToHex = RGB -> String
rgbToHex (RGB -> String) -> (HPLuv -> RGB) -> HPLuv -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HPLuv -> RGB
hpluvToRgb

hexToHsluv :: String -> Maybe HSLuv
hexToHsluv :: String -> Maybe HSLuv
hexToHsluv = (RGB -> HSLuv) -> Maybe RGB -> Maybe HSLuv
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap RGB -> HSLuv
rgbToHsluv (Maybe RGB -> Maybe HSLuv)
-> (String -> Maybe RGB) -> String -> Maybe HSLuv
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe RGB
hexToRgb

hexToHpluv :: String -> Maybe HPLuv
hexToHpluv :: String -> Maybe HPLuv
hexToHpluv = (RGB -> HPLuv) -> Maybe RGB -> Maybe HPLuv
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap RGB -> HPLuv
rgbToHpluv (Maybe RGB -> Maybe HPLuv)
-> (String -> Maybe RGB) -> String -> Maybe HPLuv
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe RGB
hexToRgb

hsluvToColour :: HSLuv -> Colour Double
hsluvToColour :: HSLuv -> Colour Double
hsluvToColour HSLuv
hsluv =
  let XYZ (XYZX Double
x) (XYZY Double
y) (XYZZ Double
z) = LUV -> XYZ
luvToXyz (LUV -> XYZ) -> (HSLuv -> LUV) -> HSLuv -> XYZ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LCH -> LUV
lchToLuv (LCH -> LUV) -> (HSLuv -> LCH) -> HSLuv -> LUV
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HSLuv -> LCH
hsluvToLch (HSLuv -> XYZ) -> HSLuv -> XYZ
forall a b. (a -> b) -> a -> b
$ HSLuv
hsluv
  in Double -> Double -> Double -> Colour Double
forall a. Fractional a => a -> a -> a -> Colour a
cieXYZ Double
x Double
y Double
z

colourToHsluv :: Colour Double -> HSLuv
colourToHsluv :: Colour Double -> HSLuv
colourToHsluv Colour Double
colour =
  let (Double
x, Double
y, Double
z) = Colour Double -> (Double, Double, Double)
forall a. Fractional a => Colour a -> (a, a, a)
cieXYZView Colour Double
colour
  in LCH -> HSLuv
lchToHsluv (LCH -> HSLuv) -> (XYZ -> LCH) -> XYZ -> HSLuv
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LUV -> LCH
luvToLch (LUV -> LCH) -> (XYZ -> LUV) -> XYZ -> LCH
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XYZ -> LUV
xyzToLuv (XYZ -> HSLuv) -> XYZ -> HSLuv
forall a b. (a -> b) -> a -> b
$ XYZX -> XYZY -> XYZZ -> XYZ
XYZ (Double -> XYZX
XYZX Double
x) (Double -> XYZY
XYZY Double
y) (Double -> XYZZ
XYZZ Double
z)

hpluvToColour :: HPLuv -> Colour Double
hpluvToColour :: HPLuv -> Colour Double
hpluvToColour HPLuv
hsluv =
  let XYZ (XYZX Double
x) (XYZY Double
y) (XYZZ Double
z) = LUV -> XYZ
luvToXyz (LUV -> XYZ) -> (HPLuv -> LUV) -> HPLuv -> XYZ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LCH -> LUV
lchToLuv (LCH -> LUV) -> (HPLuv -> LCH) -> HPLuv -> LUV
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HPLuv -> LCH
hpluvToLch (HPLuv -> XYZ) -> HPLuv -> XYZ
forall a b. (a -> b) -> a -> b
$ HPLuv
hsluv
  in Double -> Double -> Double -> Colour Double
forall a. Fractional a => a -> a -> a -> Colour a
cieXYZ Double
x Double
y Double
z

colourToHpluv :: Colour Double -> HPLuv
colourToHpluv :: Colour Double -> HPLuv
colourToHpluv Colour Double
colour =
  let (Double
x, Double
y, Double
z) = Colour Double -> (Double, Double, Double)
forall a. Fractional a => Colour a -> (a, a, a)
cieXYZView Colour Double
colour
  in LCH -> HPLuv
lchToHpluv (LCH -> HPLuv) -> (XYZ -> LCH) -> XYZ -> HPLuv
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LUV -> LCH
luvToLch (LUV -> LCH) -> (XYZ -> LUV) -> XYZ -> LCH
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XYZ -> LUV
xyzToLuv (XYZ -> HPLuv) -> XYZ -> HPLuv
forall a b. (a -> b) -> a -> b
$ XYZX -> XYZY -> XYZZ -> XYZ
XYZ (Double -> XYZX
XYZX Double
x) (Double -> XYZY
XYZY Double
y) (Double -> XYZZ
XYZZ Double
z)