never executed always true always false

    1 {-# LANGUAGE RecordWildCards #-}
    2 {- |
    3   Colors are three dimensional and can be projected into many color spaces
    4   with different properties.
    5 
    6   Interpolating directly in the RGB color space is unintuitive and rarely useful.
    7   If you want to transition through color, you most likely want either the XYZ space
    8   (for physically accurate color transitions) or the LAB space (for esthetically
    9   pleasing colors).
   10 -}
   11 module Reanimate.ColorComponents
   12   ( ColorComponents(..)
   13   , rgbComponents
   14   , hsvComponents
   15   , labComponents
   16   , xyzComponents
   17   , lchComponents
   18   , interpolate
   19   , interpolateRGB8
   20   , interpolateRGBA8
   21   , toRGB8
   22   , fromRGB8
   23   ) where
   24 
   25 import           Codec.Picture
   26 import           Codec.Picture.Types
   27 import           Data.Colour
   28 import           Data.Colour.CIE
   29 import           Data.Colour.CIE.Illuminant (d65)
   30 import           Data.Colour.RGBSpace
   31 import           Data.Colour.RGBSpace.HSV
   32 import           Data.Colour.SRGB
   33 import           Data.Fixed
   34 import           Reanimate.Ease
   35 
   36 -- | Constructor and destructor for color's three components.
   37 data ColorComponents = ColorComponents
   38   { colorUnpack :: Colour Double -> (Double, Double, Double)
   39     -- ^ Unpack a color into its three components.
   40   , colorPack   :: Double -> Double -> Double -> Colour Double
   41     -- ^ Restore a color from three coordinates.
   42   }
   43 
   44 -- | > interpolate rgbComponents yellow blue
   45 --
   46 --   <<docs/gifs/doc_rgbComponents.gif>>
   47 rgbComponents :: ColorComponents
   48 rgbComponents = ColorComponents rgbUnpack sRGB
   49   where
   50     rgbUnpack :: Colour Double -> (Double, Double, Double)
   51     rgbUnpack c =
   52       case toSRGB c of
   53         RGB r g b -> (r,g,b)
   54 
   55 -- | > interpolate hsvComponents yellow blue
   56 --
   57 --   <<docs/gifs/doc_hsvComponents.gif>>
   58 hsvComponents :: ColorComponents
   59 hsvComponents = ColorComponents unpack pack
   60   where
   61     unpack = hsvView.toSRGB
   62     pack a b c = uncurryRGB sRGB $ hsv a b c
   63 
   64 -- | > interpolate labComponents yellow blue
   65 --
   66 --   <<docs/gifs/doc_labComponents.gif>>
   67 labComponents :: ColorComponents
   68 labComponents = ColorComponents unpack pack
   69   where
   70     unpack = cieLABView d65
   71     pack = cieLAB d65
   72 
   73 -- | > interpolate xyzComponents yellow blue
   74 --
   75 --   <<docs/gifs/doc_xyzComponents.gif>>
   76 xyzComponents :: ColorComponents
   77 xyzComponents = ColorComponents cieXYZView cieXYZ
   78 
   79 -- | > interpolate lchComponents yellow blue
   80 --
   81 --   <<docs/gifs/doc_lchComponents.gif>>
   82 lchComponents :: ColorComponents
   83 lchComponents = ColorComponents unpack pack
   84   where
   85     toDeg,toRad :: Double -> Double
   86     toRad deg = deg/180 * pi
   87     toDeg rad = rad/pi * 180
   88     unpack :: Colour Double -> (Double, Double, Double)
   89     unpack color =
   90       let (l,a,b) = cieLABView d65 color
   91           c = sqrt (a*a + b*b)
   92           h :: Double
   93           h = (toDeg(atan2 b a) + 360) `mod'` 360
   94           isZero = round (c*10000) == (0::Integer)
   95       in (l, c, if isZero then 0/0 else h)
   96     pack l c h =
   97       cieLAB d65 l (cos (toRad h) * c) (sin (toRad h) * c)
   98 
   99 -- | Smoothly interpolate between two colors using the given color components.
  100 interpolate :: ColorComponents -> Colour Double -> Colour Double -> (Double -> Colour Double)
  101 interpolate ColorComponents{..} from to = \d ->
  102     colorPack (a1 + (a2-a1)*d) (b1 + (b2-b1)*d) (c1 + (c2-c1)*d)
  103   where
  104     (a1,b1,c1) = colorUnpack from
  105     (a2,b2,c2) = colorUnpack to
  106 
  107 -- | Convenience interpolation function for RGB8 values.
  108 interpolateRGB8 :: ColorComponents -> PixelRGB8 -> PixelRGB8 -> (Double -> PixelRGB8)
  109 interpolateRGB8 comps from to = toRGB8 . interpolate comps (fromRGB8 from) (fromRGB8 to)
  110 
  111 -- | Convenience interpolation function for RGBA8 values.
  112 interpolateRGBA8 :: ColorComponents -> PixelRGBA8 -> PixelRGBA8 -> (Double -> PixelRGBA8)
  113 interpolateRGBA8 comps from to = \t ->
  114   case interp t of
  115     PixelRGB8 r g b ->
  116       let alpha = fromToS (fromIntegral $ pixelOpacity from) (fromIntegral $ pixelOpacity to) t
  117       in PixelRGBA8 r g b (round alpha)
  118   where
  119     interp = interpolateRGB8 comps (dropTransparency from) (dropTransparency to)
  120 
  121 -- | Convenience function for expressing a color as an RGB8 value.
  122 toRGB8 :: Colour Double -> PixelRGB8
  123 toRGB8 c = PixelRGB8 r g b
  124   where
  125     RGB r g b = toSRGBBounded c
  126 
  127 -- | Convenience function for expressing an RGB8 value as a color.
  128 fromRGB8 :: PixelRGB8 -> Colour Double
  129 fromRGB8 (PixelRGB8 r g b) = sRGB24 r g b