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

Color-theory updates and related API changes. (#50)

Browse source 
Rewamp the scene api, add circle plots, add blender flips, fix caching issue in driver, fix bug in partialSvg.


Former-commit-id: 5cb900521044fee13766dd7474fd9b72c7691686
This commit is contained in:
David Himmelstrup 2020-02-02 09:17:29 +08:00 • committed by GitHub
commit 4bfafa4d8e
25 changed files with 1441 additions and 338 deletions
Download patch file Download diff file Expand all files Collapse all files

16
examples/doc_circlePlot.hs Executable file
View file

@ -0,0 +1,16 @@
#!/usr/bin/env stack
-- stack runghc --package reanimate
module Main(main) where
import Reanimate hiding (raster, hsv)
import Reanimate.Builtin.Documentation
import Reanimate.Builtin.CirclePlot
import Reanimate.Interpolate
import Data.Colour.RGBSpace.HSV
import Data.Colour.RGBSpace
import Data.Colour.SRGB
import Codec.Picture.Types
main :: IO ()
main = reanimate $ docEnv $ animate $ const $ circlePlot 500 $ \ang r ->
promotePixel $ toRGB8 $ uncurryRGB sRGB $ hsv (ang/pi*180) r 1

18
examples/tut_glue_blender.hs
View file

@ -2,6 +2,7 @@
-- stack runghc --package reanimate -- stack runghc --package reanimate
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ApplicativeDo #-}
module Main (main) where module Main (main) where
import Reanimate import Reanimate
@ -23,12 +24,14 @@ main = seq texture $ reanimate $ pauseAtEnd 1 $ parA bg $ sceneAnimation $ do
rotX <- newVar 0 rotX <- newVar 0
rotY <- newVar 0 rotY <- newVar 0
_ <- newSprite $ do _ <- newSprite $ do
getBend <- freezeVar bend getBend <- unVar bend
getTrans <- freezeVar trans getTrans <- unVar trans
getRotX <- freezeVar rotX getRotX <- unVar rotX
getRotY <- freezeVar rotY getRotY <- unVar rotY
return $ \real_t dur t -> seq (texture (t/dur)) $ t <- spriteT
blender (script (texture (t/dur)) (getBend real_t) (getTrans real_t) (getRotX real_t) (getRotY real_t)) dur <- spriteDuration
return $ seq (texture (t/dur)) $
blender (script (texture (t/dur)) getBend getTrans getRotX getRotY)
wait 2 wait 2
tweenVar trans 5 (\t v -> fromToS v (-2) $ curveS 2 (t/5)) tweenVar trans 5 (\t v -> fromToS v (-2) $ curveS 2 (t/5))
tweenVar bend 5 (\t v -> fromToS v 1 $ curveS 2 (t/5)) tweenVar bend 5 (\t v -> fromToS v 1 $ curveS 2 (t/5))
@ -234,7 +237,8 @@ drawAnimation' mbSeed fillDur step svg = sceneAnimation $ do
fork $ do fork $ do
wait (n*step+(1-fillDur)) wait (n*step+(1-fillDur))
newSprite $ do newSprite $ do
return $ \_real_t _d t -> t <- spriteT
pure $
withStrokeWidth 0 $ fn $ withFillOpacity (min 1 $ t/fillDur) tree withStrokeWidth 0 $ fn $ withFillOpacity (min 1 $ t/fillDur) tree
where where
shuf lst = shuf lst =

4
examples/tut_glue_latex.hs
View file

@ -1,6 +1,7 @@
#!/usr/bin/env stack #!/usr/bin/env stack
-- stack runghc --package reanimate -- stack runghc --package reanimate
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ApplicativeDo #-}
module Main (main) where module Main (main) where
import Reanimate import Reanimate
@ -83,7 +84,8 @@ drawAnimation' mbSeed fillDur step svg = sceneAnimation $ do
fork $ do fork $ do
wait (n*step+(1-fillDur)) wait (n*step+(1-fillDur))
newSprite $ do newSprite $ do
return $ \_real_t _d t -> t <- spriteT
return $
withStrokeWidth 0 $ fn $ withFillOpacity (min 1 $ t/fillDur) tree withStrokeWidth 0 $ fn $ withFillOpacity (min 1 $ t/fillDur) tree
where where
shuf lst = shuf lst =

6
examples/tut_glue_potrace.hs
View file

@ -17,11 +17,7 @@ main = reanimate $ parA bg $ sceneAnimation $ do
play $ mkAnimation drawDuration $ \t -> partialSvg t (wireframe (-45) 220) play $ mkAnimation drawDuration $ \t -> partialSvg t (wireframe (-45) 220)
xRot <- newVar (-45) xRot <- newVar (-45)
yRot <- newVar 220 yRot <- newVar 220
wf <- newSprite $ do wf <- newSprite $ wireframe <$> unVar xRot <*> unVar yRot
getX <- freezeVar xRot
getY <- freezeVar yRot
return $ \real_t _dur _t ->
wireframe (getX real_t) (getY real_t)
tweenVar yRot spinDur (\t v -> fromToS v (v+60*3) $ curveS 2 (t/spinDur)) tweenVar yRot spinDur (\t v -> fromToS v (v+60*3) $ curveS 2 (t/spinDur))
replicateM_ wobbles $ do replicateM_ wobbles $ do
tweenVar xRot (wobbleDur/2) (\t v -> fromToS v (v+90) $ curveS 2 (t/(wobbleDur/2))) tweenVar xRot (wobbleDur/2) (\t v -> fromToS v (v+90) $ curveS 2 (t/(wobbleDur/2)))

16
examples/tut_glue_povray.hs
View file

@ -2,6 +2,7 @@
-- stack runghc --package reanimate -- stack runghc --package reanimate
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ApplicativeDo #-}
module Main (main) where module Main (main) where
import Reanimate import Reanimate
@ -25,12 +26,14 @@ main = reanimate $ parA bg $ sceneAnimation $ do
xRot <- newVar 0 xRot <- newVar 0
zRot <- newVar 0 zRot <- newVar 0
_ <- newSprite $ do _ <- newSprite $ do
transZ <- freezeVar zPos transZ <- unVar zPos
getX <- freezeVar xRot getX <- unVar xRot
getZ <- freezeVar zRot getZ <- unVar zRot
return $ \real_t dur t -> t <- spriteT
dur <- spriteDuration
pure $
povraySlow [] $ povraySlow [] $
script (svgAsPngFile (texture (t/dur))) (transZ real_t) (getX real_t) (getZ real_t) script (svgAsPngFile (texture (t/dur))) transZ getX getZ
wait 2 wait 2
tweenVar zPos 9 (\t v -> fromToS v 8 (t/9)) tweenVar zPos 9 (\t v -> fromToS v 8 (t/9))
tweenVar xRot 9 (\t v -> fromToS v 360 $ curveS 2 (t/9)) tweenVar xRot 9 (\t v -> fromToS v 360 $ curveS 2 (t/9))
@ -148,7 +151,8 @@ drawAnimation' mbSeed fillDur step svg = sceneAnimation $ do
fork $ do fork $ do
wait (n*step+(1-fillDur)) wait (n*step+(1-fillDur))
newSprite $ do newSprite $ do
return $ \_real_t _d t -> t <- spriteT
return $
withStrokeWidth 0 $ fn $ withFillOpacity (min 1 $ t/fillDur) tree withStrokeWidth 0 $ fn $ withFillOpacity (min 1 $ t/fillDur) tree
where where
shuf lst = shuf lst =

16
examples/tut_glue_povray_ortho.hs
View file

@ -2,6 +2,7 @@
-- stack runghc --package reanimate -- stack runghc --package reanimate
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ApplicativeDo #-}
module Main (main) where module Main (main) where
import Reanimate import Reanimate
@ -25,12 +26,14 @@ main = reanimate $ parA bg $ sceneAnimation $ do
yRot <- newVar 180 yRot <- newVar 180
zRot <- newVar 0 zRot <- newVar 0
_ <- newSprite $ do _ <- newSprite $ do
getX <- freezeVar xRot getX <- unVar xRot
getY <- freezeVar yRot getY <- unVar yRot
getZ <- freezeVar zRot getZ <- unVar zRot
return $ \real_t dur t -> t <- spriteT
dur <- spriteDuration
return $
povraySlow [] $ povraySlow [] $
script (svgAsPngFile (texture (t/dur))) (getX real_t) (getY real_t) (getZ real_t) script (svgAsPngFile (texture (t/dur))) getX getY getZ
wait 2 wait 2
let tDuration = 10 let tDuration = 10
tweenVar yRot tDuration (\t v -> fromToS v (v+180) $ curveS 2 (t/tDuration)) tweenVar yRot tDuration (\t v -> fromToS v (v+180) $ curveS 2 (t/tDuration))
@ -184,7 +187,8 @@ drawAnimation' mbSeed fillDur step svg = sceneAnimation $ do
fork $ do fork $ do
wait (n*step+(1-fillDur)) wait (n*step+(1-fillDur))
newSprite $ do newSprite $ do
return $ \_real_t _d t -> t <- spriteT
return $
withStrokeWidth 0 $ fn $ withFillOpacity (min 1 $ t/fillDur) tree withStrokeWidth 0 $ fn $ withFillOpacity (min 1 $ t/fillDur) tree
where where
shuf lst = shuf lst =

2
reanimate.cabal
View file

@ -63,6 +63,8 @@ library
Reanimate.Blender Reanimate.Blender
Reanimate.Effect Reanimate.Effect
Reanimate.Builtin.TernaryPlot Reanimate.Builtin.TernaryPlot
Reanimate.Builtin.CirclePlot
Reanimate.Builtin.Flip
Reanimate.Constants Reanimate.Constants
Reanimate.Parameters Reanimate.Parameters
Reanimate.Chiphunk Reanimate.Chiphunk

6
src/Reanimate.hs
View file

@ -67,7 +67,6 @@ module Reanimate
sceneAnimation, sceneAnimation,
fork, fork,
play, play,
playZ,
queryNow, queryNow,
waitAll, waitAll,
waitUntil, waitUntil,
@ -76,11 +75,14 @@ module Reanimate
withSceneDuration, withSceneDuration,
newSprite, newSprite,
newSpriteA, newSpriteA,
newSpriteSVG,
destroySprite, destroySprite,
spriteE, spriteE,
newVar, newVar,
tweenVar, tweenVar,
freezeVar, unVar,
spriteT,
spriteDuration,
-- ** Effects -- ** Effects
Effect, Effect,

1
src/Reanimate/Blender.hs
View file

@ -47,4 +47,3 @@ mkBlenderImage' script = cacheFile template $ \target -> do
, "--render-output", target, "--python", py_file] , "--render-output", target, "--python", py_file]
where where
template = show (hash script) <.> "png" template = show (hash script) <.> "png"

23
src/Reanimate/Builtin/CirclePlot.hs Normal file
View file

@ -0,0 +1,23 @@
module Reanimate.Builtin.CirclePlot where
import Codec.Picture
import Graphics.SvgTree (Tree)
import Reanimate.Raster
import Reanimate.Svg
import Reanimate.Constants
circlePlot :: Int -- ^ Pixels in the X-axis.
-> (Double -- ^ Angle in radians
-> Double -- ^ Radius in percent
-> PixelRGBA8) -> Tree
circlePlot density fn =
scaleToHeight screenHeight $ flipYAxis $
embedImage $ generateImage gen density density
where
cN = fromIntegral $ density `div` 2 - 1
gen x y =
let radius = sqrt ((fromIntegral x-cN)**2 + (fromIntegral y-cN)**2)
ang = atan2 (fromIntegral y-cN) (fromIntegral x-cN)
in if radius > cN
then PixelRGBA8 0 0 0 0
else fn ang (radius / cN)

200
src/Reanimate/Builtin/Flip.hs Executable file
View file

