diff --git a/examples/doc_circlePlot.hs b/examples/doc_circlePlot.hs
new file mode 100755
index 0000000..a97f846
--- /dev/null
+++ 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
diff --git a/examples/tut_glue_blender.hs b/examples/tut_glue_blender.hs
index 1579039..3dee7fa 100755
--- 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 =
diff --git a/examples/tut_glue_latex.hs b/examples/tut_glue_latex.hs
index a8f2afc..9565b3e 100755
--- 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 =
diff --git a/examples/tut_glue_potrace.hs b/examples/tut_glue_potrace.hs
index abafd99..9baac61 100755
--- 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)))
diff --git a/examples/tut_glue_povray.hs b/examples/tut_glue_povray.hs
index 7ad0059..a2e2d5f 100755
--- 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 =
diff --git a/examples/tut_glue_povray_ortho.hs b/examples/tut_glue_povray_ortho.hs
index 643bc97..48eb0f7 100755
--- 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 =
diff --git a/reanimate.cabal b/reanimate.cabal
index fbf3a02..f169db1 100644
--- 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
diff --git a/src/Reanimate.hs b/src/Reanimate.hs
index 93ce3c7..00b618e 100644
--- 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,
diff --git a/src/Reanimate/Blender.hs b/src/Reanimate/Blender.hs
index 41b113d..de6bc02 100644
--- 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"
-
diff --git a/src/Reanimate/Builtin/CirclePlot.hs b/src/Reanimate/Builtin/CirclePlot.hs
new file mode 100644
index 0000000..be95c96
--- /dev/null
+++ 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)
diff --git a/src/Reanimate/Builtin/Flip.hs b/src/Reanimate/Builtin/Flip.hs
new file mode 100755
index 0000000..1236645
--- /dev/null
+++ 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 )
+|]
diff --git a/src/Reanimate/ColorSpace.hs b/src/Reanimate/ColorSpace.hs
index bab96ba..a7747c2 100644
--- 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 $
diff --git a/src/Reanimate/Driver.hs b/src/Reanimate/Driver.hs
index 5776604..6a94257 100644
--- 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
 
diff --git a/src/Reanimate/Driver/CLI.hs b/src/Reanimate/Driver/CLI.hs
index 0919936..a7a56e0 100644
--- 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
diff --git a/src/Reanimate/Driver/Server.hs b/src/Reanimate/Driver/Server.hs
index 932c586..6452610 100644
--- 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)
diff --git a/src/Reanimate/Scene.hs b/src/Reanimate/Scene.hs
index 1126430..f8d2a87 100644
--- 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
diff --git a/src/Reanimate/Svg/LineCommand.hs b/src/Reanimate/Svg/LineCommand.hs
index e8e2c85..497fc55 100644
--- 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) =
diff --git a/videos/color-theory/EndScene.hs b/videos/color-theory/EndScene.hs
new file mode 100644
index 0000000..9c669b4
--- /dev/null
+++ 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
diff --git a/videos/color-theory/Grid.hs b/videos/color-theory/Grid.hs
new file mode 100755
index 0000000..7208428
--- /dev/null
+++ 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)
diff --git a/videos/color-theory/SCRIPT.md b/videos/color-theory/SCRIPT.md
new file mode 100644
index 0000000..fed30a9
--- /dev/null
+++ 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.
diff --git a/videos/color-theory/Spectrum.hs b/videos/color-theory/Spectrum.hs
index 86fbc27..1632cf9 100755
--- 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 =
diff --git a/videos/color-theory/color-theory.hs b/videos/color-theory/color-theory.hs
index 1c6ebe2..bcdf0e9 100755
--- 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 $
diff --git a/videos/color-theory/gen_lab.hs b/videos/color-theory/gen_lab.hs
new file mode 100644
index 0000000..7c7c4aa
--- /dev/null
+++ 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
diff --git a/videos/color-theory/posters.hs b/videos/color-theory/posters.hs
new file mode 100755
index 0000000..9141b71
--- /dev/null
+++ 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)
diff --git a/videos/showcase/showcase.hs b/videos/showcase/showcase.hs
index 9a43ad0..a01390e 100644
--- 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