{-# LANGUAGE RecordWildCards #-}
{- |
  Colors are three dimensional and can be projected into many color spaces
  with different properties.

  Interpolating directly in the RGB color space is unintuitive and rarely useful.
  If you want to transition through color, you most likely want either the XYZ space
  (for physically accurate color transitions) or the LAB space (for esthetically
  pleasing colors).
-}
module Reanimate.ColorComponents
  ( ColorComponents(..)
  , rgbComponents
  , hsvComponents
  , labComponents
  , xyzComponents
  , lchComponents
  , interpolate
  , interpolateRGB8
  , interpolateRGBA8
  , toRGB8
  , fromRGB8
  ) where

import           Codec.Picture              (Pixel (pixelOpacity), PixelRGB8 (..), PixelRGBA8 (..))
import           Codec.Picture.Types        (TransparentPixel (dropTransparency))
import           Data.Colour                (Colour)
import           Data.Colour.CIE            (cieLAB, cieLABView, cieXYZ, cieXYZView)
import           Data.Colour.CIE.Illuminant (d65)
import           Data.Colour.RGBSpace       (RGB (RGB), uncurryRGB)
import           Data.Colour.RGBSpace.HSV   (hsv, hsvView)
import           Data.Colour.SRGB           (sRGB, sRGB24, toSRGB, toSRGBBounded)
import           Data.Fixed                 (mod')
import           Reanimate.Ease             (fromToS)

-- | Constructor and destructor for color's three components.
data ColorComponents = ColorComponents
  { ColorComponents -> Colour Double -> (Double, Double, Double)
colorUnpack :: Colour Double -> (Double, Double, Double)
    -- ^ Unpack a color into its three components.
  , ColorComponents -> Double -> Double -> Double -> Colour Double
colorPack   :: Double -> Double -> Double -> Colour Double
    -- ^ Restore a color from three coordinates.
  }

-- | > interpolate rgbComponents yellow blue
--
--   <<docs/gifs/doc_rgbComponents.gif>>
rgbComponents :: ColorComponents
rgbComponents :: ColorComponents
rgbComponents = (Colour Double -> (Double, Double, Double))
-> (Double -> Double -> Double -> Colour Double) -> ColorComponents
ColorComponents Colour Double -> (Double, Double, Double)
rgbUnpack Double -> Double -> Double -> Colour Double
forall b. (Ord b, Floating b) => b -> b -> b -> Colour b
sRGB
  where
    rgbUnpack :: Colour Double -> (Double, Double, Double)
    rgbUnpack :: Colour Double -> (Double, Double, Double)
rgbUnpack Colour Double
c =
      case Colour Double -> RGB Double
forall b. (Ord b, Floating b) => Colour b -> RGB b
toSRGB Colour Double
c of
        RGB Double
r Double
g Double
b -> (Double
r,Double
g,Double
b)

-- | > interpolate hsvComponents yellow blue
--
--   <<docs/gifs/doc_hsvComponents.gif>>
hsvComponents :: ColorComponents
hsvComponents :: ColorComponents
hsvComponents = (Colour Double -> (Double, Double, Double))
-> (Double -> Double -> Double -> Colour Double) -> ColorComponents
ColorComponents Colour Double -> (Double, Double, Double)
unpack Double -> Double -> Double -> Colour Double
forall b. (Floating b, RealFrac b) => b -> b -> b -> Colour b
pack
  where
    unpack :: Colour Double -> (Double, Double, Double)
unpack = RGB Double -> (Double, Double, Double)
forall a. (Fractional a, Ord a) => RGB a -> (a, a, a)
hsvView(RGB Double -> (Double, Double, Double))
-> (Colour Double -> RGB Double)
-> Colour Double
-> (Double, Double, Double)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Colour Double -> RGB Double
forall b. (Ord b, Floating b) => Colour b -> RGB b
toSRGB
    pack :: b -> b -> b -> Colour b
pack b
a b
b b
c = (b -> b -> b -> Colour b) -> RGB b -> Colour b
forall a b. (a -> a -> a -> b) -> RGB a -> b
uncurryRGB b -> b -> b -> Colour b
forall b. (Ord b, Floating b) => b -> b -> b -> Colour b
sRGB (RGB b -> Colour b) -> RGB b -> Colour b
forall a b. (a -> b) -> a -> b
$ b -> b -> b -> RGB b
forall a. (RealFrac a, Ord a) => a -> a -> a -> RGB a
hsv b
a b
b b
c

-- | > interpolate labComponents yellow blue
--
--   <<docs/gifs/doc_labComponents.gif>>
labComponents :: ColorComponents
labComponents :: ColorComponents
labComponents = (Colour Double -> (Double, Double, Double))
-> (Double -> Double -> Double -> Colour Double) -> ColorComponents
ColorComponents Colour Double -> (Double, Double, Double)
unpack Double -> Double -> Double -> Colour Double
pack
  where
    unpack :: Colour Double -> (Double, Double, Double)
unpack = Chromaticity Double -> Colour Double -> (Double, Double, Double)
forall a.
(Ord a, Floating a) =>
Chromaticity a -> Colour a -> (a, a, a)
cieLABView Chromaticity Double
forall a. Fractional a => Chromaticity a
d65
    pack :: Double -> Double -> Double -> Colour Double
pack = Chromaticity Double -> Double -> Double -> Double -> Colour Double
forall a.
(Ord a, Floating a) =>
Chromaticity a -> a -> a -> a -> Colour a
cieLAB Chromaticity Double
forall a. Fractional a => Chromaticity a
d65

-- | > interpolate xyzComponents yellow blue
--
--   <<docs/gifs/doc_xyzComponents.gif>>
xyzComponents :: ColorComponents
xyzComponents :: ColorComponents
xyzComponents = (Colour Double -> (Double, Double, Double))
-> (Double -> Double -> Double -> Colour Double) -> ColorComponents
ColorComponents Colour Double -> (Double, Double, Double)
forall a. Fractional a => Colour a -> (a, a, a)
cieXYZView Double -> Double -> Double -> Colour Double
forall a. Fractional a => a -> a -> a -> Colour a
cieXYZ

-- | > interpolate lchComponents yellow blue
--
--   <<docs/gifs/doc_lchComponents.gif>>
lchComponents :: ColorComponents
lchComponents :: ColorComponents
lchComponents = (Colour Double -> (Double, Double, Double))
-> (Double -> Double -> Double -> Colour Double) -> ColorComponents
ColorComponents Colour Double -> (Double, Double, Double)
unpack Double -> Double -> Double -> Colour Double
pack
  where
    toDeg,toRad :: Double -> Double
    toRad :: Double -> Double
toRad Double
deg = Double
degDouble -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
180 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
forall a. Floating a => a
pi
    toDeg :: Double -> Double
toDeg Double
rad = Double
radDouble -> 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
180
    unpack :: Colour Double -> (Double, Double, Double)
    unpack :: Colour Double -> (Double, Double, Double)
unpack Colour Double
color =
      let (Double
l,Double
a,Double
b) = Chromaticity Double -> Colour Double -> (Double, Double, Double)
forall a.
(Ord a, Floating a) =>
Chromaticity a -> Colour a -> (a, a, a)
cieLABView Chromaticity Double
forall a. Fractional a => Chromaticity a
d65 Colour Double
color
          c :: Double
c = Double -> Double
forall a. Floating a => a -> a
sqrt (Double
aDouble -> Double -> Double
forall a. Num a => a -> a -> a
*Double
a Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
bDouble -> Double -> Double
forall a. Num a => a -> a -> a
*Double
b)
          h :: Double
          h :: Double
h = (Double -> Double
toDeg(Double -> Double -> Double
forall a. RealFloat a => a -> a -> a
atan2 Double
b Double
a) Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
360) Double -> Double -> Double
forall a. Real a => a -> a -> a
`mod'` Double
360
          isZero :: Bool
isZero = Double -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
round (Double
cDouble -> Double -> Double
forall a. Num a => a -> a -> a
*Double
10000) Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== (Integer
0::Integer)
      in (Double
l, Double
c, if Bool
isZero then Double
0Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
0 else Double
h)
    pack :: Double -> Double -> Double -> Colour Double
pack Double
l Double
c Double
h =
      Chromaticity Double -> Double -> Double -> Double -> Colour Double
forall a.
(Ord a, Floating a) =>
Chromaticity a -> a -> a -> a -> Colour a
cieLAB Chromaticity Double
forall a. Fractional a => Chromaticity a
d65 Double
l (Double -> Double
forall a. Floating a => a -> a
cos (Double -> Double
toRad Double
h) Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
c) (Double -> Double
forall a. Floating a => a -> a
sin (Double -> Double
toRad Double
h) Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
c)

-- | Smoothly interpolate between two colors using the given color components.
interpolate :: ColorComponents -> Colour Double -> Colour Double -> (Double -> Colour Double)
interpolate :: ColorComponents
-> Colour Double -> Colour Double -> Double -> Colour Double
interpolate ColorComponents{Double -> Double -> Double -> Colour Double
Colour Double -> (Double, Double, Double)
colorPack :: Double -> Double -> Double -> Colour Double
colorUnpack :: Colour Double -> (Double, Double, Double)
colorPack :: ColorComponents -> Double -> Double -> Double -> Colour Double
colorUnpack :: ColorComponents -> Colour Double -> (Double, Double, Double)
..} Colour Double
from Colour Double
to = \Double
d ->
    Double -> Double -> Double -> Colour Double
colorPack (Double
a1 Double -> Double -> Double
forall a. Num a => a -> a -> a
+ (Double
a2Double -> Double -> Double
forall a. Num a => a -> a -> a
-Double
a1)Double -> Double -> Double
forall a. Num a => a -> a -> a
*Double
d) (Double
b1 Double -> Double -> Double
forall a. Num a => a -> a -> a
+ (Double
b2Double -> Double -> Double
forall a. Num a => a -> a -> a
-Double
b1)Double -> Double -> Double
forall a. Num a => a -> a -> a
*Double
d) (Double
c1 Double -> Double -> Double
forall a. Num a => a -> a -> a
+ (Double
c2Double -> Double -> Double
forall a. Num a => a -> a -> a
-Double
c1)Double -> Double -> Double
forall a. Num a => a -> a -> a
*Double
d)
  where
    (Double
a1,Double
b1,Double
c1) = Colour Double -> (Double, Double, Double)
colorUnpack Colour Double
from
    (Double
a2,Double
b2,Double
c2) = Colour Double -> (Double, Double, Double)
colorUnpack Colour Double
to

-- | Convenience interpolation function for RGB8 values.
interpolateRGB8 :: ColorComponents -> PixelRGB8 -> PixelRGB8 -> (Double -> PixelRGB8)
interpolateRGB8 :: ColorComponents -> PixelRGB8 -> PixelRGB8 -> Double -> PixelRGB8
interpolateRGB8 ColorComponents
comps PixelRGB8
from PixelRGB8
to = Colour Double -> PixelRGB8
toRGB8 (Colour Double -> PixelRGB8)
-> (Double -> Colour Double) -> Double -> PixelRGB8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ColorComponents
-> Colour Double -> Colour Double -> Double -> Colour Double
interpolate ColorComponents
comps (PixelRGB8 -> Colour Double
fromRGB8 PixelRGB8
from) (PixelRGB8 -> Colour Double
fromRGB8 PixelRGB8
to)

-- | Convenience interpolation function for RGBA8 values.
interpolateRGBA8 :: ColorComponents -> PixelRGBA8 -> PixelRGBA8 -> (Double -> PixelRGBA8)
interpolateRGBA8 :: ColorComponents -> PixelRGBA8 -> PixelRGBA8 -> Double -> PixelRGBA8
interpolateRGBA8 ColorComponents
comps PixelRGBA8
from PixelRGBA8
to = \Double
t ->
  case Double -> PixelRGB8
interp Double
t of
    PixelRGB8 Pixel8
r Pixel8
g Pixel8
b ->
      let alpha :: Double
alpha = Double -> Double -> Double -> Double
fromToS (Pixel8 -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Pixel8 -> Double) -> Pixel8 -> Double
forall a b. (a -> b) -> a -> b
$ PixelRGBA8 -> PixelBaseComponent PixelRGBA8
forall a. Pixel a => a -> PixelBaseComponent a
pixelOpacity PixelRGBA8
from) (Pixel8 -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Pixel8 -> Double) -> Pixel8 -> Double
forall a b. (a -> b) -> a -> b
$ PixelRGBA8 -> PixelBaseComponent PixelRGBA8
forall a. Pixel a => a -> PixelBaseComponent a
pixelOpacity PixelRGBA8
to) Double
t
      in Pixel8 -> Pixel8 -> Pixel8 -> Pixel8 -> PixelRGBA8
