From 8648b7fee0e348b9e66b6ce0b6795c921aa85b73 Mon Sep 17 00:00:00 2001
From: David Himmelstrup <lemmih@gmail.com>
Date: Mon, 14 Oct 2019 18:53:53 +0800
Subject: [PATCH] Feature params (#24)

* Vars and Sprites.

* Bump reanimate-svg dependency.

* Don't memo raster images.

* Feature: svgAsPngFile :: Tree -> FilePath

Former-commit-id: 96681be8f654a1a1638ac778031e76b575782dbd
---
 reanimate.cabal                               |   2 +-
 src/Reanimate/Povray.hs                       |   5 +-
 src/Reanimate/Raster.hs                       |  46 ++--
 src/Reanimate/Scene.hs                        | 231 +++++++++++++++---
 stack-lts-11.yaml                             |   2 +-
 stack-lts-12.yaml                             |   2 +-
 stack.yaml                                    |   2 +-
 stack.yaml.lock                               |   6 +-
 .../sorting-algorithms/sorting-algorithms.hs  | 231 +++++++++++++++++-
 9 files changed, 462 insertions(+), 65 deletions(-)

diff --git a/reanimate.cabal b/reanimate.cabal
index 5b5495a..01ae828 100644
--- a/reanimate.cabal
+++ b/reanimate.cabal
@@ -76,7 +76,7 @@ library
                       Paths_reanimate
   build-depends:       base >=4.10 && <4.13,
                        time, text, filepath, process, directory,
-                       containers, reanimate-svg >= 0.9.3.0, xml, bytestring, lens, linear, mtl, matrix,
+                       containers, reanimate-svg >= 0.9.3.1, xml, bytestring, lens, linear, mtl, matrix,
                        JuicyPixels, attoparsec, parallel, diagrams, diagrams-svg,
                        diagrams-core, diagrams-lib, diagrams-contrib,
                        svg-builder, cubicbezier, palette, websockets,
diff --git a/src/Reanimate/Povray.hs b/src/Reanimate/Povray.hs
index 6ff7c92..b91cebf 100644
--- a/src/Reanimate/Povray.hs
+++ b/src/Reanimate/Povray.hs
@@ -12,7 +12,6 @@ import qualified Data.Text         as T
 import qualified Data.Text.IO      as T
 import           Graphics.SvgTree  (Tree (..))
 import           Reanimate.Cache
-import           Reanimate.Memo
 import           Reanimate.Misc
 import           Reanimate.Raster
 import           Reanimate.Svg.Constructors
@@ -21,7 +20,7 @@ import           System.IO.Unsafe  (unsafePerformIO)
 
 povrayRaw :: [String] -> Text -> Tree
 povrayRaw args script =
-  memo [Key mkPovrayImage, KeyPrim args, KeyPrim script]
+  -- memo [Key mkPovrayImage, KeyPrim args, KeyPrim script]
   (unsafePerformIO $ mkPovrayImage args script)
 
 povray :: [String] -> Text -> Tree
@@ -41,7 +40,7 @@ mkPovrayImage args script = cacheDiskKey key $ do
     T.writeFile pov_file script
     ret <- runCmd_ exec (args ++ ["-D","+UA", pov_file, "+o"++out])
     case ret of
-      Left{} -> error "povray went wrong"
+      Left err -> error $ "povray went wrong:\n" ++ err
       Right{} -> do
         png <- B.readFile out
         case decodePng png of
diff --git a/src/Reanimate/Raster.hs b/src/Reanimate/Raster.hs
index 003e7af..466a18d 100644
--- a/src/Reanimate/Raster.hs
+++ b/src/Reanimate/Raster.hs
@@ -3,11 +3,12 @@ module Reanimate.Raster
   , embedDynamicImage
   , embedPng
   , raster
+  , svgAsPngFile
   ) where
 
 import           Codec.Picture
 import           Codec.Picture.Types         (dynamicMap)
-import           Control.Lens
+import           Control.Lens ((.~),(&))
 import qualified Data.ByteString             as B
 import qualified Data.ByteString.Base64.Lazy as Base64
 import qualified Data.ByteString.Lazy.Char8  as LBS
@@ -18,8 +19,8 @@ import           Reanimate.Misc
 import           Reanimate.Animation
 import           Reanimate.Svg.Constructors
 import           System.FilePath