@ -0,0 +1,200 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ApplicativeDo #-}
module Reanimate.Builtin.Flip
( FlipSprite(..)
, flipSprite
, Transition
, signalT
, flipTransition
, flipTransitionOpts
, overlapTransition
) where
import Reanimate.Animation
import Reanimate.Blender
import Reanimate.Raster
import Reanimate.Scene
import Reanimate.Signal
import Reanimate.Svg.Constructors
import Data.String.Here
import qualified Data.Text as T
data FlipSprite s = FlipSprite
{ fsSprite :: Sprite s
, fsBend :: Var s Double
, fsZoom :: Var s Double
, fsWobble :: Var s Double
}
flipSprite :: Animation -> Animation -> Scene s (FlipSprite s)
flipSprite front back = do
bend <- newVar 0
trans <- newVar 0
rotX <- newVar 0
s <- newSprite $ do
getBend <- unVar bend
getTrans <- unVar trans
getRotX <- unVar rotX
t <- spriteT
dur <- spriteDuration
return $
let rotY = fromToS 0 pi (t/dur)
frontTexture = svgAsPngFile (frameAt t $ setDuration dur front)
backTexture = svgAsPngFile (flipXAxis $ frameAt t $ setDuration dur back)
-- seq'ing frontTexture and backTexture is required to avoid segfaults. :(
in frontTexture `seq` backTexture `seq`
blender (script frontTexture backTexture getBend getTrans getRotX rotY)
return FlipSprite
{ fsSprite = s
, fsBend = bend
, fsZoom = trans
, fsWobble = rotX }
type Transition = Animation -> Animation -> Animation
signalT :: Signal -> Transition -> Transition
signalT s t = \a b -> signalA s (t a b)
overlapTransition :: Double -> Transition -> Transition
overlapTransition overlap t a b =
aBefore `seqA` t aOverlap bOverlap `seqA` bAfter
where
aBefore = takeA (duration a - overlap) a
aOverlap = dropA (duration a - overlap) a
bOverlap = takeA overlap b
bAfter = dropA overlap b
flipTransitionOpts :: Double -> Double -> Double -> Transition
flipTransitionOpts bend zoom wobble a b = sceneAnimation $ do
FlipSprite{..} <- flipSprite a b
fork $ tweenVar fsZoom dur $ \v -> fromToS v zoom . oscillateS
fork $ tweenVar fsBend dur $ \v -> fromToS v bend . oscillateS
fork $ tweenVar fsWobble dur $ \v -> fromToS v wobble . oscillateS
where
dur = max (duration a) (duration b)
flipTransition :: Transition
flipTransition = flipTransitionOpts bend zoom wobble
where
bend = 1/3
zoom = 3
wobble = -pi*0.10
script :: FilePath -> FilePath -> Double -> Double -> Double -> Double -> T.Text
script frontImage backImage bend transZ rotX rotY = [iTrim|
import os
import math
import bpy
light = bpy.data.objects['Light']
bpy.ops.object.select_all(action='DESELECT')
light.select_set(True)
bpy.ops.object.delete()
cam = bpy.data.objects['Camera']
cam.location = (0,0,22.22 + ${transZ})
cam.rotation_euler = (0, 0, 0)
bpy.ops.object.empty_add(location=(0.0, 0, 0))
focus_target = bpy.context.object
bpy.ops.object.select_all(action='DESELECT')
cam.select_set(True)
focus_target.select_set(True)
bpy.ops.object.parent_set()
focus_target.rotation_euler = (${rotX}, 0, 0)
origin = bpy.data.objects['Cube']
bpy.ops.object.select_all(action='DESELECT')
origin.select_set(True)
bpy.ops.object.delete()
x = ${bend}
bpy.ops.mesh.primitive_plane_add()
plane = bpy.context.object
plane.scale = (16/2,${fromToS (9/2) 4 bend},1)
bpy.ops.object.shade_smooth()
bpy.context.object.active_material = bpy.data.materials['Material']
mat = bpy.context.object.active_material
mix = mat.node_tree.nodes.new('ShaderNodeMixShader')
geo = mat.node_tree.nodes.new('ShaderNodeNewGeometry')
mat.blend_method = 'HASHED'
image_node = mat.node_tree.nodes.new('ShaderNodeTexImage')
gh_node = mat.node_tree.nodes.new('ShaderNodeTexImage')
output = mat.node_tree.nodes['Material Output']
gh_mix = mat.node_tree.nodes.new('ShaderNodeMixShader')
transparent = mat.node_tree.nodes.new('ShaderNodeBsdfTransparent')
mat.node_tree.links.new(geo.outputs['Backfacing'], mix.inputs['Fac'])
mat.node_tree.links.new(mix.outputs['Shader'], output.inputs['Surface'])
mat.node_tree.links.new(image_node.outputs['Color'], mix.inputs[1])
#mat.node_tree.links.new(gh_node.outputs['Color'], mix.inputs[2])
mat.node_tree.links.new(gh_node.outputs['Color'], gh_mix.inputs[2])
mat.node_tree.links.new(gh_node.outputs['Alpha'], gh_mix.inputs['Fac'])
mat.node_tree.links.new(transparent.outputs['BSDF'], gh_mix.inputs[1])
mat.node_tree.links.new(gh_mix.outputs['Shader'], mix.inputs[2])
image_node.image = bpy.data.images.load('${T.pack frontImage}')
image_node.interpolation = 'Closest'
gh_node.image = bpy.data.images.load('${T.pack backImage}')
gh_node.interpolation = 'Closest'
modifier = plane.modifiers.new(name='Subsurf', type='SUBSURF')
modifier.levels = 7
modifier.render_levels = 7
modifier.subdivision_type = 'SIMPLE'
bpy.ops.object.empty_add(type='ARROWS',rotation=(math.pi/2,0,0))
empty = bpy.context.object
bendUp = plane.modifiers.new(name='Bend up', type='SIMPLE_DEFORM')
bendUp.deform_method = 'BEND'
bendUp.origin = empty
bendUp.deform_axis = 'X'
bendUp.factor = -math.pi*x
bendAround = plane.modifiers.new(name='Bend around', type='SIMPLE_DEFORM')
bendAround.deform_method = 'BEND'
bendAround.origin = empty
bendAround.deform_axis = 'Z'
bendAround.factor = -math.pi*2*x
bpy.context.view_layer.objects.active = plane
bpy.ops.object.modifier_apply(modifier='Subsurf')
bpy.ops.object.modifier_apply(modifier='Bend up')
bpy.ops.object.modifier_apply(modifier='Bend around')
bpy.ops.object.select_all(action='DESELECT')
plane.select_set(True);
bpy.ops.object.origin_clear()
bpy.ops.object.origin_set(type='GEOMETRY_ORIGIN')
plane.rotation_euler = (0, ${rotY}, 0)
scn = bpy.context.scene
#scn.render.engine = 'CYCLES'
#scn.render.resolution_percentage = 10
scn.view_settings.view_transform = 'Standard'
scn.render.resolution_x = 2560
scn.render.resolution_y = 1440
scn.render.film_transparent = True
bpy.ops.render.render( write_still=True )
|]

5
src/Reanimate/ColorSpace.hs
View file

@ -33,6 +33,11 @@ bigXYZCoordinates = unsafePerformIO $ do
Right vec -> return $ Map.fromList Right vec -> return $ Map.fromList
[ (nm, (x,y,z)) | (nm,x,y,z) <- V.toList vec, nm <= 700 ] [ (nm, (x,y,z)) | (nm,x,y,z) <- V.toList vec, nm <= 700 ]
nmToColor :: Nanometer -> Maybe (Colour Double)
nmToColor nm = do
(x, y, z) <- Map.lookup nm bigXYZCoordinates
return $ cieXYZ x y z
renderXYZCoordinates :: Tree renderXYZCoordinates :: Tree
renderXYZCoordinates = renderXYZCoordinates =
withFillOpacity 0 $ withFillOpacity 0 $

5
src/Reanimate/Driver.hs
View file

@ -21,6 +21,7 @@ presetFormat ExampleGif = RenderGif
presetFormat Quick = RenderMp4 presetFormat Quick = RenderMp4
presetFormat MediumQ = RenderMp4 presetFormat MediumQ = RenderMp4
presetFormat HighQ = RenderMp4 presetFormat HighQ = RenderMp4
presetFormat LowFPS = RenderMp4
presetFPS :: Preset -> FPS presetFPS :: Preset -> FPS
presetFPS Youtube = 60 presetFPS Youtube = 60
@ -28,6 +29,7 @@ presetFPS ExampleGif = 24
presetFPS Quick = 15 presetFPS Quick = 15
presetFPS MediumQ = 30 presetFPS MediumQ = 30
presetFPS HighQ = 30 presetFPS HighQ = 30
presetFPS LowFPS = 10
presetWidth :: Preset -> Width presetWidth :: Preset -> Width
presetWidth Youtube = 2560 presetWidth Youtube = 2560
@ -35,6 +37,7 @@ presetWidth ExampleGif = 320
presetWidth Quick = 320 presetWidth Quick = 320
presetWidth MediumQ = 800 presetWidth MediumQ = 800
presetWidth HighQ = 1920 presetWidth HighQ = 1920
presetWidth LowFPS = presetWidth HighQ
presetHeight :: Preset -> Height presetHeight :: Preset -> Height
presetHeight preset = presetWidth preset * 9 `div` 16 presetHeight preset = presetWidth preset * 9 `div` 16
@ -163,7 +166,7 @@ guessParameter a b def = fromMaybe def (a <|> b)
-- If user specifies exactly one dimension explicitly, calculate the other -- If user specifies exactly one dimension explicitly, calculate the other
userPreferredDimensions :: Maybe Width -> Maybe Height -> Maybe (Width, Height) userPreferredDimensions :: Maybe Width -> Maybe Height -> Maybe (Width, Height)
userPreferredDimensions (Just width) (Just height) = Just (width, height) userPreferredDimensions (Just width) (Just height) = Just (width, height)
userPreferredDimensions (Just width) Nothing = Just (width, makeEven $ width * 9 `div` 16) userPreferredDimensions (Just width) Nothing = Just (width, makeEven $ width * 9 `div` 16)
userPreferredDimensions Nothing (Just height) = Just (makeEven $ height * 16 `div` 9, height) userPreferredDimensions Nothing (Just height) = Just (makeEven $ height * 16 `div` 9, height)
userPreferredDimensions Nothing Nothing = Nothing userPreferredDimensions Nothing Nothing = Nothing

4
src/Reanimate/Driver/CLI.hs
View file

@ -34,7 +34,7 @@ data Command
} }
deriving (Show) deriving (Show)
data Preset = Youtube | ExampleGif | Quick | MediumQ | HighQ data Preset = Youtube | ExampleGif | Quick | MediumQ | HighQ | LowFPS
deriving (Show) deriving (Show)
readFormat :: String -> Maybe Format readFormat :: String -> Maybe Format
@ -58,6 +58,7 @@ readPreset preset =
"quick" -> Just Quick "quick" -> Just Quick
"medium" -> Just MediumQ "medium" -> Just MediumQ
"high" -> Just HighQ "high" -> Just HighQ
"lowfps" -> Just LowFPS
_ -> Nothing _ -> Nothing
showPreset :: Preset -> String showPreset :: Preset -> String
@ -66,6 +67,7 @@ showPreset ExampleGif = "gif"
showPreset Quick = "quick" showPreset Quick = "quick"
showPreset MediumQ = "medium" showPreset MediumQ = "medium"
showPreset HighQ = "high" showPreset HighQ = "high"
showPreset LowFPS = "lowfps"
options :: Parser Options options :: Parser Options
options = Options <$> commandP options = Options <$> commandP

39
src/Reanimate/Driver/Server.hs
View file

@ -4,12 +4,11 @@ module Reanimate.Driver.Server
, findOwnSource , findOwnSource
) where ) where
import Control.Concurrent
import Control.Concurrent (forkIO, killThread, threadDelay) import Control.Concurrent (forkIO, killThread, threadDelay)
import Control.Concurrent.MVar
import Control.Exception (SomeException, catch, finally) import Control.Exception (SomeException, catch, finally)
import Control.Monad import Control.Monad
import Control.Monad.Fix (fix) import Control.Monad.Fix (fix)
import Data.Hashable (hash)
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Text.IO as T import qualified Data.Text.IO as T
@ -94,31 +93,47 @@ slaveHandler conn self svgDir =
withCurrentDirectory (takeDirectory self) $ withCurrentDirectory (takeDirectory self) $
withSystemTempDirectory "reanimate" $ \tmpDir -> withSystemTempDirectory "reanimate" $ \tmpDir ->
withTempFile tmpDir "reanimate.exe" $ \tmpExecutable handle -> do withTempFile tmpDir "reanimate.exe" $ \tmpExecutable handle -> do
-- cap <- getNumCapabilities
let n = 25
sem <- newQSemN n
hClose handle hClose handle
lock <- newMVar ()
sendTextData conn (T.pack "status\nCompiling") sendTextData conn (T.pack "status\nCompiling")
ret <- runCmd_ "stack" $ ["ghc", "--"] ++ ghcOptions tmpDir ++ [takeFileName self, "-o", tmpExecutable] ret <- runCmd_ "stack" $ ["ghc", "--"] ++ ghcOptions tmpDir ++ [takeFileName self, "-o", tmpExecutable]
case ret of case ret of
Left err -> Left err ->
sendTextData conn $ T.pack $ "error\n" ++ unlines (drop 3 (lines err)) sendTextData conn $ T.pack $ "error\n" ++ unlines (drop 3 (lines err))
Right{} -> runCmdLazy tmpExecutable execOpts $ \getFrame -> do Right{} -> runCmdLazy tmpExecutable execOpts $ \getFrame -> do
(frameCount,_) <- expectFrame =<< getFrame (frameCount,_) <- expectFrame sem =<< getFrame
sendTextData conn (T.pack $ "frame_count\n" ++ show frameCount) sendTextData conn (T.pack $ "frame_count\n" ++ show frameCount)
fix $ \loop -> do fix $ \loop -> do
(frameIdx, frame) <- expectFrame =<< getFrame (frameIdx, frame) <- expectFrame sem =<< getFrame
let fileName = svgDir </> show (hash frame) <.> "svg" -- putStrLn $ "Got frame: " ++ show frameIdx
T.writeFile fileName frame let fileName = svgDir </> takeBaseName tmpExecutable <.> show frameIdx <.> "svg"
sendTextData conn (T.pack $ "frame\n" ++ show frameIdx ++ "\n" ++ fileName) -- pngName = replaceExtension fileName "png"
_ <- forkIO $ do
waitQSemN sem 1
T.writeFile fileName frame
-- runCmd "rsvg-convert"
-- [ fileName
-- , "--width=256" -- "--width=1024"
-- , "--height=144" -- "--height=576"
-- , "--output", pngName ]
withMVar lock $ \_ ->
sendTextData conn (T.pack $ "frame\n" ++ show frameIdx ++ "\n" ++ fileName)
signalQSemN sem 1
loop loop
where where
execOpts = ["raw", "+RTS", "-N", "-M1G", "-RTS"] execOpts = ["raw", "+RTS", "-N", "-M2G", "-RTS"]
expectFrame :: Either String Text -> IO (Integer, Text) expectFrame :: QSemN -> Either String Text -> IO (Integer, Text)
expectFrame (Left "") = do expectFrame sem (Left "") = do
waitQSemN sem 25 -- =<< getNumCapabilities
sendTextData conn (T.pack "status\nDone") sendTextData conn (T.pack "status\nDone")
exitSuccess exitSuccess
expectFrame (Left err) = do expectFrame _ (Left err) = do
sendTextData conn $ T.pack $ "Error" ++ err sendTextData conn $ T.pack $ "Error" ++ err
exitWith (ExitFailure 1) exitWith (ExitFailure 1)
expectFrame (Right frame) = expectFrame _ (Right frame) =
case T.decimal frame of case T.decimal frame of
Left err -> do Left err -> do
hPutStrLn stderr (T.unpack frame) hPutStrLn stderr (T.unpack frame)

204
src/Reanimate/Scene.hs
View file

