never executed always true always false

    1 {-# LANGUAGE RecordWildCards #-}
    2 module Reanimate.ColorComponents where
    3 
    4 import           Codec.Picture
    5 import           Codec.Picture.Types
    6 import           Data.Colour
    7 import           Data.Colour.CIE
    8 import           Data.Colour.CIE.Illuminant (d65)
    9 import           Data.Colour.RGBSpace
   10 import           Data.Colour.RGBSpace.HSV
   11 import           Data.Colour.SRGB
   12 import           Data.Fixed
   13 import           Reanimate.Ease
   14 
   15 data ColorComponents = ColorComponents
   16   { colorUnpack :: Colour Double -> (Double, Double, Double)
   17   , colorPack   :: Double -> Double -> Double -> Colour Double }
   18 
   19 -- | > interpolate rgbComponents yellow blue
   20 --
   21 --   <<docs/gifs/doc_rgbComponents.gif>>
   22 rgbComponents :: ColorComponents
   23 rgbComponents = ColorComponents rgbUnpack sRGB
   24   where
   25     rgbUnpack :: Colour Double -> (Double, Double, Double)
   26     rgbUnpack c =
   27       case toSRGB c of
   28         RGB r g b -> (r,g,b)
   29 
   30 -- | > interpolate hsvComponents yellow blue
   31 --
   32 --   <<docs/gifs/doc_hsvComponents.gif>>
   33 hsvComponents :: ColorComponents
   34 hsvComponents = ColorComponents unpack pack
   35   where
   36     unpack = hsvView.toSRGB
   37     pack a b c = uncurryRGB sRGB $ hsv a b c
   38 
   39 -- | > interpolate labComponents yellow blue
   40 --
   41 --   <<docs/gifs/doc_labComponents.gif>>
   42 labComponents :: ColorComponents
   43 labComponents = ColorComponents unpack pack
   44   where
   45     unpack = cieLABView d65
   46     pack = cieLAB d65
   47 
   48 -- | > interpolate xyzComponents yellow blue
   49 --
   50 --   <<docs/gifs/doc_xyzComponents.gif>>
   51 xyzComponents :: ColorComponents
   52 xyzComponents = ColorComponents cieXYZView cieXYZ
   53 
   54 -- | > interpolate lchComponents yellow blue
   55 --
   56 --   <<docs/gifs/doc_lchComponents.gif>>
   57 lchComponents :: ColorComponents
   58 lchComponents = ColorComponents unpack pack
   59   where
   60     toDeg,toRad :: Double -> Double
   61     toRad deg = deg/180 * pi
   62     toDeg rad = rad/pi * 180
   63     unpack :: Colour Double -> (Double, Double, Double)
   64     unpack color =
   65       let (l,a,b) = cieLABView d65 color
   66           c = sqrt (a*a + b*b)
   67           h :: Double
   68           h = (toDeg(atan2 b a) + 360) `mod'` 360
   69           isZero = round (c*10000) == (0::Integer)
   70       in (l, c, if isZero then 0/0 else h)
   71     pack l c h =
   72       cieLAB d65 l (cos (toRad h) * c) (sin (toRad h) * c)
   73 
   74 interpolate :: ColorComponents -> Colour Double -> Colour Double -> (Double -> Colour Double)
   75 interpolate ColorComponents{..} from to = \d ->
   76     colorPack (a1 + (a2-a1)*d) (b1 + (b2-b1)*d) (c1 + (c2-c1)*d)
   77   where
   78     (a1,b1,c1) = colorUnpack from
   79     (a2,b2,c2) = colorUnpack to
   80 
   81 interpolateRGB8 :: ColorComponents -> PixelRGB8 -> PixelRGB8 -> (Double -> PixelRGB8)
   82 interpolateRGB8 comps from to = toRGB8 . interpolate comps (fromRGB8 from) (fromRGB8 to)
   83 
   84 interpolateRGBA8 :: ColorComponents -> PixelRGBA8 -> PixelRGBA8 -> (Double -> PixelRGBA8)
   85 interpolateRGBA8 comps from to = \t ->
   86   case interp t of
   87     PixelRGB8 r g b ->
   88       let alpha = fromToS (fromIntegral $ pixelOpacity from) (fromIntegral $ pixelOpacity to) t
   89       in PixelRGBA8 r g b (round alpha)
   90   where
   91     interp = interpolateRGB8 comps (dropTransparency from) (dropTransparency to)
   92 
   93 toRGB8 :: Colour Double -> PixelRGB8
   94 toRGB8 c = PixelRGB8 r g b
   95   where
   96     RGB r g b = toSRGBBounded c
   97 
   98 fromRGB8 :: PixelRGB8 -> Colour Double
   99 fromRGB8 (PixelRGB8 r g b) = sRGB24 r g b