PixelRGBA8 Pixel8
r Pixel8
g Pixel8
b (Double -> Pixel8
forall a b. (RealFrac a, Integral b) => a -> b
round Double
alpha)
  where
    interp :: Double -> PixelRGB8
interp = ColorComponents -> PixelRGB8 -> PixelRGB8 -> Double -> PixelRGB8
interpolateRGB8 ColorComponents
comps (PixelRGBA8 -> PixelRGB8
forall a b. TransparentPixel a b => a -> b
dropTransparency PixelRGBA8
from) (PixelRGBA8 -> PixelRGB8
forall a b. TransparentPixel a b => a -> b
dropTransparency PixelRGBA8
to)

-- | Convenience function for expressing a color as an RGB8 value.
toRGB8 :: Colour Double -> PixelRGB8
toRGB8 :: Colour Double -> PixelRGB8
toRGB8 Colour Double
c = Pixel8 -> Pixel8 -> Pixel8 -> PixelRGB8
PixelRGB8 Pixel8
r Pixel8
g Pixel8
b
  where
    RGB Pixel8
r Pixel8
g Pixel8
b = Colour Double -> RGB Pixel8
forall b a.
(RealFrac b, Floating b, Integral a, Bounded a) =>
Colour b -> RGB a
toSRGBBounded Colour Double
c

-- | Convenience function for expressing an RGB8 value as a color.
fromRGB8 :: PixelRGB8 -> Colour Double
fromRGB8 :: PixelRGB8 -> Colour Double
fromRGB8 (PixelRGB8 Pixel8
r Pixel8
g Pixel8
b) = Pixel8 -> Pixel8 -> Pixel8 -> Colour Double
forall b.
(Ord b, Floating b) =>
Pixel8 -> Pixel8 -> Pixel8 -> Colour b
sRGB24 Pixel8
r Pixel8
g Pixel8
b