@ -1,4 +1,5 @@
{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ApplicativeDo #-}
module Reanimate.Scene where module Reanimate.Scene where
import Control.Monad.Fix import Control.Monad.Fix
@ -6,7 +7,6 @@ import Control.Monad.ST
import Data.List import Data.List
import Data.STRef import Data.STRef
import Reanimate.Animation import Reanimate.Animation
import Reanimate.Signal
import Reanimate.Effect import Reanimate.Effect
import Reanimate.Svg.Constructors import Reanimate.Svg.Constructors
import Graphics.SvgTree (Tree(None)) import Graphics.SvgTree (Tree(None))
@ -19,53 +19,41 @@ o # f = f o
-- (seq duration, par duration) -- (seq duration, par duration)
-- [(Time, Animation, ZIndex)] -- [(Time, Animation, ZIndex)]
-- Map Time [(Animation, ZIndex)] -- Map Time [(Animation, ZIndex)]
type Timeline = [(Time, Animation, ZIndex)]
type Gen s = ST s (Duration -> Time -> (SVG, ZIndex)) type Gen s = ST s (Duration -> Time -> (SVG, ZIndex))
newtype Scene s a = M { unM :: Time -> ST s (a, Duration, Duration, Timeline, [Gen s]) } newtype Scene s a = M { unM :: Time -> ST s (a, Duration, Duration, [Gen s]) }
unionTimeline :: Timeline -> Timeline -> Timeline
unionTimeline = (++)
emptyTimeline :: Timeline
emptyTimeline = []
instance Functor (Scene s) where instance Functor (Scene s) where
fmap f action = M $ \t -> do fmap f action = M $ \t -> do
(a, d1, d2, tl, gens) <- unM action t (a, d1, d2, gens) <- unM action t
return (f a, d1, d2, tl, gens) return (f a, d1, d2, gens)
instance Applicative (Scene s) where instance Applicative (Scene s) where
pure a = M $ \_ -> return (a, 0, 0, emptyTimeline, []) pure a = M $ \_ -> return (a, 0, 0, [])
f <*> g = M $ \t -> do f <*> g = M $ \t -> do
(f', s1, p1, tl1, gen1) <- unM f t (f', s1, p1, gen1) <- unM f t
(g', s2, p2, tl2, gen2) <- unM g (t+s1) (g', s2, p2, gen2) <- unM g (t+s1)
return (f' g', s1+s2, max p1 (s1+p2), unionTimeline tl1 tl2, gen1++gen2) return (f' g', s1+s2, max p1 (s1+p2), gen1++gen2)
instance Monad (Scene s) where instance Monad (Scene s) where
return = pure return = pure
f >>= g = M $ \t -> do f >>= g = M $ \t -> do
(a, s1, p1, tl1, gen1) <- unM f t (a, s1, p1, gen1) <- unM f t
(b, s2, p2, tl2, gen2) <- unM (g a) (t+s1) (b, s2, p2, gen2) <- unM (g a) (t+s1)
return (b, s1+s2, max p1 (s1+p2), unionTimeline tl1 tl2, gen1++gen2) return (b, s1+s2, max p1 (s1+p2), gen1++gen2)
instance MonadFix (Scene s) where instance MonadFix (Scene s) where
mfix fn = M $ \t -> mfix (\v -> let (a,_s,_p,_tl,_gens) = v in unM (fn a) t) mfix fn = M $ \t -> mfix (\v -> let (a,_s,_p,_gens) = v in unM (fn a) t)
liftST :: ST s a -> Scene s a liftST :: ST s a -> Scene s a
liftST action = M $ \_ -> action >>= \a -> return (a, 0, 0, emptyTimeline, []) liftST action = M $ \_ -> action >>= \a -> return (a, 0, 0, [])
sceneAnimation :: (forall s. Scene s a) -> Animation sceneAnimation :: (forall s. Scene s a) -> Animation
sceneAnimation action = sceneAnimation action =
runST (do runST (do
(_, s, p, tl, gens) <- unM action 0 (_, s, p, gens) <- unM action 0
let dur = max s p let dur = max s p
anis = foldl' parDropA (pause 0) $
map snd $ sortOn fst
[ (z, pause startT `seqA` a)
| (startT, a, z) <- tl
]
genFns <- sequence gens genFns <- sequence gens
return $ anis `parDropA` mkAnimation dur (\t -> return $ mkAnimation dur (\t ->
mkGroup $ mkGroup $
map fst $ map fst $
sortOn snd sortOn snd
@ -75,25 +63,20 @@ sceneAnimation action =
fork :: Scene s a -> Scene s a fork :: Scene s a -> Scene s a
fork (M action) = M $ \t -> do fork (M action) = M $ \t -> do
(a, s, p, tl, gens) <- action t (a, s, p, gens) <- action t
return (a, 0, max s p, tl, gens) return (a, 0, max s p, gens)
play :: Animation -> Scene s () play :: Animation -> Scene s ()
play = playZ 0 play ani = newSpriteA ani >>= destroySprite
playZ :: ZIndex -> Animation -> Scene s ()
playZ z ani = M $ \t -> do
let d = duration ani
return ((), d, 0, [(t, ani, z)], [])
queryNow :: Scene s Time queryNow :: Scene s Time
queryNow = M $ \t -> return (t, 0, 0, emptyTimeline, []) queryNow = M $ \t -> return (t, 0, 0, [])
-- Wait until all forked and sequential animations have finished. -- Wait until all forked and sequential animations have finished.
waitAll :: Scene s a -> Scene s a waitAll :: Scene s a -> Scene s a
waitAll (M action) = M $ \t -> do waitAll (M action) = M $ \t -> do
(a, s, p, tl, gens) <- action t (a, s, p, gens) <- action t
return (a, max s p, 0, tl, gens) return (a, max s p, 0, gens)
waitUntil :: Time -> Scene s () waitUntil :: Time -> Scene s ()
waitUntil tNew = do waitUntil tNew = do
@ -102,12 +85,18 @@ waitUntil tNew = do
wait :: Duration -> Scene s () wait :: Duration -> Scene s ()
wait d = M $ \_ -> wait d = M $ \_ ->
return ((), d, 0, emptyTimeline, []) return ((), d, 0, [])
adjustZ :: (ZIndex -> ZIndex) -> Scene s a -> Scene s a adjustZ :: (ZIndex -> ZIndex) -> Scene s a -> Scene s a
adjustZ fn (M action) = M $ \t -> do adjustZ fn (M action) = M $ \t -> do
(a, s, p, tl, gens) <- action t (a, s, p, gens) <- action t
return (a, s, p, [ (startT, ani, fn z) | (startT, ani, z) <- tl ], gens) return (a, s, p, map genFn gens)
where
genFn gen = do
frameGen <- gen
return $ \d t ->
let (svg, z) = frameGen d t
in (svg, fn z)
withSceneDuration :: Scene s () -> Scene s Duration withSceneDuration :: Scene s () -> Scene s Duration
withSceneDuration s = do withSceneDuration s = do
@ -116,52 +105,13 @@ withSceneDuration s = do
t2 <- queryNow t2 <- queryNow
return (t2-t1) return (t2-t1)
newtype Object s = Object (STRef s (Maybe Timeline))
newObject :: Scene s (Object s)
newObject = Object <$> liftST (newSTRef Nothing)
stretchTimeline :: Timeline -> Scene s ()
stretchTimeline = mapM_ worker
where
worker (t, a, z) = M $ \tNow -> -- 3
let tNew = t + duration a -- 1+1=2
dNew = tNow - tNew -- 3-2=1
aNew = setDuration dNew (signalA (constantS 1) a) in
if (dNew > 0)
then return ((), 0, 0, [(tNew, aNew, z)], [])
else return ((), 0, 0, emptyTimeline, [])
dropObject :: Object s -> Scene s ()
dropObject (Object ref) = do
mbTimeline <- liftST $ readSTRef ref
case mbTimeline of
Nothing -> return ()
Just timeline -> do
liftST $ writeSTRef ref Nothing
stretchTimeline timeline
listen :: Scene s a -> Scene s (a, Timeline)
listen scene = M $ \t -> do
(a, s, p, tl, gens) <- unM scene t
return ((a,tl), s, p, tl, gens)
withObject :: Object s -> Scene s a -> Scene s a
withObject obj@(Object ref) scene = do
dropObject obj
(a, tl) <- listen scene
liftST $ writeSTRef ref (Just tl)
return a
fromParams :: Gen s -> Scene s () fromParams :: Gen s -> Scene s ()
fromParams gen = M $ \_ -> return ((), 0, 0, emptyTimeline, [gen]) fromParams gen = M $ \_ -> return ((), 0, 0, [gen])
simpleParam :: (a -> SVG) -> a -> Scene s (Var s a) simpleParam :: (a -> SVG) -> a -> Scene s (Var s a)
simpleParam render def = do simpleParam render def = do
v <- newVar def v <- newVar def
_ <- newSprite $ do _ <- newSprite $ render <$> unVar v
getV <- freezeVar v
return $ \real_t _d _t -> render (getV real_t)
return v return v
newtype Var s a = Var (STRef s (Time -> a)) newtype Var s a = Var (STRef s (Time -> a))
@ -190,8 +140,10 @@ tweenVar (Var ref) dur fn = do
fn (prev t) ((max 0 $ min dur $ t-now)/dur) fn (prev t) ((max 0 $ min dur $ t-now)/dur)
wait dur wait dur
freezeVar :: Var s a -> ST s (Time -> a) unVar :: Var s a -> Frame s a
freezeVar (Var ref) = readSTRef ref unVar (Var ref) = Frame $ do
fn <- readSTRef ref
return $ \real_t _d _t -> fn real_t
findVar :: (a -> Bool) -> [Var s a] -> Scene s (Var s a) findVar :: (a -> Bool) -> [Var s a] -> Scene s (Var s a)
findVar _cond [] = error "Variable not found." findVar _cond [] = error "Variable not found."
@ -202,22 +154,44 @@ findVar cond (v:vs) = do
applyVar :: Var s a -> Sprite s -> (a -> SVG -> SVG) -> Scene s () applyVar :: Var s a -> Sprite s -> (a -> SVG -> SVG) -> Scene s ()
applyVar var sprite fn = do applyVar var sprite fn = do
spriteModify sprite $ do spriteModify sprite $ do
varFn <- freezeVar var varFn <- unVar var
return $ \absT _relD _relT (svg, zindex) -> return $ \(svg, zindex) ->
(fn (varFn absT) svg, zindex) (fn varFn svg, zindex)
data Sprite s = Sprite Time (STRef s (Duration, ST s (Duration -> Time -> SVG -> (SVG, ZIndex)))) data Sprite s = Sprite Time (STRef s (Duration, ST s (Duration -> Time -> SVG -> (SVG, ZIndex))))
newSprite :: ST s (Time -> Duration -> Time -> SVG) -> Scene s (Sprite s) newtype Frame s a = Frame { unFrame :: ST s (Time -> Duration -> Time -> a) }
instance Functor (Frame s) where
fmap fn (Frame gen) = Frame $ do
m <- gen
return (\real_t d t -> fn $ m real_t d t)
instance Applicative (Frame s) where
pure v = Frame $ return (\_ _ _ -> v)
Frame f <*> Frame g = Frame $ do
m1 <- f
m2 <- g
return $ \real_t d t ->
m1 real_t d t (m2 real_t d t)
-- Time in seconds.
spriteT :: Frame s Time
spriteT = Frame $ return (\_real_t _d t -> t)
spriteDuration :: Frame s Duration
spriteDuration = Frame $ return (\_real_t d _t -> d)
newSprite :: Frame s SVG -> Scene s (Sprite s)
newSprite render = do newSprite render = do
now <- queryNow now <- queryNow
ref <- liftST $ newSTRef (-1, return $ \_d _t svg -> (svg, 0)) ref <- liftST $ newSTRef (-1, return $ \_d _t svg -> (svg, 0))
fromParams $ do fromParams $ do
fn <- render fn <- unFrame render
(spriteDuration, spriteEffectGen) <- readSTRef ref (spriteDur, spriteEffectGen) <- readSTRef ref
spriteEffect <- spriteEffectGen spriteEffect <- spriteEffectGen
return $ \d absT -> return $ \d absT ->
let relD = (if spriteDuration < 0 then d else spriteDuration)-now let relD = (if spriteDur < 0 then d else spriteDur)-now
relT = absT-now in relT = absT-now in
if relT < 0 || relD < relT if relT < 0 || relD < relT
then (None, 0) then (None, 0)
@ -228,20 +202,12 @@ newSpriteA :: Animation -> Scene s (Sprite s)
newSpriteA = newSpriteA' SyncStretch newSpriteA = newSpriteA' SyncStretch
newSpriteA' :: Sync -> Animation -> Scene s (Sprite s) newSpriteA' :: Sync -> Animation -> Scene s (Sprite s)
newSpriteA' sync animation = do newSpriteA' sync animation =
now <- queryNow newSprite (getAnimationFrame sync animation <$> spriteT <*> spriteDuration)
ref <- liftST $ newSTRef (-1, return $ \_d _t svg -> (svg, 0)) <* wait (duration animation)
fromParams $ do
(spriteDuration, spriteEffectGen) <- readSTRef ref newSpriteSVG :: SVG -> Scene s (Sprite s)
spriteEffect <- spriteEffectGen newSpriteSVG = newSprite . pure
return $ \d absT ->
let relD = (if spriteDuration < 0 then d else spriteDuration)-now
relT = absT-now in
if relT < 0 || relT > relD
then (None, 0)
else spriteEffect relD relT (getAnimationFrame sync animation relT relD)
wait (duration animation)
return $ Sprite now ref
getAnimationFrame :: Sync -> Animation -> Time -> Duration -> SVG getAnimationFrame :: Sync -> Animation -> Time -> Duration -> SVG
getAnimationFrame sync (Animation aDur aGen) t d = getAnimationFrame sync (Animation aDur aGen) t d =
@ -265,24 +231,28 @@ destroySprite (Sprite _ ref) = do
liftST $ modifySTRef ref $ \(ttl, render) -> liftST $ modifySTRef ref $ \(ttl, render) ->
(if ttl < 0 then now else min ttl now, render) (if ttl < 0 then now else min ttl now, render)
spriteModify :: Sprite s -> ST s (Time -> Duration -> Time -> (SVG, ZIndex) -> (SVG, ZIndex)) -> Scene s () spriteModify :: Sprite s -> Frame s ((SVG,ZIndex) -> (SVG, ZIndex)) -> Scene s ()
spriteModify (Sprite born ref) modFn = spriteModify (Sprite born ref) modFn =
liftST $ modifySTRef ref $ \(ttl, renderGen) -> liftST $ modifySTRef ref $ \(ttl, renderGen) ->
(ttl, do (ttl, do
render <- renderGen render <- renderGen
modRender <- modFn modRender <- unFrame modFn
return $ \relD relT -> return $ \relD relT ->
let absT = relT + born let absT = relT + born
in modRender absT relD relT . render relD relT) in modRender absT relD relT . render relD relT)
spriteMap :: Sprite s -> (SVG -> SVG) -> Scene s ()
spriteMap sprite fn = spriteModify sprite $ pure $ \(svg, zindex) -> (fn svg, zindex)
spriteTween :: Sprite s -> Duration -> (Double -> SVG -> SVG) -> Scene s () spriteTween :: Sprite s -> Duration -> (Double -> SVG -> SVG) -> Scene s ()
spriteTween sprite@(Sprite born _) dur fn = do spriteTween sprite@(Sprite born _) dur fn = do
now <- queryNow now <- queryNow
let tDelta = now - born let tDelta = now - born
spriteModify sprite $ do spriteModify sprite $ do
return $ \_real_t _d t (svg, zindex) -> t <- spriteT
(fn (clamp 0 1 $ (t-tDelta)/dur) svg, zindex) return $ \(svg, zindex) ->
wait dur (fn (clamp 0 1 $ (t-tDelta)/dur) svg, zindex)
wait dur
where where
clamp a b v clamp a b v
| v < a = a | v < a = a
@ -293,9 +263,9 @@ spriteVar :: Sprite s -> a -> (a -> SVG -> SVG) -> Scene s (Var s a)
spriteVar sprite def fn = do spriteVar sprite def fn = do
v <- newVar def v <- newVar def
spriteModify sprite $ do spriteModify sprite $ do
getV <- freezeVar v getV <- unVar v
return $ \real_t _d _t (svg, zindex) -> return $ \(svg, zindex) ->
(fn (getV real_t) svg, zindex) (fn getV svg, zindex)
return v return v
spriteE :: Sprite s -> Effect -> Scene s () spriteE :: Sprite s -> Effect -> Scene s ()
@ -306,7 +276,7 @@ spriteE (Sprite born ref) effect = do
render <- renderGen render <- renderGen
return $ \d t svg -> return $ \d t svg ->
let (svg', z) = render d t svg let (svg', z) = render d t svg
in (delayE (now-born) effect d t svg', z)) in (delayE (max 0 $ now-born) effect d t svg', z))
spriteZ :: Sprite s -> ZIndex -> Scene s () spriteZ :: Sprite s -> ZIndex -> Scene s ()
spriteZ (Sprite born ref) zindex = do spriteZ (Sprite born ref) zindex = do

2
src/Reanimate/Svg/LineCommand.hs
View file

@ -251,7 +251,7 @@ interpolatePathCommands alpha = lineToPath . partialLine alpha . toLineCommands
partialSvg :: Double -- ^ number between 0 and 1 inclusively, determining what portion of the path to show partialSvg :: Double -- ^ number between 0 and 1 inclusively, determining what portion of the path to show
-> Tree -- ^ Image representing a path, of which we only want to display a portion determined by the first argument -> Tree -- ^ Image representing a path, of which we only want to display a portion determined by the first argument
-> Tree -> Tree
-- partialSvg alpha | alpha >= 1 = id partialSvg alpha | alpha >= 1 = id
partialSvg alpha = mapTree worker partialSvg alpha = mapTree worker
where where
worker (PathTree path) = worker (PathTree path) =

39
videos/color-theory/EndScene.hs Normal file
View file

@ -0,0 +1,39 @@
#!/usr/bin/env stack
-- stack --resolver lts-13.14 runghc --package reanimate
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module EndScene (endScene) where
import Control.Lens ()
import Control.Monad
import qualified Data.ByteString as BS
import qualified Data.Map as Map
import Data.Monoid
import qualified Data.Text as T
import Codec.Picture
import Codec.Picture.Jpg
import Codec.Picture.Types
import Data.Maybe
import Data.Word
import Graphics.SvgTree hiding (Image, imageHeight, imageWidth)
import Graphics.SvgTree.Memo
import Numeric
import Reanimate
import Reanimate.Animation
import Reanimate.ColorMap
import Reanimate.ColorSpace
import Reanimate.Builtin.Images
import Reanimate.Constants
import Reanimate.Driver (reanimate)
import Reanimate.Effect
import Reanimate.LaTeX
import Reanimate.Raster
import Reanimate.Scene
import Reanimate.Signal
import Reanimate.Svg
import System.IO.Unsafe
endScene :: Animation
endScene = mkAnimation 5 $ const $
scale 0.5 $ githubIcon

151
videos/color-theory/Grid.hs Executable file
View file

@ -0,0 +1,151 @@
#!/usr/bin/env stack
-- stack --resolver lts-13.14 runghc --package reanimate
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ApplicativeDo #-}
module Grid (gridScene) where
import Control.Lens ()
import Control.Monad
import qualified Data.ByteString as BS
import qualified Data.Map as Map
import Data.Monoid
import qualified Data.Text as T
import Codec.Picture
import Codec.Picture.Jpg
import Codec.Picture.Types
import Data.Maybe
import Data.Word
import Graphics.SvgTree hiding (Image, imageHeight, imageWidth)
import Graphics.SvgTree.Memo
import Numeric
import Reanimate
import Reanimate.Animation
import Reanimate.ColorMap
import Reanimate.ColorSpace
import Reanimate.Constants
import Reanimate.Driver (reanimate)
import Reanimate.Effect
import Reanimate.LaTeX
import Reanimate.Raster
import Reanimate.Scene
import Reanimate.Signal
import Reanimate.Svg
import System.IO.Unsafe
gridScene :: Animation
gridScene = sceneAnimation $ do
sViridis <- monalisaSprite (-1) 1 "viridis"
sCividis <- monalisaSprite 0 1 "cividis"
sParula <- monalisaSprite 1 1 "parula"
sJet <- monalisaSprite (-1) 0 "jet"
sInferno <- monalisaSprite 0 0 "inferno"
sSinebow <- monalisaSprite 1 0 "sinebow"
sTurbo <- monalisaSprite (-1) (-1) "turbo"
sPlasma <- monalisaSprite 0 (-1) "plasma"
sHSV <- monalisaSprite 1 (-1) "hsv"
showMap sViridis
showMap sCividis
showMap sParula
wait 2
showMap sJet
showMap sInferno
showMap sSinebow
wait 2
showMap sTurbo
showMap sPlasma
showMap sHSV
wait 2
return ()
where
showMap hd = do
spriteZ (fst hd) 1
tweenVar (snd hd) 1 $ \v -> fromToS v 1 . curveS 3
wait 1
tweenVar (snd hd) 1 $ \v -> fromToS v 0 . curveS 3
spriteZ (fst hd) 0
maps =
[ ("viridis", viridis)
, ("cividis", cividis)
, ("parula", parula)
, ("jet", jet)
, ("inferno", inferno)
, ("sinebow", sinebow)
, ("turbo", turbo)
, ("plasma", plasma)
, ("hsv", hsv)
]
monalisaSprite :: Double -> Double -> T.Text -> Scene s (Sprite s, Var s Double)
monalisaSprite x y txt = do
highlight <- newVar 0
s <- newSprite $ do
getHighlight <- unVar highlight
return $
translate (screenWidth/3 * x * (1-getHighlight))
(screenHeight/3 * y * (1-getHighlight)) $
scale (fromToS 1 2 (getHighlight)) $
mkGroup
[ scaleToSize (screenWidth/3) (screenHeight/3) $
embedImage $
applyColorMap (fromMaybe jet $ lookup txt maps) monalisa
, translate (-screenWidth/6 + screenWidth*0.005) (screenHeight/6 - screenHeight*0.005) $
scale 0.5 $
withStrokeColor "black" $
withStrokeWidth (defaultStrokeWidth*0.5) $
withFillColor "white" $
latex ("\\texttt{" <> txt <> "}")
]
return (s, highlight)
monalisaPoster :: SVG
monalisaPoster =
mkGroup
[ mkPic (-1) 1 viridis "viridis", mkPic 0 1 cividis "cividis", mkPic 1 1 parula "parula"
, mkPic (-1) 0 jet "jet", mkPic 0 0 inferno "inferno", mkPic 1 0 sinebow "sinebow"
, mkPic (-1) (-1) turbo "turbo", mkPic 0 (-1) plasma "plasma", mkPic 1 (-1) hsv "hsv" ]
where
mkPic x y cm txt =
translate (screenWidth/3 * x) (screenHeight/3 * y) $
mkGroup
[ scaleToSize (screenWidth/3) (screenHeight/3) $ embedImage $
applyColorMap cm monalisa
, translate (-screenWidth/6) (screenHeight/6) $
scale 0.5 $
withStrokeColor "black" $
withStrokeWidth (defaultStrokeWidth*0.5) $
withFillColor "white" $
latex ("\\texttt{" <> txt <> "}")
]
monalisa :: Image PixelRGB8
monalisa = unsafePerformIO $ do
dat <- BS.readFile "monalisa.jpg"
case decodeJpeg dat of
Left err -> error err
Right img -> return $ convertRGB8 img
monalisaLarge :: Image PixelRGB8
monalisaLarge = scaleImage 15 monalisa
scaleImage :: Pixel a => Int -> Image a -> Image a
scaleImage factor img =
generateImage fn (imageWidth img * factor) (imageHeight img * factor)
where
fn x y = pixelAt img (x `div` factor) (y `div` factor)
applyColorMap :: (Double -> PixelRGB8) -> Image PixelRGB8 -> Image PixelRGB8
applyColorMap cmap img =
generateImage fn (imageWidth img) (imageHeight img)
where
fn x y =
case pixelAt img x y of
PixelRGB8 r _ _ -> cmap (fromIntegral r/255)

29
videos/color-theory/SCRIPT.md Normal file
View file

@ -0,0 +1,29 @@
On its own, data doesn't look like much.
Often it is merely a wall of unintelligible numbers.
However, if we take each number and assign it a shade of grey, suddenly
the data becomes understandable and the face of the monalisa stares out at us.
Using shades of grey is not the only possible color palette, though,
and many colorful alternatives exists. Some of these colormaps have been around
for a while, and Jet, one of the oldest, first appeared in the 1970s. However,
in recent years, a lot of attention has gone into addressing the shortcomings
of the early colormaps and create better standards for the future.
Particularly, Matlab replaced Jet by Parula in 2014, Viridis became the default
in Matplotlib by 2015, the research paper describing Cividis was published in
2018, and Google created Turbo as a spiritual successor to Jet in 2019.
So, why were so many new colormaps invented in this 5-year period? How are these
colormaps created? Are they merely the favorite colors of their creators? How
can a colormap be interesting enough to merit a research publication?
To answer these questions, first we have to explore a bit of color theory.
Visible light roughly ranges from a wavelength of 400nm to 700nm. If each
combination of wavelengths gave rise to a unique color then creating a color
space would be nigh impossible. Fortunately, most human eyes have just three
types of light-sensitive cells that respond to ranges of wavelengths, and the
space of colors is therefore reduced to three dimensions.
The axes are called S, M and L because the corrosponding cones are sensitive to
short, medium, and lone wavelengths respectively.

638
videos/color-theory/Spectrum.hs
View file

@ -1,32 +1,33 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecursiveDo #-} {-# LANGUAGE RecursiveDo #-}
{-# LANGUAGE ApplicativeDo #-}
module Spectrum module Spectrum
( colorSpacesScene ( scene2
, xyzTernaryPlot
, interpolation
, spacesA
, scene2
, scene3
) where ) where
import Control.Lens ((&), (.~)) import Control.Lens ((&), (.~))
import Codec.Picture import Codec.Picture
import Codec.Picture.Types
import Control.Monad import Control.Monad
import qualified Data.ByteString as BS
import Data.Colour import Data.Colour
import Data.Colour.CIE import Data.Colour.CIE
import Data.Colour.CIE.Illuminant import Data.Colour.CIE.Illuminant
import Data.Colour.RGBSpace import Data.Colour.RGBSpace
import Data.Colour.RGBSpace.HSV (hsvView)
import Data.Colour.SRGB import Data.Colour.SRGB
import Data.Colour.SRGB.Linear import Data.Colour.SRGB.Linear
import Data.List import Data.List
import qualified Data.Map as Map import qualified Data.Map as Map
import Data.Maybe
import Data.Ord import Data.Ord
import Data.Text (Text) import Data.Text (Text)
import Graphics.SvgTree hiding (Text) import Graphics.SvgTree hiding (Text)
import Linear.V2 import Linear.V2
import Reanimate import Reanimate
import Reanimate.Animation import Reanimate.Animation
import Reanimate.Builtin.CirclePlot
import Reanimate.Builtin.Documentation import Reanimate.Builtin.Documentation
import qualified Reanimate.Builtin.TernaryPlot as Ternary import qualified Reanimate.Builtin.TernaryPlot as Ternary
import Reanimate.ColorMap import Reanimate.ColorMap
@ -41,6 +42,7 @@ import Reanimate.Scene
import Reanimate.Signal import Reanimate.Signal
import Reanimate.Svg import Reanimate.Svg
import Reanimate.Svg.BoundingBox import Reanimate.Svg.BoundingBox
import System.IO.Unsafe
{- STORYBOARD {- STORYBOARD
- Wavelength scene - Wavelength scene
@ -58,8 +60,8 @@ xCoords = [ (nm, x/2) | (nm, (x, y, z)) <- Map.toList bigXYZCoordinates ]
yCoords = [ (nm, y/2) | (nm, (x, y, z)) <- Map.toList bigXYZCoordinates ] yCoords = [ (nm, y/2) | (nm, (x, y, z)) <- Map.toList bigXYZCoordinates ]
zCoords = [ (nm, z/2) | (nm, (x, y, z)) <- Map.toList bigXYZCoordinates ] zCoords = [ (nm, z/2) | (nm, (x, y, z)) <- Map.toList bigXYZCoordinates ]
labScaleX = 128 labScaleX = 110 -- 100 -- 128
labScaleY = 128 labScaleY = 110 -- 100 -- 128
blueName = "royalblue" blueName = "royalblue"
greenName = "green" greenName = "green"
@ -67,7 +69,7 @@ redName = "maroon"
drawSensitivities :: Animation drawSensitivities :: Animation
drawSensitivities = sceneAnimation $ do drawSensitivities = sceneAnimation $ do
bg <- newSpriteA $ staticFrame 0 spectrumGrid bg <- newSpriteSVG $ spectrumGrid True
spriteZ bg 1 spriteZ bg 1
forM_ [(short, blueName), (medium, greenName), (long, redName)] $ forM_ [(short, blueName), (medium, greenName), (long, redName)] $
@ -81,7 +83,7 @@ drawSensitivities = sceneAnimation $ do
drawMorphingSensitivities :: Animation drawMorphingSensitivities :: Animation
drawMorphingSensitivities = sceneAnimation $ do drawMorphingSensitivities = sceneAnimation $ do
bg <- newSpriteA $ staticFrame 0 spectrumGrid bg <- newSpriteSVG $ spectrumGrid True
spriteZ bg 1 spriteZ bg 1
forM_ keys $ \(datA, datB, name) -> do forM_ keys $ \(datA, datB, name) -> do
@ -92,7 +94,7 @@ drawMorphingSensitivities = sceneAnimation $ do
, (medium, yCoords, greenName) , (medium, yCoords, greenName)
, (long, xCoords, redName)] , (long, xCoords, redName)]
drawDur = 3 drawDur = 3
{-
colorSpacesScene :: Animation colorSpacesScene :: Animation
colorSpacesScene = sceneAnimation $ mdo colorSpacesScene = sceneAnimation $ mdo
beginT <- queryNow beginT <- queryNow
@ -167,7 +169,7 @@ colorSpacesScene = sceneAnimation $ mdo
drawDur = 3 drawDur = 3
drawStagger = 1 drawStagger = 1
drawPause = 4 drawPause = 4
-}
drawLabelS = drawLabel "S" blueName drawLabelS = drawLabel "S" blueName
drawLabelM = drawLabel "M" greenName drawLabelM = drawLabel "M" greenName
drawLabelL = drawLabel "L" redName drawLabelL = drawLabel "L" redName
@ -176,25 +178,63 @@ drawLabelZ = drawLabel "Z" blueName
drawLabelY = drawLabel "Y" greenName drawLabelY = drawLabel "Y" greenName
drawLabelX = drawLabel "X" redName drawLabelX = drawLabel "X" redName
scene2Intro :: Animation
scene2Intro = staticFrame 10 (spectrumGrid False)
illustrateSpectrum :: Animation
illustrateSpectrum = sceneAnimation $ do
grid <- newSpriteSVG $ spectrumGrid False
spriteZ grid 1
forM_ (zip [0 ..] spectrum) $ \(nth, intensity) -> do
let nm = fromIntegral nth * (300/23/2) + 400
fork $ drawLine nm intensity
wait 0.05
wait 5
return ()
where
spectrum =
[ 0.02, 0.03, 0.07, 0.1, 0.2, 0.35, 0.7, 0.8, 0.9 ,0.75, 0.5 ] ++
[ 0.3, 0.27, 0.31, 0.25, 0.3, 0.35, 0.4, 0.5] ++
[ 0.65, 0.8, 0.95, 1.0, 0.95, 0.98, 0.93, 0.97] ++
[ 0.85, 0.75, 0.65, 0.60, 0.55, 0.52, 0.48, 0.45] ++
[ 0.45, 0.40, 0.35, 0.30, 0.25, 0.20, 0.15, 0.15, 0.15, 0.13, 0.11, 0.08]
drawLine nm intensity = do
let Just c = fmap (promotePixel.toRGB8) (nmToColor (round nm))
s <- newSpriteSVG $
pathify $
withStrokeColorPixel c $
translate (-spectrumWidth/2) (-spectrumHeight/2) $
translate (fromToS 0 spectrumWidth ((nm-400)/(700-400))) 0 $
mkLine (0,0) (0, spectrumHeight*intensity)
spriteE s $ overEnding 0.3 fadeOutE
-- spriteTween s intensity $ partialSvg . curveS 2
spriteTween s 0.8 $ partialSvg . curveS 2
scene2 :: Animation scene2 :: Animation
scene2 = {- dropA 29 $-} sceneAnimation $ do scene2 = seqA scene2Intro $ seqA illustrateSpectrum $ sceneAnimation $ do
oldGrid <- newSpriteSVG $ spectrumGrid False
newGrid <- newSpriteSVG $ spectrumGrid True
spriteTween newGrid 0.5 withGroupOpacity
destroySprite newGrid
destroySprite oldGrid
-- SML labels and timings. -- SML labels and timings.
labelS <- fork $ newSpriteA $ drawLabelS labelS <- newSpriteSVG $ drawLabelSVG "S" blueName
# applyE (overBeginning 0.3 fadeInE) spriteMap labelS $ uncurry translate (labelPosition short)
# applyE (overEnding 0.2 fadeOutE)
# mapA (uncurry translate (labelPosition short))
labelM <- fork $ do labelM <- fork $ do
wait 2 wait 2.1
newSpriteA $ drawLabelM newSpriteA $ drawLabelM
# applyE (overBeginning 0.3 fadeInE) spriteMap labelM $ uncurry translate (labelPosition medium)
# applyE (overEnding 0.2 fadeOutE)
# mapA (uncurry translate (labelPosition medium))
labelL <- fork $ do labelL <- fork $ do
wait 3.5 wait 3.5
newSpriteA $ drawLabelL newSpriteA $ drawLabelL
# applyE (overBeginning 0.3 fadeInE) spriteMap labelL $ uncurry translate (labelPosition long)
# applyE (overEnding 0.2 fadeOutE)
# mapA (uncurry translate (labelPosition long)) forM_ [labelS, labelM, labelL] $ \label -> do
spriteE label $ overBeginning 0.3 fadeInE
spriteE label $ overEnding 0.3 fadeOutE
play $ drawSensitivities play $ drawSensitivities
# pauseAtEnd 1 # pauseAtEnd 1
@ -207,15 +247,15 @@ scene2 = {- dropA 29 $-} sceneAnimation $ do
-- XYZ labels and timings -- XYZ labels and timings
wait (duration drawMorphingSensitivities) wait (duration drawMorphingSensitivities)
labelZ <- fork $ newSpriteA $ drawLabelZ labelZ <- fork $ newSpriteA $ drawLabelZ
# applyE (overBeginning 0.3 fadeInE) spriteE labelZ $ overBeginning 0.3 fadeInE
labelZPos <- spriteVar labelZ (labelPosition zCoords) $ uncurry translate labelZPos <- spriteVar labelZ (labelPosition zCoords) $ uncurry translate
labelY <- fork $ newSpriteA $ drawLabelY labelY <- fork $ newSpriteA $ drawLabelY
# applyE (overBeginning 0.3 fadeInE) spriteE labelY $ overBeginning 0.3 fadeInE
labelYPos <- spriteVar labelY (labelPosition yCoords) $ uncurry translate labelYPos <- spriteVar labelY (labelPosition yCoords) $ uncurry translate
labelX <- fork $ newSpriteA $ drawLabelX labelX <- fork $ newSpriteA $ drawLabelX
# applyE (overBeginning 0.3 fadeInE) spriteE labelX $ overBeginning 0.3 fadeInE
labelXPos <- spriteVar labelX (labelPosition xCoords) $ uncurry translate labelXPos <- spriteVar labelX (labelPosition xCoords) $ uncurry translate
wait 4 wait 4
@ -243,15 +283,17 @@ scene2 = {- dropA 29 $-} sceneAnimation $ do
redFactor <- newVar 0 redFactor <- newVar 0
greenFactor <- newVar 0 greenFactor <- newVar 0
blueFactor <- newVar 0 blueFactor <- newVar 0
xyzSpace <- newSprite $ do xyzSpace <- newSprite $
getRed <- freezeVar redFactor cieXYImage
getGreen <- freezeVar greenFactor <$> unVar redFactor
getBlue <- freezeVar blueFactor <*> unVar greenFactor
return $ \real_t d t -> <*> unVar blueFactor
cieXYImage (getRed real_t) (getGreen real_t) (getBlue real_t) imgSize <*> pure imgSize
-- xyzSpace <- newSparite $ cieXYImage <$> unVar redFactor <*> unVar greenFactor <*> unVar blueFactor spriteMap xyzSpace $ translate (-screenWidth/4) 0
spriteE xyzSpace $ constE $ translate (-screenWidth/4) 0
spriteZ xyzSpace (-1) spriteZ xyzSpace (-1)
spriteTween xyzSpace 0.5 $ aroundCenter . scale . curveS 2
wait 1
@ -265,21 +307,49 @@ scene2 = {- dropA 29 $-} sceneAnimation $ do
tweenVar blueFactor 1 $ \v -> fromToS v 1 . curveS 2 tweenVar blueFactor 1 $ \v -> fromToS v 1 . curveS 2
wait 3 wait 3
visLine <- fork $ newSpriteA' SyncFreeze $ mkAnimation 3 $ \t -> let downShift = 1
withStrokeWidth 0.03 $ withStrokeColor "white" $ morphXYZCoordinates t visCurve <- newVar 0
waveLine <- fork $ newSpriteSVG $
translate (screenWidth/4) 0 $
scale 0.5 $
translate 0 (-spectrumHeight/2) $
wavelengthAxis
spriteTween waveLine 1 $ \d ->
translate 0 (fromToS 0 (-downShift) $ curveS 2 d)
-- wait 1
visLine <- newSprite $
withStrokeWidth 0.03 . withStrokeColor "white" . morphXYZCoordinates
<$> unVar visCurve
spriteZ visLine (1) spriteZ visLine (1)
spriteTween waveLine 0.5 $ \t -> withGroupOpacity (1-t)
destroySprite waveLine
visSide <- spriteVar visLine 0 $ \t -> visSide <- spriteVar visLine 0 $ \t ->
translate 0 (-downShift) .
translate (fromToS (screenWidth/4) (-screenWidth/4) $ curveS 2 t) 0 . translate (fromToS (screenWidth/4) (-screenWidth/4) $ curveS 2 t) 0 .
scale (fromToS 0.5 1 $ curveS 2 t) . scale (fromToS 0.5 1 $ curveS 2 t) .
translate 0 (fromToS (-spectrumHeight/2) 0 $ curveS 2 t) translate 0 (fromToS (-spectrumHeight/2) 0 $ curveS 2 t)
fork $ tweenVar visSide 3 $ \v -> fromToS v 1 fork $ tweenVar visSide 3 $ \v -> fromToS v 1 . curveS 2
fork $ tweenVar visCurve 3 $ \v -> fromToS v 1 . curveS 2
fork $ spriteTween visLine 3 $ \d ->
translate 0 (fromToS 0 downShift $ curveS 2 d)
obsVisible <- newVar 1 obsVisible <- newVar 1
gamut <- newVar 0 gamut <- newVar 0
reorient <- newVar 0
cmOpacity <- newVar 1
cmDelta <- newVar 0
cmName <- newVar "sinebow"
cmFunc <- newVar sinebow
visSpace <- fork $ newSprite $ do visSpace <- fork $ newSprite $ do
getObs <- freezeVar obsVisible getObs <- unVar obsVisible
getGamut <- freezeVar gamut getGamut <- unVar gamut
return $ \real_t d t -> getReorient <- unVar reorient
getOpacity <- unVar cmOpacity
getDelta <- unVar cmDelta
getFunc <- unVar cmFunc
return $
translate (-screenWidth/4) 0 $ translate (-screenWidth/4) 0 $
mkGroup mkGroup
[ mkClipPath "visible" [ mkClipPath "visible"
@ -288,16 +358,43 @@ scene2 = {- dropA 29 $-} sceneAnimation $ do
] ]
, mkClipPath "sRGB" , mkClipPath "sRGB"
[ simplify $ [ simplify $
sRGBTriangle (getGamut real_t) sRGBTriangle getGamut
] ]
, withGroupOpacity (getObs real_t) $ , withGroupOpacity getObs $
withClipPathRef (Ref "visible") $ withClipPathRef (Ref "visible") $
mkGroup [cieXYImage 1 1 1 imgSize] mkGroup [cieXYImage 1 1 1 imgSize]
, withClipPathRef (Ref "sRGB") $ , translate 0 (1*getReorient) $
mkGroup [cieXYImageGamut (getGamut real_t) imgSize] rotate (-gamutSlope sRGBGamut * getReorient) $
mkGroup
[ scale (1+0.5*getReorient) $
withClipPathRef (Ref "sRGB") $
mkGroup [cieXYImageGamut getGamut imgSize]
, lowerTransformations $ scale (1+0.5*getReorient) $
withGroupOpacity getOpacity $
cmToTernary getDelta getFunc
]
, withGroupOpacity getReorient $
translate 0 3.5 $ scale 0.5 $
center $ withFillColor "white" $
latex "sRGB"
] ]
colorMap <- newSprite $ do
getOpacity <- unVar cmOpacity
getDelta <- unVar cmDelta
getFunc <- unVar cmFunc
getName <- unVar cmName
return $
withGroupOpacity getOpacity $
mkGroup
[ renderColorMap getDelta (screenWidth*0.75) (screenHeight*0.15) getFunc
, withGroupOpacity (getDelta * 2) $
withFillColor "white" $
translate 0 1.2 $
scale 0.7 $
center $ latex getName
]
spriteTween colorMap 0 $ const $ translate 0 (-3)
wait 4 wait 4
fork $ spriteTween visLine 1 $ \t -> withGroupOpacity (1-t) fork $ spriteTween visLine 1 $ \t -> withGroupOpacity (1-t)
@ -306,29 +403,167 @@ scene2 = {- dropA 29 $-} sceneAnimation $ do
fork $ spriteTween xyzGraph 1 $ \t -> withGroupOpacity (1-t) fork $ spriteTween xyzGraph 1 $ \t -> withGroupOpacity (1-t)
fork $ spriteTween labelX 1 $ \t -> withGroupOpacity (1-t) fork $ tweenVar labelXPos 1 $ \(x,y) t ->
fork $ spriteTween labelY 1 $ \t -> withGroupOpacity (1-t) let (newX, newY) = (-1,3)
fork $ spriteTween labelZ 1 $ \t -> withGroupOpacity (1-t) s = curveS 2 t
in (fromToS x newX s, fromToS y newY s)
fork $ tweenVar labelYPos 1 $ \(x,y) t ->
let (newX, newY) = (0,3)
s = curveS 2 t
in (fromToS x newX s, fromToS y newY s)
fork $ tweenVar labelZPos 1 $ \(x,y) t ->
let (newX, newY) = (1,3)
s = curveS 2 t
in (fromToS x newX s, fromToS y newY s)
-- fork $ spriteTween labelX 1 $ \t -> withGroupOpacity (1-t)
-- fork $ spriteTween labelY 1 $ \t -> withGroupOpacity (1-t)
-- fork $ spriteTween labelZ 1 $ \t -> withGroupOpacity (1-t)
wait 1 -- wait 1
spriteZ visSpace (-1)
spriteTween visSpace 1 $ \t -> spriteTween visSpace 1 $ \t ->
translate (fromToS 0 (screenWidth/4) $ curveS 2 t) 0 translate (fromToS 0 (screenWidth/4) $ curveS 2 t) 0
wait 2 wait 2
rgb <- newSprite $ do rgb <- newSprite $ withStrokeColor "white" . sRGBTriangle <$> unVar gamut
getGamut <- freezeVar gamut
return $ \real_t d t ->
withStrokeColor "white" $ sRGBTriangle (getGamut real_t)
spriteTween rgb 1 $ partialSvg spriteTween rgb 1 $ partialSvg
wait 1 wait 1
tweenVar obsVisible 1 $ \v -> fromToS v 0 . curveS 2
wait 1
fork $ spriteTween rgb 1 $ \t -> withGroupOpacity (1-t) fork $ spriteTween rgb 1 $ \t -> withGroupOpacity (1-t)
tweenVar gamut 1 $ \v -> fromToS v 1 . curveS 2
fork $ spriteTween labelX 1 $ \t -> withGroupOpacity (1-t)
fork $ spriteTween labelY 1 $ \t -> withGroupOpacity (1-t)
fork $ spriteTween labelZ 1 $ \t -> withGroupOpacity (1-t)
tweenVar obsVisible 1 $ \v -> fromToS v 0 . curveS 2
wait 1
-- tweenVar gamut 1 $ \v -> fromToS v 1 . curveS 2
tweenVar reorient 1 $ \v -> fromToS v 1 . curveS 2
wait 1
writeVar cmName "jet"
writeVar cmFunc jet
tweenVar cmDelta 1 $ \d -> fromToS d 1
wait 2 wait 2
spriteTween visSpace 1 $ \t -> translate (-2.5*curveS 2 t) 0
hsv <- newSprite $ do
getOpacity <- unVar cmOpacity
getDelta <- unVar cmDelta
getFunc <- unVar cmFunc
return $
mkGroup
[ lowerTransformations $
scaleToWidth (screenWidth*0.20) $
mkGroup [ hsvColorSpace 100
, withGroupOpacity getOpacity $
cmToHSV getDelta getFunc]
, translate 0 2 $ scale 0.5 $
center $ withFillColor "white" $
latex "HSV" ]
-- lchColorSpace 100
-- cieLABImage 100 50
-- cieLABImage 2000 2000
spriteTween hsv 0 $ const $ translate 3 1.5
spriteTween hsv 1 withGroupOpacity
wait 1
tweenVar cmOpacity 0.3 $ \o t -> fromToS o 0 t
writeVar cmName "sinebow"
writeVar cmFunc sinebow
writeVar cmOpacity 1
writeVar cmDelta 0
tweenVar cmDelta 5 $ \d -> fromToS d 1
wait 1
tweenVar cmOpacity 0.3 $ \o t -> fromToS o 0 t
writeVar cmName "parula"
writeVar cmFunc parula
writeVar cmOpacity 1
writeVar cmDelta 0
tweenVar cmDelta 5 $ \d -> fromToS d 1
wait 1
fork $ spriteTween hsv 1 $ \t -> translate (2*curveS 2 t) 0
spriteTween visSpace 1 $ \t -> translate (-2*curveS 2 t) 0
lab <- newSprite $ do
getOpacity <- unVar cmOpacity
getDelta <- unVar cmDelta
getFunc <- unVar cmFunc
return $
mkGroup
[ lowerTransformations $
scaleToWidth (screenWidth/4) $
mkGroup [ cieLABImagePixels
, withGroupOpacity getOpacity $
cmToLAB getDelta getFunc]
, translate 0 2 $ scale 0.5 $
center $ withFillColor "white" $
latex "LAB" ]
spriteTween lab 0 $ const $ translate 0 1.5
spriteTween lab 1 withGroupOpacity
-- tweenVar rgbCM 1 $ \(cm,d) t -> (parula ,fromToS 0 1 t)
wait 1
tweenVar cmOpacity 0.3 $ \o t -> fromToS o 0 t
writeVar cmName "viridis"
writeVar cmFunc viridis
writeVar cmOpacity 1
writeVar cmDelta 0
tweenVar cmDelta 5 $ \d -> fromToS d 1
wait 1
tweenVar cmOpacity 0.3 $ \o t -> fromToS o 0 t
writeVar cmName "plasma"
writeVar cmFunc plasma
writeVar cmOpacity 1
writeVar cmDelta 0
tweenVar cmDelta 5 $ \d -> fromToS d 1
wait 1
tweenVar cmOpacity 0.3 $ \o t -> fromToS o 0 t
writeVar cmName "cividis"
writeVar cmFunc cividis
writeVar cmOpacity 1
writeVar cmDelta 0
tweenVar cmDelta 5 $ \d -> fromToS d 1
wait 1
tweenVar cmOpacity 0.3 $ \o t -> fromToS o 0 t
writeVar cmName "jet"
writeVar cmFunc jet
writeVar cmOpacity 1
writeVar cmDelta 0
tweenVar cmDelta 5 $ \d -> fromToS d 1
wait 1
tweenVar cmOpacity 0.3 $ \o t -> fromToS o 0 t
writeVar cmName "turbo"
writeVar cmFunc turbo
writeVar cmOpacity 1
writeVar cmDelta 0
tweenVar cmDelta 5 $ \d -> fromToS d 1
wait 1
return () return ()
where where
imgSize = 50 imgSize = 50
@ -337,6 +572,18 @@ scene2 = {- dropA 29 $-} sceneAnimation $ do
scale 5 $ scale 5 $
renderXYZCoordinatesTernary renderXYZCoordinatesTernary
renderColorMap :: Double -> Double -> Double -> (Double -> PixelRGB8) -> Tree
renderColorMap delta width height cmap =
translate (-width/2 * (1-delta)) 0 $
mkGroup
[ scaleToSize (width*delta) height $ showColorMap (\t -> cmap (t*delta))
, withStrokeWidth (defaultStrokeWidth*0.7) $
withStrokeColor "white" $ withFillOpacity 0 $
mkRect (width*delta) height
]
{-
scene3 :: Animation scene3 :: Animation
scene3 = sceneAnimation $ do scene3 = sceneAnimation $ do
play $ mkAnimation 1 $ \t -> cieXYImage 0 0 t imgSize play $ mkAnimation 1 $ \t -> cieXYImage 0 0 t imgSize
@ -355,7 +602,9 @@ scene3 = sceneAnimation $ do
lowerTransformations $ lowerTransformations $
scale (100/2) $ scale (100/2) $
renderLABCoordinates renderLABCoordinates
-}
{-
frame = mkAnimation 2 $ \t -> frame = mkAnimation 2 $ \t ->
-- emit $ mkBackground "black" -- emit $ mkBackground "black"
-- emit $ spectrumGrid -- emit $ spectrumGrid
@ -399,7 +648,7 @@ frame = mkAnimation 2 $ \t ->
imgSize :: Num a => a imgSize :: Num a => a
imgSize = 1000 imgSize = 1000
img1 = cieXYImage 1 1 1 imgSize img1 = cieXYImage 1 1 1 imgSize
img2 = cieLABImage imgSize imgSize img2 = cieLABImage imgSize 50
obsColors = obsColors =
lowerTransformations $ lowerTransformations $
scale 5 $ scale 5 $
@ -408,7 +657,9 @@ frame = mkAnimation 2 $ \t ->
lowerTransformations $ lowerTransformations $
scale (100/2) $ scale (100/2) $
renderLABCoordinates renderLABCoordinates
-}
{-
xyzTernaryPlot = mkAnimation 2 $ \t -> xyzTernaryPlot = mkAnimation 2 $ \t ->
-- emit $ mkBackground "black" -- emit $ mkBackground "black"
-- emit $ spectrumGrid -- emit $ spectrumGrid
@ -451,7 +702,7 @@ xyzTernaryPlot = mkAnimation 2 $ \t ->
imgSize :: Num a => a imgSize :: Num a => a
imgSize = 50 imgSize = 50
img1 t = cieXYImage t t t imgSize img1 t = cieXYImage t t t imgSize
img2 = cieLABImage imgSize imgSize img2 = cieLABImage imgSize 50
obsColors = obsColors =
lowerTransformations $ lowerTransformations $
scale 5 $ scale 5 $
@ -460,7 +711,7 @@ xyzTernaryPlot = mkAnimation 2 $ \t ->
lowerTransformations $ lowerTransformations $
scale (100/2) $ scale (100/2) $
renderLABCoordinates renderLABCoordinates
-}
renderXYZCoordinatesTernary :: Tree renderXYZCoordinatesTernary :: Tree
renderXYZCoordinatesTernary = renderXYZCoordinatesTernary =
@ -496,7 +747,7 @@ cieXYImageGamut t density = Ternary.ternaryPlot density $ \aCoord bCoord cCoord
aCoord' = fromToS aCoord (rX * aCoord + gX * bCoord + bX * cCoord) t aCoord' = fromToS aCoord (rX * aCoord + gX * bCoord + bX * cCoord) t
bCoord' = fromToS bCoord (rY * aCoord + gY * bCoord + bY * cCoord) t bCoord' = fromToS bCoord (rY * aCoord + gY * bCoord + bY * cCoord) t
cCoord' = fromToS cCoord (rZ * aCoord + gZ * bCoord + bZ * cCoord) t cCoord' = fromToS cCoord (rZ * aCoord + gZ * bCoord + bZ * cCoord) t
RGB r g b = toSRGBBounded (cieXYZ aCoord' bCoord' cCoord) RGB r g b = toSRGBBounded (cieXYZ aCoord' bCoord' cCoord')
in PixelRGBA8 r g b 0xFF in PixelRGBA8 r g b 0xFF
where where
RGB r g b = primaries sRGBGamut RGB r g b = primaries sRGBGamut
@ -504,6 +755,80 @@ cieXYImageGamut t density = Ternary.ternaryPlot density $ \aCoord bCoord cCoord
(gX, gY, gZ) = chromaCoords $ chromaConvert g (gX, gY, gZ) = chromaCoords $ chromaConvert g
(bX, bY, bZ) = chromaCoords $ chromaConvert b (bX, bY, bZ) = chromaCoords $ chromaConvert b
-- slope in degrees
gamutSlope :: RGBGamut -> Double
gamutSlope gamut = atan2 (y1/y2) (x1/x2) / pi * 180
where
RGB r g b = primaries sRGBGamut
(gX, gY, _gZ) = chromaCoords $ chromaConvert g
(bX, bY, _bZ) = chromaCoords $ chromaConvert b
(x1, y1) = Ternary.toCartesianCoords gX gY
(x2, y2) = Ternary.toCartesianCoords bX bY
strokeLine :: Double -> [(Double, Double)] -> SVG
strokeLine t points = mkGroup
[ withStrokeWidth (defaultStrokeWidth*1) $
withFillOpacity 0 $ withStrokeColor "black" $
partialSvg t $
mkLinePath points
& strokeLineCap .~ pure CapRound
, withStrokeWidth (defaultStrokeWidth*0.5) $
withFillOpacity 0 $ withStrokeColor "white" $
partialSvg t $ mkLinePath points
& strokeLineCap .~ pure CapRound
]
-- 0.15 0.06 -> 0 0
cmToTernary :: Double -> (Double -> PixelRGB8) -> Tree
cmToTernary 0 _ = mkGroup []
cmToTernary t cm =
lowerTransformations $ scale 5 $
strokeLine t points
where
steps = 100
points =
[ Ternary.toOffsetCartesianCoords (cieY/s) (cieX/s)
| n <- [0..steps]
, let PixelRGB8 red green blue = cm (fromIntegral n / fromIntegral steps)
(cieX,cieY,cieZ) = cieXYZView (sRGB24 red green blue)
s = cieX + cieY + cieZ
]
cmToHSV :: Double -> (Double -> PixelRGB8) -> Tree
cmToHSV t cm =
lowerTransformations $ scale (screenHeight/2) $
strokeLine t points
where
steps = 100
points =
[ (cos radian * s, sin radian * s)
| n <- [0..steps]
, let PixelRGB8 red green blue = cm (fromIntegral n / fromIntegral steps)
(h,s,_v) = hsvView (toSRGB $ sRGB24 red green blue)
radian = h/180*pi
]
-- dim = 100
-- -labScaleX = 0
-- 0 = dim/2
-- +labScaleX = dim
-- -labScaleX to +labScaleX
cmToLAB :: Double -> (Double -> PixelRGB8) -> Tree
cmToLAB t cm =
lowerTransformations $
translate (-screenHeight/2) (-screenHeight/2) $
strokeLine t points
where
steps = 100
points =
[ ( (a+labScaleX)/(labScaleX*2)*screenHeight,
(b+labScaleY)/(labScaleY*2)*screenHeight )
| n <- [0..steps]
, let PixelRGB8 red green blue = cm (fromIntegral n / fromIntegral steps)
(_l,a,b) = cieLABView d65 (sRGB24 red green blue)
]
-- aCoord = red -- aCoord = red
-- bCoord = green -- bCoord = green
-- cCoord = blue -- cCoord = blue
@ -524,17 +849,54 @@ cieXYImage redFactor greenFactor blueFactor density =
-- RGB r g b = toSRGBBounded (chromaColour d65 1) -- RGB r g b = toSRGBBounded (chromaColour d65 1)
in PixelRGBA8 r g b 0xFF in PixelRGBA8 r g b 0xFF
cieLABImage :: Int -> Int -> Tree cieLABImagePixels :: SVG
cieLABImage width height = embedImage $ generateImage gen width height cieLABImagePixels = scaleToHeight screenHeight $ embedImage $
unsafePerformIO $ do
dat <- BS.readFile "lab.png"
case decodePng dat of
Left err -> error err
Right img -> return $ convertRGBA8 img
cieLABImages :: Int -> Tree
cieLABImages dim = mkGroup
[ cieLABImage dim lStar
| lStar <- [40..95]
]
cieLABImage :: Int -> Double -> Tree
cieLABImage dim = embedImage . cieLABImage' dim
cieLABImage' dim lStar = generateImage gen dim dim
where where
gen x y = gen x y =
let let
aStar = (fromIntegral x / fromIntegral width) * labScaleX*2 - labScaleX aStar = (fromIntegral x / fromIntegral dim) * labScaleX*2 - labScaleX
bStar = (1-(fromIntegral y / fromIntegral height)) * labScaleY*2 - labScaleY bStar = (1-(fromIntegral y / fromIntegral dim)) * labScaleY*2 - labScaleY
lStar = findLStar aStar bStar -- lStar = 50 -- findLStar aStar bStar
color = cieLAB d65 lStar aStar bStar
RGB r g b = toSRGBBounded (cieLAB d65 lStar aStar bStar) RGB r g b = toSRGBBounded (cieLAB d65 lStar aStar bStar)
-- RGB r g b = RGB (round $ lStar/100 * 255) (round $ lStar/100 * 255) (round $ lStar/100 * 255) -- RGB r g b = RGB (round $ lStar/100 * 255) (round $ lStar/100 * 255) (round $ lStar/100 * 255)
in PixelRGB8 r g b in if inGamut sRGBGamut color
then PixelRGBA8 r g b 0xFF
else PixelRGBA8 0xFF 0xFF 0xFF 0x00
cieLABImage_ :: Int -> Tree
cieLABImage_ = embedImage . cieLABImage_'
cieLABImage_' dim = generateImage gen dim dim
where
gen x y =
let
aStar = (fromIntegral x / fromIntegral dim) * labScaleX*2 - labScaleX
bStar = (1-(fromIntegral y / fromIntegral dim)) * labScaleY*2 - labScaleY
-- lStar = 50 -- findLStar aStar bStar
colors = [ toSRGBBounded color
| lStar <- reverse [40 .. 95]
, let color = cieLAB d65 lStar aStar bStar
, inGamut sRGBGamut color ]
in case listToMaybe colors of
Nothing -> PixelRGBA8 0xFF 0xFF 0xFF 0x00
Just (RGB r g b) -> PixelRGBA8 r g b 0xFF
findLStar :: Double -> Double -> Double findLStar :: Double -> Double -> Double
findLStar aStar bStar = worker 0 100 10 findLStar aStar bStar = worker 0 100 10
@ -589,6 +951,7 @@ mkClosedLinePath :: [(Double, Double)] -> Tree
mkClosedLinePath [] = mkGroup [] mkClosedLinePath [] = mkGroup []
mkClosedLinePath ((startX, startY):rest) = mkClosedLinePath ((startX, startY):rest) =
PathTree $ defaultSvg & pathDefinition .~ cmds PathTree $ defaultSvg & pathDefinition .~ cmds
& strokeLineJoin .~ pure JoinRound
where where
cmds = [ MoveTo OriginAbsolute [V2 startX startY] cmds = [ MoveTo OriginAbsolute [V2 startX startY]
, LineTo OriginAbsolute [ V2 x y | (x, y) <- rest ] , LineTo OriginAbsolute [ V2 x y | (x, y) <- rest ]
@ -597,8 +960,32 @@ mkClosedLinePath ((startX, startY):rest) =
spectrumHeight = screenHeight * 0.5 spectrumHeight = screenHeight * 0.5
spectrumWidth = screenWidth * 0.7 spectrumWidth = screenWidth * 0.7
spectrumGrid :: Tree
spectrumGrid = wavelengthAxis :: Tree
wavelengthAxis =
withStrokeWidth strokeWidth $
mkGroup
[ translate (-spectrumWidth/2) 0 $
withFillOpacity 0 $ withStrokeColor "white" $ mkPath $
[ MoveTo OriginAbsolute [V2 0 0]
, VerticalTo OriginRelative [tickLength,-tickLength]
, HorizontalTo OriginRelative [spectrumWidth]
, VerticalTo OriginRelative [tickLength,-tickLength]
]
++ concat
[ [ MoveTo OriginAbsolute [V2 (n / (nTicksX-1) * spectrumWidth) 0]
, VerticalTo OriginRelative [tickLength]]
| n <- [0..nTicksX-1]
]
]
where
strokeWidth = 0.03
nTicksX = 24
nTicksY = fromIntegral (round (spectrumHeight/spectrumWidth * nTicksX))
tickLength = spectrumHeight*0.02
spectrumGrid :: Bool -> Tree
spectrumGrid includeSensitivity =
withStrokeWidth strokeWidth $ withStrokeWidth strokeWidth $
mkGroup mkGroup
[ --center $ [ --center $
@ -620,20 +1007,22 @@ spectrumGrid =
, HorizontalTo OriginRelative [tickLength]] , HorizontalTo OriginRelative [tickLength]]
| n <- [0..nTicksY-1] | n <- [0..nTicksY-1]
] ]
, withFillColor "white" $ , if includeSensitivity
translate (-spectrumWidth*0.5 + svgWidth sensitivity*1.2) 0 $ then withFillColor "white" $
sensitivity translate (-spectrumWidth*0.5 + svgWidth sensitivity*1.2) 0 $
sensitivity
else None
, withFillColor "white" $ , withFillColor "white" $
translate 0 (-spectrumHeight*0.5 + svgHeight wavelength*1.2) $ translate 0 (-spectrumHeight*0.5 + svgHeight wavelength*1.2) $
wavelength wavelength
-- , withFillColor "white" $ , withFillColor "white" $
-- translate (-spectrumWidth*0.5 + svgWidth shortWaves/2) translate (-spectrumWidth*0.5 - svgWidth shortWaves)
-- (-spectrumHeight*0.5 + svgHeight shortWaves) $ (-spectrumHeight*0.5 + svgHeight shortWaves*1.2) $
-- shortWaves shortWaves
-- , withFillColor "white" $ , withFillColor "white" $
-- translate (spectrumWidth*0.5 - svgWidth shortWaves/2) translate (spectrumWidth*0.5 - svgWidth longWaves)
-- (-spectrumHeight*0.5 + svgHeight shortWaves) $ (-spectrumHeight*0.5 + svgHeight longWaves*1.2) $
-- longWaves longWaves
] ]
where where
strokeWidth = 0.03 strokeWidth = 0.03
@ -649,12 +1038,12 @@ spectrumGrid =
scale 0.8 $ scale 0.8 $
latex "Wavelength" latex "Wavelength"
shortWaves = shortWaves =
center $ rotate (-45) $ center $
scale 0.6 $ scale 0.3 $
latex "400 nm" latex "400 nm"
longWaves = longWaves =
center $ rotate (-45) $ center $
scale 0.6 $ scale 0.3 $
latex "700 nm" latex "700 nm"
@ -679,6 +1068,15 @@ morphSensitivity datA datB c = animate $ \t ->
-- mkBackground "green" -- mkBackground "green"
sensitivitySVG :: Double -> Double -> [(Nanometer, Double)] -> String -> Tree sensitivitySVG :: Double -> Double -> [(Nanometer, Double)] -> String -> Tree
sensitivitySVG maxHeight limit dat c = sensitivitySVG maxHeight limit dat c =
mkGroup
[ mkClipPath "spectrum" $
let margin = 1 in
[ simplify $ lowerTransformations $
translate 0 (margin/2) $
pathify $
mkRect spectrumWidth (spectrumHeight+margin)
]
,
withClipPathRef (Ref "spectrum") $ withClipPathRef (Ref "spectrum") $
simplify $ lowerTransformations $ simplify $ lowerTransformations $
withStrokeColor c $ withStrokeColor c $
@ -692,7 +1090,7 @@ sensitivitySVG maxHeight limit dat c =
x = percent * spectrumWidth x = percent * spectrumWidth
y = n/maxHeight * spectrumHeight y = n/maxHeight * spectrumHeight
, percent <= limit , percent <= limit
] ] ]
where where
initNM = fromIntegral $ fst (head dat) initNM = fromIntegral $ fst (head dat)
lastNM = 700 -- fromIntegral $ fst (last dat) lastNM = 700 -- fromIntegral $ fst (last dat)
@ -719,6 +1117,17 @@ drawLabel label c = animate $ const $
scale 1 $ scale 1 $
latex label latex label
drawLabelSVG :: Text -> String -> SVG
drawLabelSVG label c =
translate (0) (-svgHeight labelSVG * 1.5) $
withFillColor c $
labelSVG
where
labelSVG =
center $
scale 1 $
latex label
moveUp :: SVG -> SVG moveUp :: SVG -> SVG
moveUp svg = translate 0 (-svgHeight svg * 1.5) svg moveUp svg = translate 0 (-svgHeight svg * 1.5) svg
@ -750,41 +1159,44 @@ interpolation = mkAnimation 2 $ \t ->
cyan = PixelRGB8 0x00 0xFF 0xFF cyan = PixelRGB8 0x00 0xFF 0xFF
red = PixelRGB8 0xFF 0x00 0x00 red = PixelRGB8 0xFF 0x00 0x00
lchColorSpace :: Int -> Int -> Tree lchColorSpace :: Int -> Tree
lchColorSpace width height = embedImage $ generateImage gen width height lchColorSpace width =
where circlePlot width $ \ang radius ->
toRad deg = deg/180 * pi let
gen x y = toRad deg = deg/180 * pi
let h = ang/pi*180
h = fromToS 0 360 (fromIntegral x / fromIntegral width) aStar = (cos (toRad h) * c)
aStar = (cos (toRad h) * c) bStar = (sin (toRad h) * c)
bStar = (sin (toRad h) * c) l = 50 -- findLStar aStar bStar
l = findLStar aStar bStar c = fromToS 0 (sqrt (labScaleX^2 + labScaleY^2)) radius
c = fromToS 0 (sqrt (labScaleX^2 + labScaleY^2)) (fromIntegral y / fromIntegral height) -- RGB r g b = toSRGBBounded (colorPack lchComponents l c h)
-- RGB r g b = toSRGBBounded (colorPack lchComponents l c h) color = cieLAB d65 l aStar bStar
RGB r g b = toSRGBBounded (cieLAB d65 l aStar bStar) RGB r g b = toSRGBBounded color
in PixelRGB8 r g b in if inGamut sRGBGamut color
then PixelRGBA8 r g b 0xFF
else PixelRGBA8 0 0 0 0x00
hsvColorSpace :: Int -> Int -> Tree hsvColorSpace :: Int -> Tree
hsvColorSpace width height = embedImage $ generateImage gen width height hsvColorSpace width =
where circlePlot width $ \ang radius ->
toRad deg = deg/180 * pi let
gen x y = h = ang/pi*180
let v = 1
h = fromToS 0 360 (fromIntegral x / fromIntegral width) s = radius
v = 1 color = colorPack hsvComponents h s v
s = fromToS 0 1 (fromIntegral y / fromIntegral height) RGB r g b = toSRGBBounded color
RGB r g b = toSRGBBounded (colorPack hsvComponents h s v) in if inGamut sRGBGamut color
in PixelRGB8 r g b then PixelRGBA8 r g b 0xFF
else PixelRGBA8 0 0 0 0x00
spacesA :: Animation spacesA :: Animation
spacesA = mkAnimation 10 $ \t -> spacesA = mkAnimation 10 $ \t ->
scaleToSize screenWidth screenHeight $ scaleToSize screenWidth screenHeight $
if t < 0.3 if t < 0.3
then cieLABImage 100 100 then cieLABImage 100 50
else if t < 0.6 else if t < 0.6
then lchColorSpace 100 100 then lchColorSpace 100
else hsvColorSpace 100 100 else hsvColorSpace 100
highlightE :: Effect highlightE :: Effect
highlightE d t = highlightE d t =

