{-# LANGUAGE RecordWildCards #-}
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)
data ColorComponents = ColorComponents
{ colorUnpack :: Colour Double -> (Double, Double, Double)
, colorPack :: Double -> Double -> Double -> Colour Double
}
rgbComponents :: ColorComponents
rgbComponents = ColorComponents rgbUnpack sRGB
where
rgbUnpack :: Colour Double -> (Double, Double, Double)
rgbUnpack c =
case toSRGB c of
RGB r g b -> (r,g,b)
hsvComponents :: ColorComponents
hsvComponents = ColorComponents unpack pack
where
unpack = hsvView.toSRGB
pack a b c = uncurryRGB sRGB $ hsv a b c
labComponents :: ColorComponents
labComponents = ColorComponents unpack pack
where
unpack = cieLABView d65
pack = cieLAB d65
xyzComponents :: ColorComponents
xyzComponents = ColorComponents cieXYZView cieXYZ
lchComponents :: ColorComponents
lchComponents = ColorComponents unpack pack
where
toDeg,toRad :: Double -> Double
toRad deg = deg/180 * pi
toDeg rad = rad/pi * 180
unpack :: Colour Double -> (Double, Double, Double)
unpack color =
let (l,a,b) = cieLABView d65 color
c = sqrt (a*a + b*b)
h :: Double
h = (toDeg(atan2 b a) + 360) `mod'` 360
isZero = round (c*10000) == (0::Integer)
in (l, c, if isZero then 0/0 else h)
pack l c h =
cieLAB d65 l (cos (toRad h) * c) (sin (toRad h) * c)
interpolate :: ColorComponents -> Colour Double -> Colour Double -> (Double -> Colour Double)
interpolate ColorComponents{..} from to = \d ->
colorPack (a1 + (a2-a1)*d) (b1 + (b2-b1)*d) (c1 + (c2-c1)*d)
where
(a1,b1,c1) = colorUnpack from
(a2,b2,c2) = colorUnpack to
interpolateRGB8 :: ColorComponents -> PixelRGB8 -> PixelRGB8 -> (Double -> PixelRGB8)
interpolateRGB8 comps from to = toRGB8 . interpolate comps (fromRGB8 from) (fromRGB8 to)
interpolateRGBA8 :: ColorComponents -> PixelRGBA8 -> PixelRGBA8 -> (Double -> PixelRGBA8)
interpolateRGBA8 comps from to = \t ->
case interp t of
PixelRGB8 r g b ->
let alpha = fromToS (fromIntegral $ pixelOpacity from) (fromIntegral $ pixelOpacity to) t
in PixelRGBA8 r g b (round alpha)
where
interp = interpolateRGB8 comps (dropTransparency from) (dropTransparency to)
toRGB8 :: Colour Double -> PixelRGB8
toRGB8 c = PixelRGB8 r g b
where
RGB r g b = toSRGBBounded c
fromRGB8 :: PixelRGB8 -> Colour Double
fromRGB8 (PixelRGB8 r g b) = sRGB24 r g b