-import           System.IO
-import           System.IO.Temp
+import           System.Directory
+import           Data.Hashable
 import           System.IO.Unsafe
 
 
@@ -53,18 +54,33 @@ embedDynamicImage img = embedPng width height imgData
         Right dat -> dat
 
 raster :: Tree -> DynamicImage
-raster svg = unsafePerformIO $
-    withSystemTempFile "reanimate.svg" $ \tmpFile handle -> do
-      let target = replaceExtension tmpFile "png"
-      -- ffmpeg <- requireExecutable "ffmpeg"
-      convert <- requireExecutable "convert"
-      hPutStr handle $ renderSvg (Just $ Num width) (Just $ Num height) svg
-      hClose handle
-      runCmd convert [ tmpFile, target ]
-      png <- B.readFile target
-      case decodePng png of
-        Left{}    -> error "bad image"
-        Right img -> return img
+raster svg = unsafePerformIO $ do
+    png <- B.readFile (svgAsPngFile svg)
+    case decodePng png of
+      Left{}    -> error "bad image"
+      Right img -> return img
+
+-- imageAsFile :: DynamicImage -> FilePath
+-- imageAsFile img
+
+svgAsPngFile :: Tree -> FilePath
+svgAsPngFile svg = unsafePerformIO $ do
+    root <- getXdgDirectory XdgCache "reanimate"
+    createDirectoryIfMissing True root
+    let svgPath = root </> show (hash rendered) <.> "svg"
+        pngPath = replaceExtension svgPath "png"
+    hit <- doesFileExist pngPath
+    if hit
+      then return pngPath
+      else do
+        -- ffmpeg <- requireExecutable "ffmpeg"
+        -- convert <- requireExecutable "convert"
+        inkscape <- requireExecutable "inkscape"
+        writeFile svgPath rendered
+        -- runCmd convert [ "-background", "none", "-antialias", svgPath, pngPath ]
+        runCmd inkscape [ svgPath, "--export-png=" ++ pngPath, "--without-gui" ]
+        return pngPath
   where
+    rendered = renderSvg (Just $ Num width) (Just $ Num height) svg
     width = 2560
     height = width * 9 / 16
diff --git a/src/Reanimate/Scene.hs b/src/Reanimate/Scene.hs
index 48571dc..b716faf 100644
--- a/src/Reanimate/Scene.hs
+++ b/src/Reanimate/Scene.hs
@@ -8,6 +8,9 @@ import           Data.Ord
 import           Data.STRef
 import           Reanimate.Animation
 import           Reanimate.Signal
+import           Reanimate.Effect
+import           Reanimate.Svg.Constructors
+import           Graphics.SvgTree (Tree(None))
 
 type ZIndex = Int
 
@@ -18,7 +21,8 @@ o # f = f o
 -- [(Time, Animation, ZIndex)]
 -- Map Time [(Animation, ZIndex)]
 type Timeline = [(Time, Animation, ZIndex)]
-newtype Scene s a = M { unM :: Time -> ST s (a, Duration, Duration, Timeline) }
+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 = (++)
@@ -28,42 +32,52 @@ emptyTimeline = []
 
 instance Functor (Scene s) where
   fmap f action = M $ \t -> do
-    (a, d1, d2, tl) <- unM action t
-    return (f a, d1, d2, tl)
+    (a, d1, d2, tl, gens) <- unM action t
+    return (f a, d1, d2, tl, gens)
 
 instance Applicative (Scene s) where
-  pure a = M $ \_ -> return (a, 0, 0, emptyTimeline)
+  pure a = M $ \_ -> return (a, 0, 0, emptyTimeline, [])
   f <*> g = M $ \t -> do
