hashirama/reanimate
Watch
1
0
Fork
You've already forked reanimate
 0
mirror of https://github.com/reanimate/reanimate.git synced 2026-09-10 23:52:22 +00:00
Code Issues Projects Releases Wiki Activity

Improve documentation.

Browse source 
Former-commit-id: 3cfff94ace7bf4ca7cefcbdb9acf38a1158a0349
This commit is contained in:
David Himmelstrup 2019-11-28 09:16:28 +08:00
commit bc36793740
2 changed files with 90 additions and 74 deletions
Download patch file Download diff file Expand all files Collapse all files

3
docs/gen_doc_gifs.sh
View file

@ -1,7 +1,8 @@
#!/usr/bin/env bash #!/usr/bin/env bash
ROOT=`stack path --project-root` ROOT=`stack path --project-root`
TINY='^(doc_turbo|doc_viridis|doc_magma|doc_inferno|doc_plasma|doc_sinebow|doc_cividis|doc_jet|doc_hsv|doc_hsvMatlab|doc_greyscale|doc_parula)$' TINY='^(doc_turbo|doc_viridis|doc_magma|doc_inferno|doc_plasma|doc_sinebow|doc_cividis|doc_jet|
doc_hsv|doc_hsvMatlab|doc_greyscale|doc_parula|doc_rgbComponents|doc_hsvComponents)$'
for src in $ROOT/examples/doc_*.hs; do for src in $ROOT/examples/doc_*.hs; do
BASE=`basename $src .hs` BASE=`basename $src .hs`

161
src/Reanimate/Interpolate.hs
View file

@ -1,73 +1,88 @@
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
module Reanimate.Interpolate where module Reanimate.Interpolate where
import Codec.Picture import Codec.Picture
import Data.Colour import Data.Colour
import Data.Colour.CIE import Data.Colour.CIE
import Data.Colour.CIE.Illuminant (d65) import Data.Colour.CIE.Illuminant (d65)
import Data.Colour.SRGB import Data.Colour.SRGB
import Data.Colour.RGBSpace.HSV import Data.Colour.RGBSpace.HSV
import Data.Colour.RGBSpace import Data.Colour.RGBSpace
import Data.Fixed import Data.Fixed
data ColorComponents = ColorComponents data ColorComponents = ColorComponents
{ colorUnpack :: Colour Double -> (Double, Double, Double) { colorUnpack :: Colour Double -> (Double, Double, Double)
, colorPack :: Double -> Double -> Double -> Colour Double } , colorPack :: Double -> Double -> Double -> Colour Double }
rgbComponents :: ColorComponents -- | > interpolate rgbComponents yellow blue
rgbComponents = ColorComponents rgbUnpack sRGB --
where -- <<docs/gifs/doc_rgbComponents.gif>>
rgbUnpack :: Colour Double -> (Double, Double, Double) rgbComponents :: ColorComponents
rgbUnpack c = rgbComponents = ColorComponents rgbUnpack sRGB
case toSRGB c of where
RGB r g b -> (r,g,b) rgbUnpack :: Colour Double -> (Double, Double, Double)
rgbUnpack c =
hsvComponents :: ColorComponents case toSRGB c of
hsvComponents = ColorComponents unpack pack RGB r g b -> (r,g,b)
where
unpack = hsvView.toSRGB -- | > interpolate hsvComponents yellow blue
pack a b c = uncurryRGB sRGB $ hsv a b c --
-- <<docs/gifs/doc_hsvComponents.gif>>
labComponents :: ColorComponents hsvComponents :: ColorComponents
labComponents = ColorComponents unpack pack hsvComponents = ColorComponents unpack pack
where where
unpack = cieLABView d65 unpack = hsvView.toSRGB
pack = cieLAB d65 pack a b c = uncurryRGB sRGB $ hsv a b c
xyzComponents :: ColorComponents -- | > interpolate labComponents yellow blue
xyzComponents = ColorComponents cieXYZView cieXYZ --
-- <<docs/gifs/doc_labComponents.gif>>
lchComponents :: ColorComponents labComponents :: ColorComponents
lchComponents = ColorComponents unpack pack labComponents = ColorComponents unpack pack
where where
toDeg,toRad :: Double -> Double unpack = cieLABView d65
toRad deg = deg/180 * pi pack = cieLAB d65
toDeg rad = rad/pi * 180
unpack :: Colour Double -> (Double, Double, Double) -- | > interpolate xyzComponents yellow blue
unpack color = --
let (l,a,b) = cieLABView d65 color -- <<docs/gifs/doc_xyzComponents.gif>>
c = sqrt (a*a + b*b) xyzComponents :: ColorComponents
h :: Double xyzComponents = ColorComponents cieXYZView cieXYZ
h = (toDeg(atan2 b a) + 360) `mod'` 360
isZero = round (c*10000) == (0::Integer) -- | > interpolate lchComponents yellow blue
in (l, c, if isZero then 0/0 else h) --
pack l c h = -- <<docs/gifs/doc_lchComponents.gif>>
cieLAB d65 l (cos (toRad h) * c) (sin (toRad h) * c) lchComponents :: ColorComponents
lchComponents = ColorComponents unpack pack
interpolate :: ColorComponents -> Colour Double -> Colour Double -> (Double -> Colour Double) where
interpolate ColorComponents{..} from to = \d -> toDeg,toRad :: Double -> Double
colorPack (a1 + (a2-a1)*d) (b1 + (b2-b1)*d) (c1 + (c2-c1)*d) toRad deg = deg/180 * pi
where toDeg rad = rad/pi * 180
(a1,b1,c1) = colorUnpack from unpack :: Colour Double -> (Double, Double, Double)
(a2,b2,c2) = colorUnpack to unpack color =
let (l,a,b) = cieLABView d65 color
interpolateRGB8 :: ColorComponents -> PixelRGB8 -> PixelRGB8 -> (Double -> PixelRGB8) c = sqrt (a*a + b*b)
interpolateRGB8 comps from to = toRGB8 . interpolate comps (fromRGB8 from) (fromRGB8 to) h :: Double
h = (toDeg(atan2 b a) + 360) `mod'` 360
toRGB8 :: Colour Double -> PixelRGB8 isZero = round (c*10000) == (0::Integer)
toRGB8 c = PixelRGB8 r g b in (l, c, if isZero then 0/0 else h)
where pack l c h =
RGB r g b = toSRGBBounded c cieLAB d65 l (cos (toRad h) * c) (sin (toRad h) * c)
fromRGB8 :: PixelRGB8 -> Colour Double interpolate :: ColorComponents -> Colour Double -> Colour Double -> (Double -> Colour Double)
fromRGB8 (PixelRGB8 r g b) = sRGB24 r g b 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)
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