174
videos/color-theory/color-theory.hs
View file

@ -18,22 +18,25 @@ import Data.Word
import Graphics.SvgTree hiding (Image, imageHeight, imageWidth) import Graphics.SvgTree hiding (Image, imageHeight, imageWidth)
import Graphics.SvgTree.Memo import Graphics.SvgTree.Memo
import Numeric import Numeric
import Reanimate.ColorMap
import Reanimate.Driver (reanimate)
import Reanimate.LaTeX
import Reanimate import Reanimate
import Reanimate.Animation import Reanimate.Animation
import Reanimate.ColorMap
import Reanimate.ColorSpace
import Reanimate.Builtin.Flip
import Reanimate.Constants
import Reanimate.Driver (reanimate)
import Reanimate.Effect
import Reanimate.LaTeX
import Reanimate.Raster import Reanimate.Raster
import Reanimate.Scene import Reanimate.Scene
import Reanimate.Signal import Reanimate.Signal
import Reanimate.Effect import Reanimate.Interpolate
import Reanimate.Svg import Reanimate.Svg
import Reanimate.ColorSpace
import Reanimate.Constants
import System.IO.Unsafe import System.IO.Unsafe
import Grid
import Spectrum import Spectrum
import EndScene
{- Scene sequence {- Scene sequence
- black - black
@ -63,11 +66,15 @@ import Spectrum
highdef = True highdef = True
main :: IO () main :: IO ()
main = reanimate $ main = reanimate $ -- takeA 10 $ dropA 55 $
(animate $ const $ mkBackground "black") `parA` parA (staticFrame 1 $ mkBackground "black") $
monalisaScene `seqA` monalisaScene `seqA`
-- colorSpacesScene falseColorScene `seqA`
scene2 scene2 `seqA`
(parA (staticFrame 1 $ mkBackground "aliceblue") $
overlapTransition 1.5 (signalT (curveS 2) flipTransition)
(parA (staticFrame 1 $ mkBackground "black") $ gridScene)
(parA (staticFrame 1 $ mkBackground "black") $ endScene))
-- scene3 -- scene3
-- xyzTernaryPlot -- xyzTernaryPlot
-- interpolation -- interpolation
@ -82,7 +89,7 @@ monalisaScene =
-- Draw numbers -- Draw numbers
fork $ fork $
play $ drawHexPixels play $ drawHexPixels
# setDuration (drawPixelDelay+toGrayScaleTime) # setDuration (drawPixelDelay+toGrayScaleTime+3)
# pauseAtBeginning beginPause # pauseAtBeginning beginPause
# fadeIn stdFade # fadeIn stdFade
wait beginPause wait beginPause
@ -90,19 +97,20 @@ monalisaScene =
let PixelRGB8 minR _ _ = minPixel monalisa let PixelRGB8 minR _ _ = minPixel monalisa
PixelRGB8 maxR _ _ = maxPixel monalisa PixelRGB8 maxR _ _ = maxPixel monalisa
waitAll $ do waitAll $ do
fork $ do
play $ drawPixelImage (fromIntegral minR/255) ((fromIntegral maxR+1)/255)
# setDuration toGrayScaleTime
# pauseAround drawPixelDelay 5
-- Move monalisa to the side of the screen
play $ sceneFalseColorIntro
-- Show colormap as monalisa fades in -- Show colormap as monalisa fades in
-- play $ showColorMap (fromIntegral minR/255) ((fromIntegral maxR+1)/255) play $ showColorMap (fromIntegral minR/255) ((fromIntegral maxR+1)/255)
-- # setDuration toGrayScaleTime # setDuration 2
-- # pauseAround 1 1 # pauseAround 1 1
-- # fadeIn stdFade # fadeIn stdFade
-- # fadeOut stdFade # fadeOut stdFade
play $ drawPixelImage (fromIntegral minR/255) ((fromIntegral maxR+1)/255)
# setDuration toGrayScaleTime
# pauseAround drawPixelDelay 3
-- Move monalisa to the side of the screen
play $ sceneFalseColorIntro
-- Cycle through colormaps for monalisa -- Cycle through colormaps for monalisa
-- play $ sceneColorMaps `sim` (sceneFalseColorChain $ map snd -- play $ sceneColorMaps `sim` (sceneFalseColorChain $ map snd
@ -123,6 +131,52 @@ monalisaScene =
stdFade = 0.3 stdFade = 0.3
toGrayScaleTime = 3 toGrayScaleTime = 3
falseColorScene :: Animation
falseColorScene = sceneAnimation $ do
delta <- newVar 0
cms <- newVar (greyscale, greyscale)
let total = 7
nth <- newVar 0
let pushCM label cm = do
(_, prevCM) <- readVar cms
writeVar delta 0
writeVar cms (prevCM, cm)
this <- readVar nth
writeVar nth (this+1)
s <- fork $ newSpriteA $ drawColorMap label cm
spriteE s (overBeginning 0.3 fadeInE)
spriteTween s 0 $ \_ -> positionColorMap total this
fork $ tweenVar delta 0.3 $ \v -> fromToS v 1 . curveS 2
wait 3
let cmSprite delta (cmap1, cmap2) t =
let s = curveS 3 t
cm x = interpolateRGB8 labComponents (cmap1 x) (cmap2 x) delta
in translate (screenWidth/4 - 0.75) 0 $
scaleToSize (screenWidth/2) (screenHeight/2) $
embedImage $ applyColorMap cm monalisa
s <- newSprite $
cmSprite
<$> unVar delta
<*> unVar cms
<*> spriteT
pushCM "greyscale" greyscale
pushCM "jet" jet
pushCM "turbo" turbo
pushCM "sinebow" sinebow
pushCM "parula" parula
pushCM "viridis" viridis
pushCM "cividis" cividis
wait 2
return ()
monalisa :: Image PixelRGB8 monalisa :: Image PixelRGB8
monalisa = unsafePerformIO $ do monalisa = unsafePerformIO $ do
@ -132,7 +186,7 @@ monalisa = unsafePerformIO $ do
Right img -> return $ convertRGB8 img Right img -> return $ convertRGB8 img
monalisaLarge :: Image PixelRGB8 monalisaLarge :: Image PixelRGB8
monalisaLarge = scaleImage 15 monalisa monalisaLarge = scaleImage (if highdef then 15 else 1) monalisa
maxPixel :: Image PixelRGB8 -> PixelRGB8 maxPixel :: Image PixelRGB8 -> PixelRGB8
maxPixel img = pixelFold (\acc _ _ pix -> max acc pix) (pixelAt img 0 0) img maxPixel img = pixelFold (\acc _ _ pix -> max acc pix) (pixelAt img 0 0) img
@ -213,14 +267,30 @@ sceneColorMaps = mkAnimation 5 $ const $
width = screenWidth*0.4 width = screenWidth*0.4
height = screenHeight*0.06 height = screenHeight*0.06
drawColorMap :: T.Text -> (Double -> PixelRGB8) -> Animation
drawColorMap label cmap = animate $ const $
mkGroup
[ renderColorMap width height cmap
, withFillColor "white" $ translate (-width/2 + screenWidth*0.01) (height*1.1) $
scale 0.3 $ latex label
]
where
width = screenWidth*0.4
height = screenHeight*0.06
positionColorMap :: Int -> Int -> SVG -> SVG
positionColorMap total nth =
translate xOffset (yInit - fromIntegral nth*yStep)
where
xOffset = -screenWidth*0.3
yInit = yStep*fromIntegral (total `div` 2)
yStep = height * 2.2
height = screenHeight*0.06
limitGreyPixels :: Word8 -> Image PixelRGB8 -> Image PixelRGBA8 limitGreyPixels :: Word8 -> Image PixelRGB8 -> Image PixelRGBA8
limitGreyPixels limit img = limitGreyPixels limit = pixelMap $ \pixel@(PixelRGB8 r _ _) ->
generateImage fn (imageWidth img) (imageHeight img) if r < limit then PixelRGBA8 r r r 255 else PixelRGBA8 0 0 0 0
where
fn x y =
let pixel@(PixelRGB8 r _ _) = pixelAt img x y
in if r < limit then promotePixel pixel else PixelRGBA8 0 0 0 1 --limit limit limit
renderColorMap :: Double -> Double -> (Double -> PixelRGB8) -> Tree renderColorMap :: Double -> Double -> (Double -> PixelRGB8) -> Tree
renderColorMap width height cmap = mkGroup renderColorMap width height cmap = mkGroup
@ -281,27 +351,33 @@ mkColorMap f = center $ embedImage img
drawPixelImage :: Double -> Double -> Animation drawPixelImage :: Double -> Double -> Animation
drawPixelImage start end = mkAnimation 2 $ \t -> drawPixelImage start end = mkAnimation 2 $ \t ->
let limit = fromToS start end $ curveS 2 t let limit = fromToS start end $ curveS 2 t
in scaleToSize screenWidth screenHeight $ center $ embedImage $ in scaleToSize screenWidth screenHeight $ center $ embedImage $
limitGreyPixels (floor (limit*255)) monalisaLarge cache !! floor (limit*255)
where
cache =
[ limitGreyPixels n monalisaLarge
| n <- [0..255] ]
drawHexPixels :: Animation drawHexPixels :: Animation
drawHexPixels = mkAnimation 1 $ \_ -> simplify $ simplify $ simplify $ drawHexPixels = mkAnimation 1 $ \_ -> svg
mkGroup
[ if highdef then defs else None
, withFillOpacity 1 $ withStrokeWidth 0 $ withFillColor "white" $
mkGroup
[ translate ((fromIntegral x+0.5)/fromIntegral width*screenWidth - screenWidth/2)
(screenHeight/2 - (fromIntegral y+0.5)/fromIntegral height*screenHeight) $
if highdef
then mkUse ("tag" ++ show r)
else mkCircle 0.5
| x <- [0..width-1]
, y <- [0..height-1]
, let pixel@(PixelRGB8 r _ _) = pixelAt monalisa x y
]
]
where where
svg = -- scaleToSize screenWidth screenHeight $ embedDynamicImage $ raster $
simplify $ simplify $ simplify $
mkGroup
[ if highdef then defs else None
, withFillOpacity 1 $ withStrokeWidth 0 $ withFillColor "white" $
mkGroup
[ translate ((fromIntegral x+0.5)/fromIntegral width*screenWidth - screenWidth/2)
(screenHeight/2 - (fromIntegral y+0.5)/fromIntegral height*screenHeight) $
if highdef
then mkUse ("tag" ++ show r)
else mkCircle 0.5
| x <- [0..width-1]
, y <- [0..height-1]
, let pixel@(PixelRGB8 r _ _) = pixelAt monalisa x y
]
]
defs = preRender $ mkDefinitions images defs = preRender $ mkDefinitions images
getNthSet n = centerX $ snd (splitGlyphs [n*2,n*2+1] allGlyphs) getNthSet n = centerX $ snd (splitGlyphs [n*2,n*2+1] allGlyphs)
allGlyphs = lowerTransformations $ scale 0.15 $ center $ latex $ allGlyphs = lowerTransformations $ scale 0.15 $ center $ latex $

60
videos/color-theory/gen_lab.hs Normal file
View file

@ -0,0 +1,60 @@
module Main where
import Control.Lens ((&), (.~))
import Codec.Picture
import Control.Monad
import Data.Colour
import Data.Colour.CIE
import Data.Colour.CIE.Illuminant
import Data.Colour.RGBSpace
import Data.Colour.RGBSpace.HSV (hsvView)
import Data.Colour.SRGB
import Data.Colour.SRGB.Linear
import Data.List
import Data.Maybe
import qualified Data.Map as Map
import Data.Ord
import Data.Text (Text)
import Graphics.SvgTree hiding (Text)
import Linear.V2
import Reanimate
import Reanimate.Animation
import Reanimate.Builtin.CirclePlot
import Reanimate.Builtin.Documentation
import qualified Reanimate.Builtin.TernaryPlot as Ternary
import Reanimate.ColorMap
import Reanimate.ColorSpace
import Reanimate.Constants
import Reanimate.Driver (reanimate)
import Reanimate.Effect
import Reanimate.Interpolate
import Reanimate.LaTeX
import Reanimate.Raster
import Reanimate.Scene
import Reanimate.Signal
import Reanimate.Svg
import Reanimate.Svg.BoundingBox
import Control.Parallel.Strategies
labScaleX = 110 -- 100 -- 128
labScaleY = 110 -- 100 -- 128
main :: IO ()
main = writePng "lab.png" (cieLABImage_' 1000)
cieLABImage_' dim = generateImage gen dim dim
where
gen x y =
let
aStar = (fromIntegral x / fromIntegral dim) * labScaleX*2 - labScaleX
bStar = (1-(fromIntegral y / fromIntegral dim)) * labScaleY*2 - labScaleY
-- lStar = 50 -- findLStar aStar bStar
colors = {-withStrategy (parList rpar)-} [ toSRGBBounded color
| lStar <- reverse [0, 0.1 .. 100]
, let color = cieLAB d65 lStar aStar bStar
, inGamut sRGBGamut color ]
in case listToMaybe colors of
Nothing -> PixelRGBA8 0xFF 0xFF 0xFF 0x00
Just (RGB r g b) -> PixelRGBA8 r g b 0xFF

85
videos/color-theory/posters.hs Executable file
View file

@ -0,0 +1,85 @@
#!/usr/bin/env stack
-- stack --resolver lts-13.14 runghc --package reanimate
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Main (main) where
import Control.Lens ()
import Control.Monad
import qualified Data.ByteString as BS
import qualified Data.Map as Map
import Data.Monoid
import qualified Data.Text as T
import Codec.Picture
import Codec.Picture.Jpg
import Codec.Picture.Types
import Data.Word
import Graphics.SvgTree hiding (Image, imageHeight, imageWidth)
import Graphics.SvgTree.Memo
import Numeric
import Reanimate.ColorMap
import Reanimate.Driver (reanimate)
import Reanimate.LaTeX
import Reanimate
import Reanimate.Animation
import Reanimate.Raster
import Reanimate.Scene
import Reanimate.Signal
import Reanimate.Effect
import Reanimate.Svg
import Reanimate.ColorSpace
import Reanimate.Constants
import System.IO.Unsafe
main :: IO ()
main = reanimate $
mkAnimation (1/60) (const monalisaPoster)
monalisaPoster :: SVG
monalisaPoster =
mkGroup
--[ mkPic (-1) 1 jet, mkPic 0 1 turbo, mkPic 1 1 parula
--, mkPic (-1) 0 viridis, mkPic 0 0 inferno, mkPic 1 0 sinebow
--, mkPic (-1) (-1) plasma, mkPic 0 (-1) cividis, mkPic 1 (-1) hsv ]
[ mkPic (-1) 1 viridis "viridis", mkPic 0 1 cividis "cividis", mkPic 1 1 parula "parula"
, mkPic (-1) 0 jet "jet", mkPic 0 0 inferno "inferno", mkPic 1 0 sinebow "sinebow"
, mkPic (-1) (-1) turbo "turbo", mkPic 0 (-1) plasma "plasma", mkPic 1 (-1) hsv "hsv" ]
where
mkPic x y cm txt =
translate (screenWidth/3 * x) (screenHeight/3 * y) $
mkGroup
[ scaleToSize (screenWidth/3) (screenHeight/3) $ embedImage $
applyColorMap cm monalisa
, translate (-screenWidth/6) (screenHeight/6) $
scale 0.5 $
withStrokeColor "black" $
withStrokeWidth (defaultStrokeWidth*0.5) $
withFillColor "white" $
latex ("\\texttt{" <> txt <> "}")
]
monalisa :: Image PixelRGB8
monalisa = unsafePerformIO $ do
dat <- BS.readFile "monalisa.jpg"
case decodeJpeg dat of
Left err -> error err
Right img -> return $ convertRGB8 img
monalisaLarge :: Image PixelRGB8
monalisaLarge = scaleImage 15 monalisa
scaleImage :: Pixel a => Int -> Image a -> Image a
scaleImage factor img =
generateImage fn (imageWidth img * factor) (imageHeight img * factor)
where
fn x y = pixelAt img (x `div` factor) (y `div` factor)
applyColorMap :: (Double -> PixelRGB8) -> Image PixelRGB8 -> Image PixelRGB8
applyColorMap cmap img =
generateImage fn (imageWidth img) (imageHeight img)
where
fn x y =
case pixelAt img x y of
PixelRGB8 r _ _ -> cmap (fromIntegral r/255)

38
videos/showcase/showcase.hs
View file

@ -2,6 +2,7 @@
-- stack runghc --package reanimate -- stack runghc --package reanimate
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ApplicativeDo #-}
module Main (main) where module Main (main) where
import Codec.Picture import Codec.Picture
@ -103,7 +104,7 @@ sphereIntro = sceneAnimation $ do
-- # applyE (delayE 1 $ overBeginning 2 fadeInE) -- # applyE (delayE 1 $ overBeginning 2 fadeInE)
-- # applyE (delayE 8 $ translateE (-3) 0) -- # applyE (delayE 8 $ translateE (-3) 0)
wait 5 wait 5
playZ 1 $ setDuration 3 $ animate $ \t -> adjustZ (+1) $ play $ setDuration 3 $ animate $ \t ->
partialSvg t $ partialSvg t $
withFillOpacity 0 $ withFillOpacity 0 $
rotate 180 $ rotate 180 $
@ -114,25 +115,25 @@ sphereIntro = sceneAnimation $ do
-- circ -- circ
let scaleFactor = 0.05 let scaleFactor = 0.05
tweenVar sphereX 1 $ \t x -> fromToS x (-3) (curveS 3 t) tweenVar sphereX 1 $ \t x -> fromToS x (-3) (curveS 3 t)
fork $ playZ 1 $ pauseAtEnd 2 $ setDuration 1 $ animate $ \t -> fork $ adjustZ (+1) $ play $ pauseAtEnd 2 $ setDuration 1 $ animate $ \t ->
let p = curveS 3 t in let p = curveS 3 t in
withFillOpacity p $ withFillOpacity p $
translate (1*p) (2*p) $ translate (1*p) (2*p) $
scale (1-scaleFactor*p) $ scale (1-scaleFactor*p) $
circ circ
fork $ playZ 1 $ pauseAtEnd 2 $ setDuration 1 $ animate $ \t -> fork $ adjustZ (+1) $ play $ pauseAtEnd 2 $ setDuration 1 $ animate $ \t ->
let p = curveS 3 t in let p = curveS 3 t in
withFillOpacity p $ withFillOpacity p $
translate (1*p) (-2*p) $ translate (1*p) (-2*p) $
scale (1-scaleFactor*p) $ scale (1-scaleFactor*p) $
circ circ
fork $ playZ 1 $ pauseAtEnd 2 $ setDuration 1 $ animate $ \t -> fork $ adjustZ (+1) $ play $ pauseAtEnd 2 $ setDuration 1 $ animate $ \t ->
let p = curveS 3 t in let p = curveS 3 t in
withFillOpacity p $ withFillOpacity p $
translate (5*p) (2*p) $ translate (5*p) (2*p) $
scale (1-scaleFactor*p) $ scale (1-scaleFactor*p) $
circ circ
fork $ playZ 1 $ pauseAtEnd 2 $ setDuration 1 $ animate $ \t -> fork $ adjustZ (+1) $ play $ pauseAtEnd 2 $ setDuration 1 $ animate $ \t ->
let p = curveS 3 t in let p = curveS 3 t in
withFillOpacity p $ withFillOpacity p $
translate (5*p) (-2*p) $ translate (5*p) (-2*p) $
@ -155,13 +156,15 @@ mkFeatSprite xPos yPos ani = do
spriteAt <- newVar 0 spriteAt <- newVar 0
spriteTMod <- newVar 0 spriteTMod <- newVar 0
sprite <- newSprite $ do sprite <- newSprite $ do
genAt <- freezeVar spriteAt genAt <- unVar spriteAt
genT <- freezeVar spriteTMod genT <- unVar spriteTMod
return $ \real_t d t -> t <- spriteT
let i = 1-genAt real_t in d <- spriteDuration
return $
let i = 1-genAt in
translate (xPos*i) (yPos*i) $ translate (xPos*i) (yPos*i) $
scale (1+0.5*genAt real_t) $ scale (1+0.5*genAt) $
frameAtT (((t+genT real_t)/d) `mod'` 1) ani frameAtT (((t+genT)/d) `mod'` 1) ani
return (spriteAt, spriteTMod, sprite) return (spriteAt, spriteTMod, sprite)
featSVG :: Animation featSVG :: Animation
@ -227,8 +230,8 @@ introSVG = sceneAnimation $ do
fork $ play $ animate $ const $ fork $ play $ animate $ const $
mkBackground "black" mkBackground "black"
-- Title -- Title
title <- newSprite $ do title <- newSprite $
return $ \_ _d _t -> pure $
translate 0 3.5 $ translate 0 3.5 $
center $ center $
withFillColor "white" $ withFillColor "white" $
@ -237,9 +240,9 @@ introSVG = sceneAnimation $ do
-- Shading -- Shading
shadeOpacity <- newVar 0 shadeOpacity <- newVar 0
shade <- newSprite $ do shade <- newSprite $ do
opacity <- freezeVar shadeOpacity opacity <- unVar shadeOpacity
return $ \real_t d t -> return $
withFillOpacity (0.8 * opacity real_t) $ withFillOpacity (0.8 * opacity) $
withFillColor "black" $ withFillColor "black" $
mkRect screenWidth screenHeight mkRect screenWidth screenHeight
spriteZ shade 1 spriteZ shade 1
@ -300,7 +303,8 @@ drawAnimation' fillDur step svg = sceneAnimation $ do
fork $ do fork $ do
wait (n*step+(1-fillDur)) wait (n*step+(1-fillDur))
newSprite $ do newSprite $ do
return $ \_real_t d t -> t <- spriteT
return $
withStrokeWidth 0 $ fn $ withFillOpacity (min 1 $ t/fillDur) tree withStrokeWidth 0 $ fn $ withFillOpacity (min 1 $ t/fillDur) tree
-- play $ animate (\t -> withStrokeWidth 0 $ fn $ withFillOpacity t tree) -- play $ animate (\t -> withStrokeWidth 0 $ fn $ withFillOpacity t tree)
-- # setDuration fillDur -- # setDuration fillDur