-    (f', s1, p1, tl1) <- unM f t
-    (g', s2, p2, tl2) <- unM g (t+s1)
-    return (f' g', s1+s2, max p1 (s1+p2), unionTimeline tl1 tl2)
+    (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)
 
 instance Monad (Scene s) where
   return = pure
   f >>= g = M $ \t -> do
-    (a, s1, p1, tl1) <- unM f t
-    (b, s2, p2, tl2) <- unM (g a) (t+s1)
-    return (b, s1+s2, max p1 (s1+p2), unionTimeline tl1 tl2)
+    (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)
 
 instance MonadFix (Scene s) where
-  mfix fn = M $ \t -> mfix (\v -> let (a,_s,_p,_tl) = v in unM (fn a) t)
+  mfix fn = M $ \t -> mfix (\v -> let (a,_s,_p,_tl,_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, emptyTimeline, [])
 
 sceneAnimation :: (forall s. Scene s a) -> Animation
-sceneAnimation action = foldl' parDropA (pause 0) $
-  map snd $ sortBy (comparing fst)
-    [ (z, pause startT `seqA` a)
-    | (startT, a, z) <- tl
-    ]
-  where
-    (_, _, _, tl) = runST (unM action 0)
+sceneAnimation action =
+  runST (do
+    (_, s, p, tl, gens) <- unM action 0
+    let dur = max s p
+        anis = foldl' parDropA (pause 0) $
+                map snd $ sortBy (comparing fst)
+                  [ (z, pause startT `seqA` a)
+                  | (startT, a, z) <- tl
+                  ]
+    genFns <- sequence gens
+    return $ anis `parA` mkAnimation dur (\t ->
+      mkGroup $
+      map fst $
+      sortBy (comparing snd)
+      [ spriteRender dur (t*dur)
+      | spriteRender <- genFns ])
+  )
 
 fork :: Scene s a -> Scene s a
 fork (M action) = M $ \t -> do
-  (a, s, p, tl) <- action t
-  return (a, 0, max s p, tl)
+  (a, s, p, tl, gens) <- action t
+  return (a, 0, max s p, tl, gens)
 
 play :: Animation -> Scene s ()
 play = playZ 0
@@ -71,16 +85,16 @@ play = playZ 0
 playZ :: ZIndex -> Animation -> Scene s ()
 playZ z ani = M $ \t -> do
   let d = duration ani
-  return ((), d, 0, [(t, ani, z)])
+  return ((), d, 0, [(t, ani, z)], [])
 
 queryNow :: Scene s Time
-queryNow = M $ \t -> return (t, 0, 0, emptyTimeline)
+queryNow = M $ \t -> return (t, 0, 0, emptyTimeline, [])
 
 -- 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) <- action t
-  return (a, max s p, 0, tl)
+  (a, s, p, tl, gens) <- action t
+  return (a, max s p, 0, tl, gens)
 
 waitUntil :: Time -> Scene s ()
 waitUntil tNew = do
@@ -89,12 +103,12 @@ waitUntil tNew = do
 
 wait :: Duration -> Scene s ()
 wait d = M $ \_ ->
-  return ((), d, 0, emptyTimeline)
+  return ((), d, 0, emptyTimeline, [])
 
 adjustZ :: (ZIndex -> ZIndex) -> Scene s a -> Scene s a
 adjustZ fn (M action) = M $ \t -> do
-  (a, s, p, tl) <- action t
-  return (a, s, p, [ (startT, ani, fn z) | (startT, ani, z) <- tl ])
+  (a, s, p, tl, gens) <- action t
+  return (a, s, p, [ (startT, ani, fn z) | (startT, ani, z) <- tl ], gens)
 
 withSceneDuration :: Scene s () -> Scene s Duration
 withSceneDuration s = do
@@ -116,8 +130,8 @@ stretchTimeline = mapM_ worker
           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)
+        then return ((), 0, 0, [(tNew, aNew, z)], [])
+        else return ((), 0, 0, emptyTimeline, [])
 
 dropObject :: Object s -> Scene s ()
 dropObject (Object ref) = do
@@ -130,8 +144,8 @@ dropObject (Object ref) = do
 
 listen :: Scene s a -> Scene s (a, Timeline)
 listen scene = M $ \t -> do
-  (a, s, p, tl) <- unM scene t
-  return ((a,tl), s, p, tl)
+  (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
@@ -139,3 +153,156 @@ withObject obj@(Object ref) scene = do
   (a, tl) <- listen scene
   liftST $ writeSTRef ref (Just tl)
   return a
+
+
+data Param s a = Param (STRef s (Time, Time, Time -> a))
+
+newParam :: a -> Scene s (Param s a)
+newParam initVal = do
+  now <- queryNow
+  Param <$> liftST (newSTRef (now, -1, const initVal))
+
+destroyParam :: Param s a -> Scene s ()
+destroyParam (Param ref) = do
+  now <- queryNow
+  liftST $ do
+    (startT, _endT, fn) <- readSTRef ref
+    writeSTRef ref (startT, now, fn)
+
+readParam :: Param s a -> Scene s a
+readParam (Param ref) = do
+  now <- queryNow
+  (_, _, fn) <- liftST $ readSTRef ref
+  return $ fn now
+
+paramAt :: Param s a -> Time -> ST s a
+paramAt = undefined
+
+paramFn :: Param s a -> ST s (Time -> a)
+paramFn (Param ref) = do
+  (_, _, fn) <- readSTRef ref
+  return fn
+
+withParamAt :: Param s a -> Time -> (a -> ST s SVG) -> ST s SVG
+withParamAt = undefined
+
+fromParams :: Gen s -> Scene s ()
+fromParams gen = M $ \_ -> return ((), 0, 0, emptyTimeline, [gen])
+
+setParam :: Param s a -> a -> Scene s ()
+setParam = undefined
+
+-- setParamZIndex :: Param s a -> ZIndex -> Scene s ()
+-- setParamZIndex = undefined
+--
+-- adjustParamZIndex :: Param s a -> Duration -> (Time -> ZIndex -> ZIndex) -> Scene s ()
+-- adjustParamZIndex = undefined
+--
+-- adjustParamZIndex_ :: Param s a -> (Time -> ZIndex -> ZIndex) -> Scene s ()
+-- adjustParamZIndex_ = undefined
+
+tweenParam :: Param s a -> Duration -> (Double -> a -> a) -> Scene s ()
+tweenParam (Param ref) dur fn = do
+  now <- queryNow
+  liftST $ do
+    (startT,endT,prevFn) <- readSTRef ref
+    let worker t
+          | t > now = fn (min 1 ((t-now)/dur)) (prevFn t)
+          | otherwise = prevFn t
+    writeSTRef ref (startT, endT, worker)
+  wait dur
+
+tweenParam_ :: Param s a -> (Time -> a -> a) -> Scene s ()
+tweenParam_ = undefined
+
+simpleParam :: (a -> SVG) -> a -> Scene s (Param s a)
+simpleParam render def = do
+  p <- newParam def
+  fromParams $ do
+    fn <- paramFn p
+    return $ \_d t -> (render $ fn t, 0)
+  return p
+
+data Var s a = Var (STRef s (Time -> a))
+
+newVar :: a -> Scene s (Var s a)
+newVar def = Var <$> liftST (newSTRef (const def))
+
+readVar :: Var s a -> Scene s a
+readVar (Var ref) = liftST (readSTRef ref) <*> queryNow
+
+writeVar :: Var s a -> a -> Scene s ()
+writeVar var val = modifyVar var (const val)
+
+modifyVar :: Var s a -> (a -> a) -> Scene s ()
+modifyVar (Var ref) fn = do
+  now <- queryNow
+  liftST $ modifySTRef ref $ \prev t ->
+    if t < now
+      then prev t
+      else fn (prev t)
+
+tweenVar :: Var s a -> Duration -> (Time -> a -> a) -> Scene s ()
+tweenVar (Var ref) dur fn = do
+  now <- queryNow
+  liftST $ modifySTRef ref $ \prev t ->
+    if t < now
+      then prev t
+      else fn (min dur $ t-now) $ prev t
+
+freezeVar :: Var s a -> ST s (Time -> a)
+freezeVar (Var ref) = readSTRef ref
+
+findVar :: (a -> Bool) -> [Var s a] -> Scene s (Var s a)
+findVar _cond [] = error "Variable not found."
+findVar cond (v:vs) = do
+  val <- readVar v
+  if cond val then return v else findVar cond vs
+
+data Sprite s = Sprite Time (STRef s (Duration, Duration -> Time -> SVG -> (SVG, ZIndex)))
+
+newSprite :: ST s (Time -> Duration -> Time -> SVG) -> Scene s (Sprite s)
+newSprite render = do
+  now <- queryNow
+  ref <- liftST $ newSTRef (-1, \_d _t svg -> (svg, 0))
+  fromParams $ do
+    fn <- render
+    (spriteDuration, spriteEffect) <- readSTRef ref
+    return $ \d t ->
+      let realD = (if spriteDuration < 0 then d else spriteDuration)-now
+          realT = t-now in
+      if realT < 0 || realD < realT
+        then (None, 0)
+        else spriteEffect realD realT (fn t realD realT)
+  return $ Sprite now ref
+
+destroySprite :: Sprite s -> Scene s ()
+destroySprite (Sprite _ ref) = do
+  now <- queryNow
+  liftST $ modifySTRef ref $ \(ttl, render) ->
+    (if ttl < 0 then now else min ttl now, render)
+
+spriteE :: Sprite s -> Effect -> Scene s ()
+spriteE (Sprite born ref) effect = do
+  now <- queryNow
+  liftST $ modifySTRef ref $ \(ttl, render) ->
+    (ttl, \d t svg ->
+      let (svg', z) = render d t svg
+      in (delayE (now-born) effect d t svg', z))
+
+{-
+data Var s a = Var (STRef s (Time -> a))
+data Sprite s = Sprite (STRef s (Duration, Duration -> Time -> (SVG, ZIndex)))
+
+newVar :: a -> Scene s (Var s a)
+readVar :: Var s a -> Scene s a
+writeVar :: Var s a -> a -> Scene s ()
+modifyVar :: Var s a -> (a -> a) -> Scene s ()
+freezeVar :: Var s a -> ST s (Time -> a)
+
+newSprite :: ST s (Time -> Time -> SVG) -> Scene s (Sprite s)
+destroySprite :: Sprite s -> Scene s ()
+spriteE :: Sprite s -> Effect -> Scene s ()
+
+newBlock :: Var s Position -> Number -> Scene s (Sprite s)
+-}
diff --git a/stack-lts-11.yaml b/stack-lts-11.yaml
index 62a98e4..b6e919e 100644
--- a/stack-lts-11.yaml
+++ b/stack-lts-11.yaml
@@ -6,7 +6,7 @@ packages:
 - .
 
 extra-deps:
-- reanimate-svg-0.9.3.0
+- reanimate-svg-0.9.3.1
 - palette-0.3.0.2
 - chiphunk-0.1.2.0
 - diagrams-1.4@sha256:3e36369e84115b900fd9dcb570672a188339a470eb19ca62170775cd835cf8ca
diff --git a/stack-lts-12.yaml b/stack-lts-12.yaml
index 44ab20f..bf743b3 100644
--- a/stack-lts-12.yaml
+++ b/stack-lts-12.yaml
@@ -6,7 +6,7 @@ packages:
 - .
 
 extra-deps:
-- reanimate-svg-0.9.3.0
+- reanimate-svg-0.9.3.1
 - palette-0.3.0.2
 - chiphunk-0.1.2.0
 - diagrams-1.4@sha256:3e36369e84115b900fd9dcb570672a188339a470eb19ca62170775cd835cf8ca
diff --git a/stack.yaml b/stack.yaml
index b17df24..58c80e8 100644
--- a/stack.yaml
+++ b/stack.yaml
@@ -6,7 +6,7 @@ packages:
 - .
 
 extra-deps:
-- reanimate-svg-0.9.3.0
+- reanimate-svg-0.9.3.1
 - palette-0.3.0.2
 - chiphunk-0.1.2.0
 - diagrams-1.4@sha256:3e36369e84115b900fd9dcb570672a188339a470eb19ca62170775cd835cf8ca
diff --git a/stack.yaml.lock b/stack.yaml.lock
index d5313ac..0fedbf7 100644
--- a/stack.yaml.lock
+++ b/stack.yaml.lock
@@ -5,12 +5,12 @@
 
 packages:
 - completed:
-    hackage: reanimate-svg-0.9.3.0@sha256:ba0414bce09a0f298b1ab5e1f0f9f75f4f47498e12dd0c6a75c2e63f33e34ca4,2448
+    hackage: reanimate-svg-0.9.3.1@sha256:ce3783b5d8437ec39f60c4bc9199068dbfe5d074baecee085303c5c850f9428f,2448
     pantry-tree:
       size: 1117
-      sha256: 1b559678d25e1fa98c75fad0315851c4c805f3cb6f2779ab4be7eb6868b4838e
+      sha256: 470085c4740a4790e9d96c588c17ddea879f7b4a793041eebfa982625b69450f
   original:
-    hackage: reanimate-svg-0.9.3.0
+    hackage: reanimate-svg-0.9.3.1
 - completed:
     hackage: palette-0.3.0.2@sha256:50e210b7d21a0c394a6d672cc3c6d3bffcfa1be07419d72b99e68cfb65d6ca3c,1485
     pantry-tree:
diff --git a/videos/sorting-algorithms/sorting-algorithms.hs b/videos/sorting-algorithms/sorting-algorithms.hs
index ace9720..efc5433 100755
--- a/videos/sorting-algorithms/sorting-algorithms.hs
+++ b/videos/sorting-algorithms/sorting-algorithms.hs
@@ -10,6 +10,7 @@ import           Codec.Picture.Types
 import           Data.Fixed
 import           Control.Monad
 import           Data.List
+import           Data.Ord (comparing)
 import qualified Data.Text             as T
 import qualified Geom2D.CubicBezier    as Bezier
 import           Graphics.SvgTree      (Number (..), Tree)
@@ -34,7 +35,10 @@ digitWidth = screenWidth/10
 digitCount = 10
 
 main :: IO ()
-main = reanimate $ fixed bg $ pauseAtEnd 1 $ sceneAnimation (simpleSort lst)
+main = reanimate $ fixed bg $ pauseAtEnd 1 $
+    -- sceneAnimation (bubbleSort lst) `seqA` sceneAnimation (simpleSort lst)
+    -- sceneAnimation (simpleSort_ lst)
+    sceneAnimation (quicksort__ lst)
     -- mkAnimation 5 $ \t ->
     --   withFillColor "white" $ translate (negate $ digitWidth*digitCount/2) 0 $
         -- sortingTransition (zip [9,0,1,2,3,4,5,6,8,7] squares) s
@@ -49,7 +53,7 @@ main = reanimate $ fixed bg $ pauseAtEnd 1 $ sceneAnimation (simpleSort lst)
     bg = mkBackground "black"
     msg = "0 1 2 3 4 5 6 7 8 9"
     digits =
-      map (withStrokeColor "black" . withStrokeWidth 0) $
+      map (withStrokeColor "black" . withStrokeWidth 0.01 . withFillColor "white") $
       map (lowerTransformations . scale 1 . pathify . center . latex . T.pack . show) [0..9]
     squares = map center [ withFillColorPixel (promotePixel $ viridis (n/9)) $
       mkRect (digitWidth*1.00) digitWidth | n <- [0..9]]
@@ -221,6 +225,14 @@ sortingTransition elts s = mkGroup
               (target,_) = elts !! next
           in signum (next-target) == signum (from-to) && canMoveDirectly next to
 
+moveDigit :: Int -> Int -> Double -> Tree -> Animation
+moveDigit fromX toX dir t =
+  signalA (curveS 2) $ animate $ \time ->
+    translate (fromToS fromPos toPos time) (sin (time*pi)*digitWidth*dir) t
+  where
+    fromPos = fromIntegral (fromX-5) * digitWidth + digitWidth/2
+    toPos = fromIntegral (toX-5) * digitWidth + digitWidth/2
+
 simpleSort :: [(Int, Tree)] -> Scene s ()
 simpleSort lst = do
   objs <- replicateM 10 newObject
@@ -237,15 +249,218 @@ simpleSort lst = do
         worker dir rest
       worker dir ((i, (nth,t)):rest) = do
         z <- round <$> queryNow
-        let obj = objs!!nth
-            fromX = fromIntegral (i-5) * digitWidth + digitWidth/2
-            toX = fromIntegral (nth-5) * digitWidth + digitWidth/2
-        withObject obj $
-          fork $ playZ (10+z) $ signalA (curveS 2) $ animate $ \time ->
-            translate (fromToS fromX toX time) (sin (time*pi)*digitWidth*dir) t
+        withObject (objs!!nth) $
+          fork $ playZ (10+z) $ moveDigit i nth dir t
         wait 0.5
         worker (negate dir) $ yoink nth rest
 
   waitAll $ worker 1 (zip [0..] lst)
 
   forM_ objs dropObject
+
+simpleSort_ :: [(Int, Tree)] -> Scene s ()
+simpleSort_ lst = do
+    params <- forM (zip [0..] lst) newBlock
+    wait 1
+    let worker _ [] = return ()
+        worker dir ((i, (nth,t)):rest) | i == nth =
+          worker dir rest
+        worker dir ((i, (nth,t)):rest) = do
+          z <- round <$> queryNow
+          fork $ tweenParam (params!!i) 1 $ \t (x,y,elt) ->
+            let s = curveS 2 t in
+            (fromToS x (fromIntegral nth) s, y+sin (pi*s )*dir, elt)
+          wait 0.5
+          worker (negate dir) $ yoink nth rest
+
+    waitAll $ worker 1 (zip [0..] lst)
+  where
+    newBlock (i, elt) = simpleParam render (i, 0, elt)
+    render (i, y, (_, t)) =
+      translate (-digitWidth*5 + i*digitWidth + digitWidth/2)
+                (y*digitWidth) t
+
+quicksort_ :: [(Int, Tree)] -> Scene s ()
+quicksort_ lst = do
+    params <- liftST $ V.new (length lst)
+    forM_ (zip [0..] lst) $ \(i, elt) -> do
+      block <- newBlock (fromIntegral i, elt)
+      liftST $ V.write params i block
+
+    let partition pivot lo hi = do
+          loValP <- liftST (V.read params lo)
+          loVal <- readParam loValP
+          hiValP <- liftST (V.read params hi)
+          hiVal <- readParam hiValP
+          if getKey loVal < getKey pivot
+            then partition pivot (lo+1) hi
+            else if getKey hiVal > getKey pivot
+              then partition pivot lo (hi-1)
+              else if lo >= hi
+                then return hi
+                else do
+                  liftST $ V.write params lo hiValP
+                  liftST $ V.write params hi loValP
+                  fork $ tweenParam hiValP 1 $ \t (x,y,elt) ->
+                    let s = curveS 2 t in
+                    (fromToS x (getPos loVal) s, y+sin (pi*s), elt)
+                  fork $ tweenParam loValP 1 $ \t (x,y,elt) ->
+                    let s = curveS 2 t in
+                    (fromToS x (getPos hiVal) s, y-sin (pi*s), elt)
+                  wait 1
+                  partition pivot (lo+1) (hi-1)
+    let worker lo hi | lo >= hi = return ()
+        worker lo hi = do
+          pivotP <- getPivot params lo hi
+          pivot <- readParam pivotP
+          tweenParam pivotP 1 $ \t (x,y,elt) ->
+            let s = curveS 2 t in
+            (x, y-s/2, elt)
+          p <- partition pivot lo hi
+          tweenParam pivotP 1 $ \t (x,y,elt) ->
+            let s = curveS 2 t in
+            (x, y+s/2, elt)
+          fork $ worker lo p
+          fork $ worker (p+1) hi
+    worker 0 (length lst-1)
+  where
+    getPivot params lo hi = do
+      let middle = lo + (hi-lo) `div` 2
+          indices = filter (< hi) $ filter (>= lo) [middle-1,middle,middle+1]
+      selected <- forM indices $ \idx -> liftST (V.read params idx)
+      keys <- mapM readParam selected
+      return $ head $ drop (length indices `div` 2) $ map snd $ sortBy (comparing fst) $ zip (map getKey keys) selected
+    getPos (x, _, _) = x
+    getKey (_x, _y, (i, _)) = i
+    newBlock (i, elt) = simpleParam render (i, 0, elt)
+    render (i, y, (_, t)) =
+      translate (-digitWidth*5 + i*digitWidth + digitWidth/2)
+                (y*digitWidth) t
+
+quicksort__ :: [(Int, Tree)] -> Scene s ()
+quicksort__ lst = do
+    vars <- mapM newBlock (zip [0..] lst)
+    forM_ vars $ \var -> newSprite $ do
+      varT <- freezeVar var
+      return $ \realT _d _t ->
+        render (varT realT)
+
+    let getNth nth = findVar (\obj -> round (getPos obj) == nth) vars
+        getPivot lo hi = do
+          let middle = lo + (hi-lo) `div` 2
+          getNth middle
+
+    let partition pivot lo hi = do
+          loValP <- getNth lo
+          loVal <- readVar loValP
+          hiValP <- getNth hi
+          hiVal <- readVar hiValP
+          if getKey loVal < getKey pivot
+            then partition pivot (lo+1) hi
+            else if getKey hiVal > getKey pivot
+              then partition pivot lo (hi-1)
+              else if lo >= hi
+                then return hi
+                else do
+                  tweenVar hiValP 1 $ \t (x,y,elt) ->
+                    let s = curveS 2 t in
+                    (fromToS x (getPos loVal) s, y+sin (pi*s), elt)
+                  tweenVar loValP 1 $ \t (x,y,elt) ->
+                    let s = curveS 2 t in
+                    (fromToS x (getPos hiVal) s, y-sin (pi*s), elt)
+                  wait 1
+                  partition pivot (lo+1) (hi-1)
+    let preshuffle lo hi = do
+          let middle = lo + (hi-lo) `div` 2
+              targets = nub [lo, middle, hi]
+          selected <- sortBy (comparing getKey) <$> (mapM readVar =<< mapM getNth targets)
+          let toMove = [ (target, origX) | (target, origX) <- zip selected targets]
+          unless (null toMove) $ do
+            forM_ toMove $ \(target,_) -> do
+              var <- getNth (round (getPos target))
+              tweenVar var 1 $ \t (x,y,elt) ->
+                let s = curveS 2 t in
+                (x, y+s/2, elt)
+            wait 1
+            forM_ toMove $ \(target,origX) ->
+              when (round (getPos target) /= origX) $ do
+                var <- getNth (round (getPos target))
+                tweenVar var 1 $ \t (x,y,elt) ->
+                  let s = curveS 2 t in
+                  (fromToS x (fromIntegral origX) s, y+sin (pi*s)/2, elt)
+            forM_ toMove $ \(target,_) -> do
+              var <- getNth (round (getPos target))
+              tweenVar var 1 $ \t (x,y,elt) ->
+                let s = curveS 2 t in
+                (x, y-s/2, elt)
+            wait 1
+    let worker lo hi | lo >= hi = return ()
+        worker lo hi | hi-lo <= 2 =
+          preshuffle lo hi
+        worker lo hi = do
+          preshuffle lo hi
+          pivotP <- getPivot lo hi
+          pivot <- readVar pivotP
+          tweenVar pivotP 1 $ \t (x,y,elt) ->
+            let s = curveS 2 t in
+            (x, y-s/2, elt)
+          wait 1
+          p <- partition pivot lo hi
+          tweenVar pivotP 1 $ \t (x,y,elt) ->
+            let s = curveS 2 t in
+            (x, y+s/2, elt)
+          wait 1
+          worker lo (p-1)
+          worker (p+1) hi
+    worker 0 (length lst-1)
+  where
+    getPos (x, _, _) = x
+    getKey (_x, _y, (i, _)) = i
+    newBlock (x, (i, elt)) = newVar (x, 0, (i, elt))
+    render (i, y, (_, t)) =
+      translate (-digitWidth*5 + i*digitWidth + digitWidth/2)
+                (y*digitWidth) t
+
+bubbleSort :: [(Int, Tree)] -> Scene s ()
+bubbleSort lst = do
+  objs <- replicateM (length lst) newObject
+  forM_ (zip [0..] lst) $ \(i, (nth, t)) -> do
+    withObject (objs!!nth) $
+      fork $ playZ 0 $ animate $ const $
+        translate (-digitWidth*5 + fromIntegral i*digitWidth + digitWidth/2) 0 t
+
+  wait 1
+
+  v <- liftST $ V.new (length lst)
+  liftST $ mapM_ (\(i,e) -> V.write v i e) (zip [0..] lst)
+
+  let worker n c | n+1 >= length lst =
+        when c $ worker 0 False
+      worker n c = do
+        (nth1, t1) <- liftST $ V.read v n
+        (nth2, t2) <- liftST $ V.read v (n+1)
+        when (nth1 > nth2) $ waitAll $ do
+          liftST $ V.write v n (nth2, t2)
+          liftST $ V.write v (n+1) (nth1, t1)
+          withObject (objs!!nth1) $
+            fork $ playZ 1 $ moveDigit n (n+1) (0.5) t1
+          withObject (objs!!nth2) $
+            fork $ playZ 1 $ moveDigit (n+1) n (-0.5) t2
+        worker (n+1) (c || nth1 > nth2)
+  worker 0 False
+  forM_ objs dropObject
+
+highlightPair :: Int -> Int -> Animation
+highlightPair fromX toX = animate $ \t ->
+    withStrokeWidth 0.1 $
+    withStrokeColor "white" $
+    mkLinePath
+      [ (xPos t,yPos-0.3)
+      , (xPos t,yPos)
+      , (xPos t+digitWidth, yPos)
+      , (xPos t+digitWidth, yPos-0.3)]
+  where
+    yPos = digitWidth*1.1
+    xPos = fromToS fromPos toPos
+    fromPos = fromIntegral (fromX-5) * digitWidth + digitWidth/2
+    toPos = fromIntegral (toX-5) * digitWidth + digitWidth/2