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

Rewamp the scene api, add circle plots, add blender flips, fix caching issue in driver, fix bug in partialSvg. Former-commit-id: 5cb900521044fee13766dd7474fd9b72c7691686
2026-09-10 15:42:21 +00:00 · 2020-02-02 09:17:29 +08:00 · 2020-02-02 09:17:29 +08:00 · 4bfafa4d8e
commit 4bfafa4d8e
parent 703836bc89
25 changed files with 1441 additions and 338 deletions
--- a/examples/doc_circlePlot.hs
+++ b/examples/doc_circlePlot.hs
@ -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
--- a/examples/tut_glue_blender.hs
+++ b/examples/tut_glue_blender.hs
@ -2,6 +2,7 @@
 -- stack runghc --package reanimate
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE QuasiQuotes       #-}
+{-# LANGUAGE ApplicativeDo     #-}
 module Main (main) where

 import           Reanimate
@ -23,12 +24,14 @@ main = seq texture $ reanimate $ pauseAtEnd 1 $ parA bg $ sceneAnimation $ do
    rotX <- newVar 0
    rotY <- newVar 0
    _ <- newSprite $ do
-      getBend <- freezeVar bend
-      getTrans <- freezeVar trans
-      getRotX <- freezeVar rotX
-      getRotY <- freezeVar rotY
-      return $ \real_t dur t -> seq (texture (t/dur)) $
-        blender (script (texture (t/dur)) (getBend real_t) (getTrans real_t) (getRotX real_t) (getRotY real_t))
+      getBend <- unVar bend
+      getTrans <- unVar trans
+      getRotX <- unVar rotX
+      getRotY <- unVar rotY
+      t <- spriteT
+      dur <- spriteDuration
+      return $ seq (texture (t/dur)) $
+        blender (script (texture (t/dur)) getBend getTrans getRotX getRotY)
    wait 2
    tweenVar trans 5 (\t v -> fromToS v (-2) $ 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
      wait (n*step+(1-fillDur))
      newSprite $ do
-        return $ \_real_t _d t ->
+        t <- spriteT
+        pure $
          withStrokeWidth 0 $ fn $ withFillOpacity (min 1 $ t/fillDur) tree
  where
    shuf lst =
--- a/examples/tut_glue_latex.hs
+++ b/examples/tut_glue_latex.hs
@ -1,6 +1,7 @@
 #!/usr/bin/env stack
 -- stack runghc --package reanimate
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ApplicativeDo #-}
 module Main (main) where

 import           Reanimate
@ -83,7 +84,8 @@ drawAnimation' mbSeed fillDur step svg = sceneAnimation $ do
    fork $ do
      wait (n*step+(1-fillDur))
      newSprite $ do
-        return $ \_real_t _d t ->
+        t <- spriteT
+        return $
          withStrokeWidth 0 $ fn $ withFillOpacity (min 1 $ t/fillDur) tree
  where
    shuf lst =
--- a/examples/tut_glue_potrace.hs
+++ b/examples/tut_glue_potrace.hs
@ -17,11 +17,7 @@ main = reanimate $ parA bg $ sceneAnimation $ do
    play $ mkAnimation drawDuration $ \t -> partialSvg t (wireframe (-45) 220)
    xRot <- newVar (-45)
    yRot <- newVar 220
-    wf <- newSprite $ do
-      getX <- freezeVar xRot
-      getY <- freezeVar yRot
-      return $ \real_t _dur _t ->
-        wireframe (getX real_t) (getY real_t)
+    wf <- newSprite $ wireframe <$> unVar xRot <*> unVar yRot
    tweenVar yRot spinDur (\t v -> fromToS v (v+60*3) $ curveS 2 (t/spinDur))
    replicateM_ wobbles $ do
      tweenVar xRot (wobbleDur/2) (\t v -> fromToS v (v+90) $ curveS 2 (t/(wobbleDur/2)))
--- a/examples/tut_glue_povray.hs
+++ b/examples/tut_glue_povray.hs
@ -2,6 +2,7 @@
 -- stack runghc --package reanimate
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE QuasiQuotes       #-}
+{-# LANGUAGE ApplicativeDo     #-}
 module Main (main) where

 import           Reanimate
@ -25,12 +26,14 @@ main = reanimate $ parA bg $ sceneAnimation $ do
    xRot <- newVar 0
    zRot <- newVar 0
    _ <- newSprite $ do
-      transZ <- freezeVar zPos
-      getX <- freezeVar xRot
-      getZ <- freezeVar zRot
-      return $ \real_t dur t ->
+      transZ <- unVar zPos
+      getX <- unVar xRot
+      getZ <- unVar zRot
+      t <- spriteT
+      dur <- spriteDuration
+      pure $
        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
    tweenVar zPos 9 (\t v -> fromToS v 8 (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
      wait (n*step+(1-fillDur))
      newSprite $ do
-        return $ \_real_t _d t ->
+        t <- spriteT
+        return $
          withStrokeWidth 0 $ fn $ withFillOpacity (min 1 $ t/fillDur) tree
  where
    shuf lst =
--- a/examples/tut_glue_povray_ortho.hs
+++ b/examples/tut_glue_povray_ortho.hs
@ -2,6 +2,7 @@
 -- stack runghc --package reanimate
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE QuasiQuotes       #-}
+{-# LANGUAGE ApplicativeDo     #-}
 module Main (main) where

 import           Reanimate
@ -25,12 +26,14 @@ main = reanimate $ parA bg $ sceneAnimation $ do
    yRot <- newVar 180
    zRot <- newVar 0
    _ <- newSprite $ do
-      getX <- freezeVar xRot
-      getY <- freezeVar yRot
-      getZ <- freezeVar zRot
-      return $ \real_t dur t ->
+      getX <- unVar xRot
+      getY <- unVar yRot
+      getZ <- unVar zRot
+      t <- spriteT
+      dur <- spriteDuration
+      return $
        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
    let tDuration = 10
    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
      wait (n*step+(1-fillDur))
      newSprite $ do
-        return $ \_real_t _d t ->
+        t <- spriteT
+        return $
          withStrokeWidth 0 $ fn $ withFillOpacity (min 1 $ t/fillDur) tree
  where
    shuf lst =
--- a/reanimate.cabal
+++ b/reanimate.cabal
@ -63,6 +63,8 @@ library
                      Reanimate.Blender
                      Reanimate.Effect
                      Reanimate.Builtin.TernaryPlot
+                      Reanimate.Builtin.CirclePlot
+                      Reanimate.Builtin.Flip
                      Reanimate.Constants
                      Reanimate.Parameters
                      Reanimate.Chiphunk
--- a/src/Reanimate.hs
+++ b/src/Reanimate.hs
@ -67,7 +67,6 @@ module Reanimate
    sceneAnimation,
    fork,
    play,
-    playZ,
    queryNow,
    waitAll,
    waitUntil,
@ -76,11 +75,14 @@ module Reanimate
    withSceneDuration,
    newSprite,
    newSpriteA,
+    newSpriteSVG,
    destroySprite,
    spriteE,
    newVar,
    tweenVar,
-    freezeVar,
+    unVar,
+    spriteT,
+    spriteDuration,

    -- ** Effects
    Effect,
--- a/src/Reanimate/Blender.hs
+++ b/src/Reanimate/Blender.hs
@ -47,4 +47,3 @@ mkBlenderImage' script = cacheFile template $ \target -> do
                , "--render-output", target, "--python", py_file]
  where
    template = show (hash script) <.> "png"
-
--- a/src/Reanimate/Builtin/CirclePlot.hs
+++ b/src/Reanimate/Builtin/CirclePlot.hs
@ -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)
--- a/src/Reanimate/Builtin/Flip.hs
+++ b/src/Reanimate/Builtin/Flip.hs
@ -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 )
+|]
--- a/src/Reanimate/ColorSpace.hs
+++ b/src/Reanimate/ColorSpace.hs
@ -33,6 +33,11 @@ bigXYZCoordinates = unsafePerformIO $ do
    Right vec -> return $ Map.fromList
      [ (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 =
  withFillOpacity 0 $
--- a/src/Reanimate/Driver.hs
+++ b/src/Reanimate/Driver.hs
@ -21,6 +21,7 @@ presetFormat ExampleGif = RenderGif
 presetFormat Quick      = RenderMp4
 presetFormat MediumQ    = RenderMp4
 presetFormat HighQ      = RenderMp4
+presetFormat LowFPS     = RenderMp4

 presetFPS :: Preset -> FPS
 presetFPS Youtube    = 60
@ -28,6 +29,7 @@ presetFPS ExampleGif = 24
 presetFPS Quick      = 15
 presetFPS MediumQ    = 30
 presetFPS HighQ      = 30
+presetFPS LowFPS     = 10

 presetWidth :: Preset -> Width
 presetWidth Youtube    = 2560
@ -35,6 +37,7 @@ presetWidth ExampleGif = 320
 presetWidth Quick      = 320
 presetWidth MediumQ    = 800
 presetWidth HighQ      = 1920
+presetWidth LowFPS     = presetWidth HighQ

 presetHeight :: Preset -> Height
 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
 userPreferredDimensions :: Maybe Width -> Maybe Height -> Maybe (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      Nothing        = Nothing

--- a/src/Reanimate/Driver/CLI.hs
+++ b/src/Reanimate/Driver/CLI.hs
@ -34,7 +34,7 @@ data Command
    }
   deriving (Show)

-data Preset = Youtube | ExampleGif | Quick | MediumQ | HighQ
+data Preset = Youtube | ExampleGif | Quick | MediumQ | HighQ | LowFPS
  deriving (Show)

 readFormat :: String -> Maybe Format
@ -58,6 +58,7 @@ readPreset preset =
    "quick"   -> Just Quick
    "medium"  -> Just MediumQ
    "high"    -> Just HighQ
+    "lowfps"  -> Just LowFPS
    _         -> Nothing

 showPreset :: Preset -> String
@ -66,6 +67,7 @@ showPreset ExampleGif = "gif"
 showPreset Quick      = "quick"
 showPreset MediumQ    = "medium"
 showPreset HighQ      = "high"
+showPreset LowFPS     = "lowfps"

 options :: Parser Options
 options = Options <$> commandP
--- a/src/Reanimate/Driver/Server.hs
+++ b/src/Reanimate/Driver/Server.hs
@ -4,12 +4,11 @@ module Reanimate.Driver.Server
  , findOwnSource
  ) where

+import           Control.Concurrent
 import           Control.Concurrent      (forkIO, killThread, threadDelay)
-import           Control.Concurrent.MVar
 import           Control.Exception       (SomeException, catch, finally)
 import           Control.Monad
 import           Control.Monad.Fix       (fix)
-import           Data.Hashable           (hash)
 import           Data.Text               (Text)
 import qualified Data.Text               as T
 import qualified Data.Text.IO            as T
@ -94,31 +93,47 @@ slaveHandler conn self svgDir =
  withCurrentDirectory (takeDirectory self) $
  withSystemTempDirectory "reanimate" $ \tmpDir ->
  withTempFile tmpDir "reanimate.exe" $ \tmpExecutable handle -> do
+    -- cap <- getNumCapabilities
+    let n = 25
+    sem <- newQSemN n
    hClose handle
+    lock <- newMVar ()
    sendTextData conn (T.pack "status\nCompiling")
    ret <- runCmd_ "stack" $ ["ghc", "--"] ++ ghcOptions tmpDir ++ [takeFileName self, "-o", tmpExecutable]
    case ret of
      Left err ->
        sendTextData conn $ T.pack $ "error\n" ++ unlines (drop 3 (lines err))
      Right{} -> runCmdLazy tmpExecutable execOpts $ \getFrame -> do
-        (frameCount,_) <- expectFrame =<< getFrame
+        (frameCount,_) <- expectFrame sem =<< getFrame
        sendTextData conn (T.pack $ "frame_count\n" ++ show frameCount)
        fix $ \loop -> do
-          (frameIdx, frame) <- expectFrame =<< getFrame
-          let fileName = svgDir </> show (hash frame) <.> "svg"
-          T.writeFile fileName frame
-          sendTextData conn (T.pack $ "frame\n" ++ show frameIdx ++ "\n" ++ fileName)
+          (frameIdx, frame) <- expectFrame sem =<< getFrame
+          -- putStrLn $ "Got frame: " ++ show frameIdx
+          let fileName = svgDir </> takeBaseName tmpExecutable <.> show frameIdx <.> "svg"
+              -- 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
  where
-    execOpts = ["raw", "+RTS", "-N", "-M1G", "-RTS"]
-    expectFrame :: Either String Text -> IO (Integer, Text)
-    expectFrame (Left "") = do
+    execOpts = ["raw", "+RTS", "-N", "-M2G", "-RTS"]
+    expectFrame :: QSemN -> Either String Text -> IO (Integer, Text)
+    expectFrame sem (Left "") = do
+      waitQSemN sem 25 -- =<< getNumCapabilities
      sendTextData conn (T.pack "status\nDone")
      exitSuccess
-    expectFrame (Left err) = do
+    expectFrame _ (Left err) = do
      sendTextData conn $ T.pack $ "Error" ++ err
      exitWith (ExitFailure 1)
-    expectFrame (Right frame) =
+    expectFrame _ (Right frame) =
      case T.decimal frame of
        Left err -> do
          hPutStrLn stderr (T.unpack frame)
--- a/src/Reanimate/Scene.hs
+++ b/src/Reanimate/Scene.hs
@ -1,4 +1,5 @@
 {-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ApplicativeDo #-}
 module Reanimate.Scene where

 import           Control.Monad.Fix
@ -6,7 +7,6 @@ import           Control.Monad.ST
 import           Data.List
 import           Data.STRef
 import           Reanimate.Animation
-import           Reanimate.Signal
 import           Reanimate.Effect
 import           Reanimate.Svg.Constructors
 import           Graphics.SvgTree (Tree(None))
@ -19,53 +19,41 @@ o # f = f o
 -- (seq duration, par duration)
 -- [(Time, Animation, ZIndex)]
 -- Map Time [(Animation, ZIndex)]
-type Timeline = [(Time, Animation, 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]) }
-
-unionTimeline :: Timeline -> Timeline -> Timeline
-unionTimeline = (++)
-
-emptyTimeline :: Timeline
-emptyTimeline = []
+newtype Scene s a = M { unM :: Time -> ST s (a, Duration, Duration, [Gen s]) }

 instance Functor (Scene s) where
  fmap f action = M $ \t -> do
-    (a, d1, d2, tl, gens) <- unM action t
-    return (f a, d1, d2, tl, gens)
+    (a, d1, d2, gens) <- unM action t
+    return (f a, d1, d2, gens)

 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', s1, p1, tl1, gen1) <- unM f t
-    (g', s2, p2, tl2, gen2) <- unM g (t+s1)
-    return (f' g', s1+s2, max p1 (s1+p2), unionTimeline tl1 tl2, gen1++gen2)
+    (f', s1, p1, gen1) <- unM f t
+    (g', s2, p2, gen2) <- unM g (t+s1)
+    return (f' g', s1+s2, max p1 (s1+p2), gen1++gen2)

 instance Monad (Scene s) where
  return = pure
  f >>= g = M $ \t -> do
-    (a, s1, p1, tl1, gen1) <- unM f t
-    (b, s2, p2, tl2, gen2) <- unM (g a) (t+s1)
-    return (b, s1+s2, max p1 (s1+p2), unionTimeline tl1 tl2, gen1++gen2)
+    (a, s1, p1, gen1) <- unM f t
+    (b, s2, p2, gen2) <- unM (g a) (t+s1)
+    return (b, s1+s2, max p1 (s1+p2), gen1++gen2)

 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 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 action =
  runST (do
-    (_, s, p, tl, gens) <- unM action 0
+    (_, s, p, gens) <- unM action 0
    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
-    return $ anis `parDropA` mkAnimation dur (\t ->
+    return $ mkAnimation dur (\t ->
      mkGroup $
      map fst $
      sortOn snd
@ -75,25 +63,20 @@ sceneAnimation action =

 fork :: Scene s a -> Scene s a
 fork (M action) = M $ \t -> do
-  (a, s, p, tl, gens) <- action t
-  return (a, 0, max s p, tl, gens)
+  (a, s, p, gens) <- action t
+  return (a, 0, max s p, gens)

 play :: Animation -> Scene s ()
-play = playZ 0
-
-playZ :: ZIndex -> Animation -> Scene s ()
-playZ z ani = M $ \t -> do
-  let d = duration ani
-  return ((), d, 0, [(t, ani, z)], [])
+play ani = newSpriteA ani >>= destroySprite

 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.
 waitAll :: Scene s a -> Scene s a
 waitAll (M action) = M $ \t -> do
-  (a, s, p, tl, gens) <- action t
-  return (a, max s p, 0, tl, gens)
+  (a, s, p, gens) <- action t
+  return (a, max s p, 0, gens)

 waitUntil :: Time -> Scene s ()
 waitUntil tNew = do
@ -102,12 +85,18 @@ waitUntil tNew = do

 wait :: Duration -> Scene s ()
 wait d = M $ \_ ->
-  return ((), d, 0, emptyTimeline, [])
+  return ((), d, 0, [])

 adjustZ :: (ZIndex -> ZIndex) -> Scene s a -> Scene s a
 adjustZ fn (M action) = M $ \t -> do
-  (a, s, p, tl, gens) <- action t
-  return (a, s, p, [ (startT, ani, fn z) | (startT, ani, z) <- tl ], gens)
+    (a, s, p, gens) <- action t
+    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 s = do
@ -116,52 +105,13 @@ withSceneDuration s = do
  t2 <- queryNow
  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 = M $ \_ -> return ((), 0, 0, emptyTimeline, [gen])
+fromParams gen = M $ \_ -> return ((), 0, 0, [gen])

 simpleParam :: (a -> SVG) -> a -> Scene s (Var s a)
 simpleParam render def = do
  v <- newVar def
-  _ <- newSprite $ do
-       getV <- freezeVar v
-       return $ \real_t _d _t -> render (getV real_t)
+  _ <- newSprite $ render <$> unVar v
  return v

 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)
  wait dur

-freezeVar :: Var s a -> ST s (Time -> a)
-freezeVar (Var ref) = readSTRef ref
+unVar :: Var s a -> Frame s a
+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 _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 sprite fn = do
  spriteModify sprite $ do
-    varFn <- freezeVar var
-    return $ \absT _relD _relT (svg, zindex) ->
-      (fn (varFn absT) svg, zindex)
+    varFn <- unVar var
+    return $ \(svg, zindex) ->
+      (fn varFn 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
  now <- queryNow
  ref <- liftST $ newSTRef (-1, return $ \_d _t svg -> (svg, 0))
  fromParams $ do
-    fn <- render
-    (spriteDuration, spriteEffectGen) <- readSTRef ref
+    fn <- unFrame render
+    (spriteDur, spriteEffectGen) <- readSTRef ref
    spriteEffect <- spriteEffectGen
    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
      if relT < 0 || relD < relT
        then (None, 0)
@ -228,20 +202,12 @@ newSpriteA :: Animation -> Scene s (Sprite s)
 newSpriteA = newSpriteA' SyncStretch

 newSpriteA' :: Sync -> Animation -> Scene s (Sprite s)
-newSpriteA' sync animation = do
-  now <- queryNow
-  ref <- liftST $ newSTRef (-1, return $ \_d _t svg -> (svg, 0))
-  fromParams $ do
-    (spriteDuration, spriteEffectGen) <- readSTRef ref
-    spriteEffect <- spriteEffectGen
-    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
+newSpriteA' sync animation =
+  newSprite (getAnimationFrame sync animation <$> spriteT <*> spriteDuration)
+    <* wait (duration animation)
+
+newSpriteSVG :: SVG -> Scene s (Sprite s)
+newSpriteSVG = newSprite . pure

 getAnimationFrame :: Sync -> Animation -> Time -> Duration -> SVG
 getAnimationFrame sync (Animation aDur aGen) t d =
@ -265,24 +231,28 @@ destroySprite (Sprite _ ref) = do
  liftST $ modifySTRef ref $ \(ttl, 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 =
  liftST $ modifySTRef ref $ \(ttl, renderGen) ->
    (ttl, do
      render <- renderGen
-      modRender <- modFn
+      modRender <- unFrame modFn
      return $ \relD relT ->
        let absT = relT + born
        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@(Sprite born _) dur fn = do
-  now <- queryNow
-  let tDelta = now - born
-  spriteModify sprite $ do
-    return $ \_real_t _d t (svg, zindex) ->
-      (fn (clamp 0 1 $ (t-tDelta)/dur) svg, zindex)
-  wait dur
+    now <- queryNow
+    let tDelta = now - born
+    spriteModify sprite $ do
+      t <- spriteT
+      return $ \(svg, zindex) ->
+        (fn (clamp 0 1 $ (t-tDelta)/dur) svg, zindex)
+    wait dur
  where
    clamp a b v
      | v < a     = a
@ -293,9 +263,9 @@ spriteVar :: Sprite s -> a -> (a -> SVG -> SVG) -> Scene s (Var s a)
 spriteVar sprite def fn = do
  v <- newVar def
  spriteModify sprite $ do
-    getV <- freezeVar v
-    return $ \real_t _d _t (svg, zindex) ->
-      (fn (getV real_t) svg, zindex)
+    getV <- unVar v
+    return $ \(svg, zindex) ->
+      (fn getV svg, zindex)
  return v

 spriteE :: Sprite s -> Effect -> Scene s ()
@ -306,7 +276,7 @@ spriteE (Sprite born ref) effect = do
      render <- renderGen
      return $ \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 born ref) zindex = do
--- a/src/Reanimate/Svg/LineCommand.hs
+++ b/src/Reanimate/Svg/LineCommand.hs
@ -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
           -> Tree -- ^ Image representing a path, of which we only want to display a portion determined by the first argument
           -> Tree
-- partialSvg alpha | alpha >= 1 = id
+partialSvg alpha | alpha >= 1 = id
 partialSvg alpha = mapTree worker
  where
    worker (PathTree path) =
--- a/videos/color-theory/EndScene.hs
+++ b/videos/color-theory/EndScene.hs
@ -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
--- a/videos/color-theory/Grid.hs
+++ b/videos/color-theory/Grid.hs
@ -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)
--- a/videos/color-theory/SCRIPT.md
+++ b/videos/color-theory/SCRIPT.md
@ -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.
--- a/videos/color-theory/Spectrum.hs
+++ b/videos/color-theory/Spectrum.hs
@ -1,32 +1,33 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecursiveDo       #-}
+{-# LANGUAGE ApplicativeDo     #-}
 module Spectrum
-  ( colorSpacesScene
-  , xyzTernaryPlot
-  , interpolation
-  , spacesA
-  , scene2
-  , scene3
+  ( scene2
  ) where

 import           Control.Lens                    ((&), (.~))

 import           Codec.Picture
+import           Codec.Picture.Types
 import           Control.Monad
+import qualified Data.ByteString                 as BS
 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 qualified Data.Map                        as Map
+import           Data.Maybe
 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
@ -41,6 +42,7 @@ import           Reanimate.Scene
 import           Reanimate.Signal
 import           Reanimate.Svg
 import           Reanimate.Svg.BoundingBox
+import           System.IO.Unsafe

 {- STORYBOARD
 - 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 ]
 zCoords = [ (nm, z/2) | (nm, (x, y, z)) <- Map.toList bigXYZCoordinates ]

-labScaleX = 128
-labScaleY = 128
+labScaleX = 110 -- 100 -- 128
+labScaleY = 110 -- 100 -- 128

 blueName = "royalblue"
 greenName = "green"
@ -67,7 +69,7 @@ redName = "maroon"

 drawSensitivities :: Animation
 drawSensitivities = sceneAnimation $ do
-    bg <- newSpriteA $ staticFrame 0 spectrumGrid
+    bg <- newSpriteSVG $ spectrumGrid True
    spriteZ bg 1

    forM_ [(short, blueName), (medium, greenName), (long, redName)] $
@ -81,7 +83,7 @@ drawSensitivities = sceneAnimation $ do

 drawMorphingSensitivities :: Animation
 drawMorphingSensitivities = sceneAnimation $ do
-    bg <- newSpriteA $ staticFrame 0 spectrumGrid
+    bg <- newSpriteSVG $ spectrumGrid True
    spriteZ bg 1

    forM_ keys $ \(datA, datB, name) -> do
@ -92,7 +94,7 @@ drawMorphingSensitivities = sceneAnimation $ do
           , (medium, yCoords, greenName)
           , (long, xCoords, redName)]
    drawDur = 3
-
+{-
 colorSpacesScene :: Animation
 colorSpacesScene = sceneAnimation $ mdo
    beginT <- queryNow
@ -167,7 +169,7 @@ colorSpacesScene = sceneAnimation $ mdo
    drawDur = 3
    drawStagger = 1
    drawPause = 4
-
+-}
 drawLabelS = drawLabel "S" blueName
 drawLabelM = drawLabel "M" greenName
 drawLabelL = drawLabel "L" redName
@ -176,25 +178,63 @@ drawLabelZ = drawLabel "Z" blueName
 drawLabelY = drawLabel "Y" greenName
 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 = {- 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.
-  labelS <- fork $ newSpriteA $ drawLabelS
-    # applyE (overBeginning 0.3 fadeInE)
-    # applyE (overEnding 0.2 fadeOutE)
-    # mapA (uncurry translate (labelPosition short))
+  labelS <- newSpriteSVG $ drawLabelSVG "S" blueName
+  spriteMap labelS $ uncurry translate (labelPosition short)
+
  labelM <- fork $ do
-    wait 2
+    wait 2.1
    newSpriteA $ drawLabelM
-      # applyE (overBeginning 0.3 fadeInE)
-      # applyE (overEnding 0.2 fadeOutE)
-      # mapA (uncurry translate (labelPosition medium))
+  spriteMap labelM $ uncurry translate (labelPosition medium)
+
  labelL <- fork $ do
    wait 3.5
    newSpriteA $ drawLabelL
-      # applyE (overBeginning 0.3 fadeInE)
-      # applyE (overEnding 0.2 fadeOutE)
-      # mapA (uncurry translate (labelPosition long))
+  spriteMap labelL $ uncurry translate (labelPosition long)
+
+  forM_ [labelS, labelM, labelL] $ \label -> do
+    spriteE label $ overBeginning 0.3 fadeInE
+    spriteE label $ overEnding 0.3 fadeOutE

  play $ drawSensitivities
    # pauseAtEnd 1
@ -207,15 +247,15 @@ scene2 = {- dropA 29 $-} sceneAnimation $ do
  -- XYZ labels and timings
  wait (duration drawMorphingSensitivities)
  labelZ <- fork $ newSpriteA $ drawLabelZ
-    # applyE (overBeginning 0.3 fadeInE)
+  spriteE labelZ $ overBeginning 0.3 fadeInE
  labelZPos <- spriteVar labelZ (labelPosition zCoords) $ uncurry translate

  labelY <- fork $ newSpriteA $ drawLabelY
-    # applyE (overBeginning 0.3 fadeInE)
+  spriteE labelY $ overBeginning 0.3 fadeInE
  labelYPos <- spriteVar labelY (labelPosition yCoords) $ uncurry translate

  labelX <- fork $ newSpriteA $ drawLabelX
-    # applyE (overBeginning 0.3 fadeInE)
+  spriteE labelX $ overBeginning 0.3 fadeInE
  labelXPos <- spriteVar labelX (labelPosition xCoords) $ uncurry translate

  wait 4
@ -243,15 +283,17 @@ scene2 = {- dropA 29 $-} sceneAnimation $ do
  redFactor <- newVar 0
  greenFactor <- newVar 0
  blueFactor <- newVar 0
-  xyzSpace <- newSprite $ do
-    getRed <- freezeVar redFactor
-    getGreen <- freezeVar greenFactor
-    getBlue <- freezeVar blueFactor
-    return $ \real_t d t ->
-      cieXYImage (getRed real_t) (getGreen real_t) (getBlue real_t) imgSize
-  -- xyzSpace <- newSparite $ cieXYImage <$> unVar redFactor <*> unVar greenFactor <*> unVar blueFactor
-  spriteE xyzSpace $ constE $ translate (-screenWidth/4) 0
+  xyzSpace <- newSprite $
+    cieXYImage
+      <$> unVar redFactor
+      <*> unVar greenFactor
+      <*> unVar blueFactor
+      <*> pure imgSize
+  spriteMap xyzSpace $ translate (-screenWidth/4) 0
  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

  wait 3
-  visLine <- fork $ newSpriteA' SyncFreeze $ mkAnimation 3 $ \t ->
-    withStrokeWidth 0.03 $ withStrokeColor "white" $ morphXYZCoordinates t
+  let downShift = 1
+  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)
+
+  spriteTween waveLine 0.5 $ \t -> withGroupOpacity (1-t)
+  destroySprite waveLine
+
  visSide <- spriteVar visLine 0 $ \t ->
+    translate 0 (-downShift) .
    translate (fromToS (screenWidth/4) (-screenWidth/4) $ curveS 2 t) 0 .
    scale (fromToS 0.5 1 $ 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
  gamut <- newVar 0
+  reorient <- newVar 0
+  cmOpacity <- newVar 1
+  cmDelta <- newVar 0
+  cmName <- newVar "sinebow"
+  cmFunc <- newVar sinebow
  visSpace <- fork $ newSprite $ do
-    getObs <- freezeVar obsVisible
-    getGamut <- freezeVar gamut
-    return $ \real_t d t ->
+    getObs <- unVar obsVisible
+    getGamut <- unVar gamut
+    getReorient <- unVar reorient
+    getOpacity <- unVar cmOpacity
+    getDelta <- unVar cmDelta
+    getFunc <- unVar cmFunc
+    return $
      translate (-screenWidth/4) 0 $
      mkGroup
      [ mkClipPath "visible"
@ -288,16 +358,43 @@ scene2 = {- dropA 29 $-} sceneAnimation $ do
        ]
      , mkClipPath "sRGB"
        [ simplify $
-          sRGBTriangle (getGamut real_t)
+          sRGBTriangle getGamut
        ]
-      , withGroupOpacity (getObs real_t) $
+      , withGroupOpacity getObs $
        withClipPathRef (Ref "visible") $
        mkGroup [cieXYImage 1 1 1 imgSize]
-      , withClipPathRef (Ref "sRGB") $
-        mkGroup [cieXYImageGamut (getGamut real_t) imgSize]
+      , translate 0 (1*getReorient) $
+        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
  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 labelX 1 $ \t -> withGroupOpacity (1-t)
-  fork $ spriteTween labelY 1 $ \t -> withGroupOpacity (1-t)
-  fork $ spriteTween labelZ 1 $ \t -> withGroupOpacity (1-t)
+  fork $ tweenVar labelXPos 1 $ \(x,y) t ->
+    let (newX, newY) = (-1,3)
+        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 ->
    translate (fromToS 0 (screenWidth/4) $ curveS 2 t) 0

  wait 2

-  rgb <- newSprite $ do
-    getGamut <- freezeVar gamut
-    return $ \real_t d t ->
-      withStrokeColor "white" $ sRGBTriangle (getGamut real_t)
+  rgb <- newSprite $ withStrokeColor "white" . sRGBTriangle <$> unVar gamut
  spriteTween rgb 1 $ partialSvg
  wait 1
-  tweenVar obsVisible 1 $ \v -> fromToS v 0 . curveS 2
-  wait 1
  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

+  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 ()
  where
    imgSize = 50
@ -337,6 +572,18 @@ scene2 = {- dropA 29 $-} sceneAnimation $ do
      scale 5 $
      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 = sceneAnimation $ do
    play $ mkAnimation 1 $ \t -> cieXYImage 0 0 t imgSize
@ -355,7 +602,9 @@ scene3 = sceneAnimation $ do
      lowerTransformations $
      scale (100/2) $
      renderLABCoordinates
+-}

+{-
 frame = mkAnimation 2 $ \t ->
    -- emit $ mkBackground "black"
    -- emit $ spectrumGrid
@ -399,7 +648,7 @@ frame = mkAnimation 2 $ \t ->
    imgSize :: Num a => a
    imgSize = 1000
    img1 = cieXYImage 1 1 1 imgSize
-    img2 = cieLABImage imgSize imgSize
+    img2 = cieLABImage imgSize 50
    obsColors =
      lowerTransformations $
      scale 5 $
@ -408,7 +657,9 @@ frame = mkAnimation 2 $ \t ->
      lowerTransformations $
      scale (100/2) $
      renderLABCoordinates
+-}

+{-
 xyzTernaryPlot = mkAnimation 2 $ \t ->
    -- emit $ mkBackground "black"
    -- emit $ spectrumGrid
@ -451,7 +702,7 @@ xyzTernaryPlot = mkAnimation 2 $ \t ->
    imgSize :: Num a => a
    imgSize = 50
    img1 t = cieXYImage t t t imgSize
-    img2 = cieLABImage imgSize imgSize
+    img2 = cieLABImage imgSize 50
    obsColors =
      lowerTransformations $
      scale 5 $
@ -460,7 +711,7 @@ xyzTernaryPlot = mkAnimation 2 $ \t ->
      lowerTransformations $
      scale (100/2) $
      renderLABCoordinates
-
+-}

 renderXYZCoordinatesTernary :: Tree
 renderXYZCoordinatesTernary =
@ -496,7 +747,7 @@ cieXYImageGamut t density = Ternary.ternaryPlot density $ \aCoord bCoord cCoord
      aCoord' = fromToS aCoord (rX * aCoord + gX * bCoord + bX * cCoord) t
      bCoord' = fromToS bCoord (rY * aCoord + gY * bCoord + bY * 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
  where
    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
    (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
 -- bCoord = green
 -- cCoord = blue
@ -524,17 +849,54 @@ cieXYImage redFactor greenFactor blueFactor density =
      -- RGB r g b = toSRGBBounded (chromaColour d65 1)
    in PixelRGBA8 r g b 0xFF

-cieLABImage :: Int -> Int -> Tree
-cieLABImage width height = embedImage $ generateImage gen width height
+cieLABImagePixels :: SVG
+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
    gen x y =
      let
-          aStar = (fromIntegral x / fromIntegral width) * labScaleX*2 - labScaleX
-          bStar = (1-(fromIntegral y / fromIntegral height)) * labScaleY*2 - labScaleY
-          lStar = findLStar aStar bStar
+          aStar = (fromIntegral x / fromIntegral dim) * labScaleX*2 - labScaleX
+          bStar = (1-(fromIntegral y / fromIntegral dim)) * labScaleY*2 - labScaleY
+          -- 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 = 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 aStar bStar = worker 0 100 10
@ -589,6 +951,7 @@ mkClosedLinePath :: [(Double, Double)] -> Tree
 mkClosedLinePath [] = mkGroup []
 mkClosedLinePath ((startX, startY):rest) =
    PathTree $ defaultSvg & pathDefinition .~ cmds
+      & strokeLineJoin .~ pure JoinRound
  where
    cmds = [ MoveTo OriginAbsolute [V2 startX startY]
           , LineTo OriginAbsolute [ V2 x y | (x, y) <- rest ]
@ -597,8 +960,32 @@ mkClosedLinePath ((startX, startY):rest) =
 spectrumHeight = screenHeight * 0.5
 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 $
  mkGroup
  [ --center $
@ -620,20 +1007,22 @@ spectrumGrid =
      , HorizontalTo OriginRelative [tickLength]]
    | n <- [0..nTicksY-1]
    ]
-  , withFillColor "white" $
-    translate (-spectrumWidth*0.5 + svgWidth sensitivity*1.2) 0 $
-    sensitivity
+  , if includeSensitivity
+    then withFillColor "white" $
+         translate (-spectrumWidth*0.5 + svgWidth sensitivity*1.2) 0 $
+         sensitivity
+    else None
  , withFillColor "white" $
    translate 0 (-spectrumHeight*0.5 + svgHeight wavelength*1.2) $
    wavelength
-  -- , withFillColor "white" $
-  --   translate (-spectrumWidth*0.5 + svgWidth shortWaves/2)
-  --             (-spectrumHeight*0.5 + svgHeight shortWaves) $
-  --   shortWaves
-  -- , withFillColor "white" $
-  --   translate (spectrumWidth*0.5 - svgWidth shortWaves/2)
-  --             (-spectrumHeight*0.5 + svgHeight shortWaves) $
-  --   longWaves
+  , withFillColor "white" $
+    translate (-spectrumWidth*0.5 - svgWidth shortWaves)
+              (-spectrumHeight*0.5 + svgHeight shortWaves*1.2) $
+    shortWaves
+  , withFillColor "white" $
+    translate (spectrumWidth*0.5 - svgWidth longWaves)
+              (-spectrumHeight*0.5 + svgHeight longWaves*1.2) $
+    longWaves
  ]
  where
    strokeWidth = 0.03
@ -649,12 +1038,12 @@ spectrumGrid =
      scale 0.8 $
      latex "Wavelength"
    shortWaves =
-      center $
-      scale 0.6 $
+      rotate (-45) $ center $
+      scale 0.3 $
      latex "400 nm"
    longWaves =
-      center $
-      scale 0.6 $
+      rotate (-45) $ center $
+      scale 0.3 $
      latex "700 nm"


@ -679,6 +1068,15 @@ morphSensitivity datA datB c = animate $ \t ->
  --  mkBackground "green"
 sensitivitySVG :: Double -> Double -> [(Nanometer, Double)] -> String -> Tree
 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") $
    simplify $ lowerTransformations $
    withStrokeColor c $
@ -692,7 +1090,7 @@ sensitivitySVG maxHeight limit dat c =
            x = percent * spectrumWidth
            y = n/maxHeight * spectrumHeight
      , percent <= limit
-      ]
+      ] ]
  where
    initNM = fromIntegral $ fst (head dat)
    lastNM = 700 -- fromIntegral $ fst (last dat)
@ -719,6 +1117,17 @@ drawLabel label c = animate $ const $
      scale 1 $
      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 = translate 0 (-svgHeight svg * 1.5) svg

@ -750,41 +1159,44 @@ interpolation = mkAnimation 2 $ \t ->
    cyan = PixelRGB8 0x00 0xFF 0xFF
    red =  PixelRGB8 0xFF 0x00 0x00

-lchColorSpace :: Int -> Int -> Tree
-lchColorSpace width height = embedImage $ generateImage gen width height
-  where
-    toRad deg = deg/180 * pi
-    gen x y =
-      let
-          h = fromToS 0 360 (fromIntegral x / fromIntegral width)
-          aStar = (cos (toRad h) * c)
-          bStar = (sin (toRad h) * c)
-          l = findLStar aStar bStar
-          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 (cieLAB d65 l aStar bStar)
-      in PixelRGB8 r g b
+lchColorSpace :: Int -> Tree
+lchColorSpace width =
+  circlePlot width $ \ang radius ->
+    let
+        toRad deg = deg/180 * pi
+        h = ang/pi*180
+        aStar = (cos (toRad h) * c)
+        bStar = (sin (toRad h) * c)
+        l = 50 -- findLStar aStar bStar
+        c = fromToS 0 (sqrt (labScaleX^2 + labScaleY^2)) radius
+        -- RGB r g b = toSRGBBounded (colorPack lchComponents l c h)
+        color = cieLAB d65 l aStar bStar
+        RGB r g b = toSRGBBounded color
+    in if inGamut sRGBGamut color
+      then PixelRGBA8 r g b 0xFF
+      else PixelRGBA8 0 0 0 0x00

-hsvColorSpace :: Int -> Int -> Tree
-hsvColorSpace width height = embedImage $ generateImage gen width height
-  where
-    toRad deg = deg/180 * pi
-    gen x y =
-      let
-          h = fromToS 0 360 (fromIntegral x / fromIntegral width)
-          v = 1
-          s = fromToS 0 1 (fromIntegral y / fromIntegral height)
-          RGB r g b = toSRGBBounded (colorPack hsvComponents h s v)
-      in PixelRGB8 r g b
+hsvColorSpace :: Int -> Tree
+hsvColorSpace width =
+  circlePlot width $ \ang radius ->
+    let
+        h = ang/pi*180
+        v = 1
+        s = radius
+        color = colorPack hsvComponents h s v
+        RGB r g b = toSRGBBounded color
+    in if inGamut sRGBGamut color
+      then PixelRGBA8 r g b 0xFF
+      else PixelRGBA8 0 0 0 0x00

 spacesA :: Animation
 spacesA = mkAnimation 10 $ \t ->
  scaleToSize screenWidth screenHeight $
  if t < 0.3
-    then cieLABImage 100 100
+    then cieLABImage 100 50
    else if t < 0.6
-      then lchColorSpace 100 100
-      else hsvColorSpace 100 100
+      then lchColorSpace 100
+      else hsvColorSpace 100

 highlightE :: Effect
 highlightE d t =
--- a/videos/color-theory/color-theory.hs
+++ b/videos/color-theory/color-theory.hs
@ -18,22 +18,25 @@ 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.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.Scene
 import           Reanimate.Signal
-import           Reanimate.Effect
+import           Reanimate.Interpolate
 import           Reanimate.Svg
-import           Reanimate.ColorSpace
-import           Reanimate.Constants
 import           System.IO.Unsafe

+import           Grid
 import           Spectrum
-
+import           EndScene
 {- Scene sequence

 - black
@ -63,11 +66,15 @@ import           Spectrum
 highdef = True

 main :: IO ()
-main = reanimate $
-  (animate $ const $ mkBackground "black") `parA`
+main = reanimate $ --  takeA 10 $ dropA 55 $
+  parA (staticFrame 1 $ mkBackground "black") $
  monalisaScene `seqA`
-  -- colorSpacesScene
-  scene2
+  falseColorScene `seqA`
+  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
  -- xyzTernaryPlot
  -- interpolation
@ -82,7 +89,7 @@ monalisaScene =
    -- Draw numbers
    fork $
      play $ drawHexPixels
-        # setDuration (drawPixelDelay+toGrayScaleTime)
+        # setDuration (drawPixelDelay+toGrayScaleTime+3)
        # pauseAtBeginning beginPause
        # fadeIn stdFade
    wait beginPause
@ -90,19 +97,20 @@ monalisaScene =
    let PixelRGB8 minR _ _ = minPixel monalisa
        PixelRGB8 maxR _ _ = maxPixel monalisa
    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
-      -- play $ showColorMap (fromIntegral minR/255) ((fromIntegral maxR+1)/255)
-      --   # setDuration toGrayScaleTime
-      --   # pauseAround 1 1
-      --   # fadeIn stdFade
-      --   # fadeOut stdFade
+      play $ showColorMap (fromIntegral minR/255) ((fromIntegral maxR+1)/255)
+        # setDuration 2
+        # pauseAround 1 1
+        # fadeIn 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
    -- play $ sceneColorMaps `sim` (sceneFalseColorChain $ map snd
@ -123,6 +131,52 @@ monalisaScene =
    stdFade = 0.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 = unsafePerformIO $ do
@ -132,7 +186,7 @@ monalisa = unsafePerformIO $ do
    Right img -> return $ convertRGB8 img

 monalisaLarge :: Image PixelRGB8
-monalisaLarge = scaleImage 15 monalisa
+monalisaLarge = scaleImage (if highdef then 15 else 1) monalisa

 maxPixel :: Image PixelRGB8 -> PixelRGB8
 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
    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 limit img =
-    generateImage fn (imageWidth img) (imageHeight img)
-  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
+limitGreyPixels limit = pixelMap $ \pixel@(PixelRGB8 r _ _) ->
+    if r < limit then PixelRGBA8 r r r 255 else PixelRGBA8 0 0 0 0

 renderColorMap :: Double -> Double -> (Double -> PixelRGB8) -> Tree
 renderColorMap width height cmap = mkGroup
@ -281,27 +351,33 @@ mkColorMap f = center $ embedImage img

 drawPixelImage :: Double -> Double -> Animation
 drawPixelImage start end = mkAnimation 2 $ \t ->
-  let limit = fromToS start end $ curveS 2 t
-  in scaleToSize screenWidth screenHeight $ center $ embedImage $
-     limitGreyPixels (floor (limit*255)) monalisaLarge
+    let limit = fromToS start end $ curveS 2 t
+    in scaleToSize screenWidth screenHeight $ center $ embedImage $
+       cache !! floor (limit*255)
+  where
+    cache =
+      [ limitGreyPixels n monalisaLarge
+      | n <- [0..255] ]

 drawHexPixels :: Animation
-drawHexPixels = mkAnimation 1 $ \_ -> 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
-    ]
-  ]
+drawHexPixels = mkAnimation 1 $ \_ -> svg
  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
    getNthSet n = centerX $ snd (splitGlyphs [n*2,n*2+1] allGlyphs)
    allGlyphs = lowerTransformations $ scale 0.15 $ center $ latex $
--- a/videos/color-theory/gen_lab.hs
+++ b/videos/color-theory/gen_lab.hs
@ -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
--- a/videos/color-theory/posters.hs
+++ b/videos/color-theory/posters.hs
@ -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)
--- a/videos/showcase/showcase.hs
+++ b/videos/showcase/showcase.hs
@ -2,6 +2,7 @@
 -- stack runghc --package reanimate
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE QuasiQuotes       #-}
+{-# LANGUAGE ApplicativeDo     #-}
 module Main (main) where

 import           Codec.Picture
@ -103,7 +104,7 @@ sphereIntro = sceneAnimation $ do
  --   # applyE (delayE 1 $ overBeginning 2 fadeInE)
  --   # applyE (delayE 8 $ translateE (-3) 0)
  wait 5
-  playZ 1 $ setDuration 3 $ animate $ \t ->
+  adjustZ (+1) $ play $ setDuration 3 $ animate $ \t ->
    partialSvg t $
    withFillOpacity 0 $
    rotate 180 $
@ -114,25 +115,25 @@ sphereIntro = sceneAnimation $ do
  --   circ
  let scaleFactor = 0.05
  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
    withFillOpacity p $
    translate (1*p) (2*p) $
    scale (1-scaleFactor*p) $
    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
    withFillOpacity p $
    translate (1*p) (-2*p) $
    scale (1-scaleFactor*p) $
    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
    withFillOpacity p $
    translate (5*p) (2*p) $
    scale (1-scaleFactor*p) $
    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
    withFillOpacity p $
    translate (5*p) (-2*p) $
@ -155,13 +156,15 @@ mkFeatSprite xPos yPos ani = do
  spriteAt <- newVar 0
  spriteTMod <- newVar 0
  sprite <- newSprite $ do
-    genAt <- freezeVar spriteAt
-    genT <- freezeVar spriteTMod
-    return $ \real_t d t ->
-      let i = 1-genAt real_t in
+    genAt <- unVar spriteAt
+    genT <- unVar spriteTMod
+    t <- spriteT
+    d <- spriteDuration
+    return $
+      let i = 1-genAt in
      translate (xPos*i) (yPos*i) $
-      scale (1+0.5*genAt real_t) $
-      frameAtT (((t+genT real_t)/d) `mod'` 1) ani
+      scale (1+0.5*genAt) $
+      frameAtT (((t+genT)/d) `mod'` 1) ani
  return (spriteAt, spriteTMod, sprite)

 featSVG :: Animation
@ -227,8 +230,8 @@ introSVG = sceneAnimation $ do
  fork $ play $ animate $ const $
    mkBackground "black"
  -- Title
-  title <- newSprite $ do
-    return $ \_ _d _t ->
+  title <- newSprite $
+    pure $
      translate 0 3.5 $
      center $
      withFillColor "white" $
@ -237,9 +240,9 @@ introSVG = sceneAnimation $ do
  -- Shading
  shadeOpacity <- newVar 0
  shade <- newSprite $ do
-    opacity <- freezeVar shadeOpacity
-    return $ \real_t d t ->
-      withFillOpacity (0.8 * opacity real_t) $
+    opacity <- unVar shadeOpacity
+    return $
+      withFillOpacity (0.8 * opacity) $
      withFillColor "black" $
      mkRect screenWidth screenHeight
  spriteZ shade 1
@ -300,7 +303,8 @@ drawAnimation' fillDur step svg = sceneAnimation $ do
    fork $ do
      wait (n*step+(1-fillDur))
      newSprite $ do
-        return $ \_real_t d t ->
+        t <- spriteT
+        return $
          withStrokeWidth 0 $ fn $ withFillOpacity (min 1 $ t/fillDur) tree
      -- play $ animate (\t -> withStrokeWidth 0 $ fn $ withFillOpacity t tree)
      --   # setDuration fillDur