Add two more (in-progress) videos.

Former-commit-id: 77c27c81c6eaaa4410a21d053dc4d32185860719

videos/bakers-algorithm/bakers-algorithm.hs

@@ -0,0 +1,102 @@
+#!/usr/bin/env stack
+-- stack --resolver lts-13.14 runghc --package reanimate
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+module Main (main) where
+
+import           Control.Lens
+
+import           Graphics.SvgTree
+import           Reanimate.Driver (reanimate)
+import           Reanimate.LaTeX
+import           Reanimate.Monad
+import           Reanimate.Svg
+import           Reanimate.Signal
+
+{- Script
+
+Computer memory is a finite resource: If it is not reused, it'll eventually
+run out.
+
+
+
+-}
+
+-- screen width 320
+-- screen height 180
+{-
+[flat (1/3) 0, linear (1/3) 0 1, linear (1/3) 1 0]
+-}
+main :: IO ()
+main = reanimate $ pauseAtEnd 2
+  (mkAnimation 0 $ emit $ mkBackground "black") `sim`
+  drawBox
+
+drawBox :: Animation
+drawBox = mkAnimation 5 $ do
+  emit $ withFillColor "white" $
+    translate 0 (-70) $
+    scale 2 $ center $ latex "Baker's Algorithm"
+  s <- getSignal $ signalFromList    [(0.7, signalFlat 0), (1, signalLinear)]
+  d <- getSignal $ signalFromList    [(0.7, signalFlat 0), (1, signalLinear)]
+  draw <- getSignal $ signalFromList [(0.5, signalLinear), (1, signalFlat 1)]
+  let mlc = MemoryLineChart
+        { mlcWidth = 230
+        , mlcHeight = 50 + s*50
+        , mlcDivider = d
+        , mlcOuterBox = draw }
+  emit $ translate 0 20 $ renderMemoryLineChart mlc
+
+highlightBox :: Animation
+highlightBox = mkAnimation 2 $ do
+  emit $ withFillColor "white" $
+    translate 0 (-70) $
+    scale 2 $ center $ latex "Highlightbox"
+  let boxX = negate mlcWidth / 2
+      boxY = negate mlcHeight / 2
+      mlcWidth = 230
+      mlcHeight = 50
+  s <- getSignal $ signalFromList    [(0.0, signalFlat 0), (1, signalBell 2)]
+  emit $
+    withStrokeColor "white" $
+    withStrokeWidth (Num $ 0.5 + s) $
+    withFillOpacity 0 $
+    translate (boxX + mlcWidth/2) (boxY + mlcHeight/2) $
+    mkRect (Num mlcWidth) (Num mlcHeight)
+
+data MemoryLineChart = MemoryLineChart
+  { mlcWidth  :: Double
+  , mlcHeight :: Double
+  , mlcDivider :: Double -- 0 -> 1
+  , mlcOuterBox :: Double -- 0 -> 1
+  }
+
+mlcBox :: MemoryLineChart -> (Double, Double, Double, Double)
+mlcBox MemoryLineChart{..} = (boxX, boxY, mlcWidth, mlcHeight)
+  where
+    boxX = negate mlcWidth / 2
+    boxY = negate mlcHeight / 2
+
+renderMemoryLineChart :: MemoryLineChart -> Tree
+renderMemoryLineChart MemoryLineChart{..} = mkGroup
+    [ withStrokeColor "white" $
+      withStrokeWidth (Num 0.5) $
+      withFillOpacity 0 $
+      partialSvg mlcOuterBox $ pathify $
+      translate (boxX + mlcWidth/2) (boxY + mlcHeight/2) $
+      mkRect (Num mlcWidth) (Num mlcHeight)
+    , withStrokeColor "white" $
+      withStrokeWidth (Num 0.5) $
+      mkLine (Num (negate $ mlcWidth/2), Num 0)
+             (Num (negate (mlcWidth/2) + lineWidth), Num 0)
+    , withFillColor "white" $
+      translate (negate (mlcWidth/2) - 10) 0 $ rotate (-90) $
+      center $ latex "Memory"
+    , withFillColor "white" $
+      translate 0 (mlcHeight/2 + 10) $
+      center $ latex "Time $\\rightarrow$"
+    ]
+  where
+    boxX = negate mlcWidth / 2
+    boxY = negate mlcHeight / 2
+    lineWidth = mlcDivider * mlcWidth

videos/sorting-algorithms/sorting-algorithms.hs

@@ -0,0 +1,221 @@
+#!/usr/bin/env stack
+-- stack --resolver lts-13.14 runghc --package reanimate
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+module Main (main) where
+
+import           Control.Lens ()
+
+import           Graphics.SvgTree (Number(..), Tree)
+import           Reanimate.Driver (reanimate)
+import           Reanimate.LaTeX
+import           Reanimate.Monad
+import           Reanimate.Svg
+import           Reanimate.Signal
+import           Reanimate.ColorMap
+import           Codec.Picture.Types
+import           Numeric
+import qualified Data.Text as T
+import qualified Geom2D.CubicBezier          as Bezier
+import Data.Fixed
+import System.Random.Shuffle
+import System.Random
+import Data.List
+
+fixed :: Tree -> Animation -> Animation
+fixed svg ani = mkAnimation 0 (emit svg) `sim` ani
+
+digitWidth = 25
+digitCount = 10
+
+main :: IO ()
+main = reanimate $ fixed bg $ pauseAtEnd 1 $
+    mkAnimation 5 $ do
+      s <- getSignal $ signalLinear
+      emit $ withFillColor "white" $ translate (negate $ digitWidth*digitCount/2) 0 $
+        -- sortingTransition (zip [9,0,1,2,3,4,5,6,8,7] squares) s
+        -- sortingTransition (zip [9,0,1,2,3,4,5,6,8,7] digits) s
+        -- sortingTransition (zip [1,0,2,3,4,5,6,7,8,9] digiSquares) s
+        -- jumpTransition (zip [1,0,2,3,4,5,6,7,8,9] digiSquares) s
+        renderSortElements (mkJumpSorted lst) s
+  where
+    seed = 0xDEADBEEF
+    lst = shuffle' (zip [0..] digiSquares) 10 (mkStdGen seed)
+    bg = mkBackground "black"
+    msg = "0 1 2 3 4 5 6 7 8 9"
+    digits =
+      map (withStrokeColor "black" . withStrokeWidth (Num 0.2)) $
+      map (lowerTransformations . scale 3 . pathify . center . latex . T.pack . show) [0..9]
+    squares = map center [ withFillColorPixel (promotePixel $ viridis (n/9)) $
+      mkRect (Num $ digitWidth+0.2) (Num digitWidth) | n <- [0..9]]
+
+    digiSquares = zipWith (\a b -> mkGroup [a,b]) squares digits
+
+    -- msg = "Eve"
+    glyphs = lowerTransformations $ scale 3 $ pathify $ center $ latexAlign msg
+    fillText = mkAnimation 1 $ do
+      s <- getSignal signalLinear
+      sat <- getSignal $ signalFromTo 0 0.7 signalLinear
+      emit $ withFillColor "white" $ withStrokeColor "white" $ withStrokeWidth (Num $ 0.4 * (1-s)) $
+        withFillOpacity s glyphs
+        -- withSubglyphs [0] (withFillColorPixel $ toRGBString sat 0.0) $
+        -- withSubglyphs [1] (withFillColorPixel $ toRGBString sat 0.1) $
+        -- withSubglyphs [2] (withFillColorPixel $ toRGBString sat 0.2) $
+        -- withSubglyphs [3] (withFillColorPixel $ toRGBString sat 0.3) $
+        -- withSubglyphs [4] (withFillColorPixel $ toRGBString sat 0.4) $
+        -- withSubglyphs [5] (withFillColorPixel $ toRGBString sat 0.5) $
+        -- withSubglyphs [6] (withFillColorPixel $ toRGBString sat 0.6) $
+        -- withSubglyphs [7] (withFillColorPixel $ toRGBString sat 0.7) $
+        -- withSubglyphs [8] (withFillColorPixel $ toRGBString sat 0.8) $
+        -- withSubglyphs [9] (withFillColorPixel $ toRGBString sat 0.9) $
+        -- glyphs
+    drawText = mkAnimation 2 $ do
+      s <- getSignal signalLinear
+      emit $
+        withStrokeColor "white" $ withFillOpacity 0 $ withStrokeWidth (Num 0.4) $
+          partialSvg s glyphs
+
+data Direction = Up | Down | Sideways
+type Delay = Double
+type Position = Int
+data SortElement = SortElement
+  { sortElementDirection :: Direction
+  , sortElementStartTime :: Double
+  , sortElementDuration   :: Double
+  , sortElementStartPosition :: Position
+  , sortElementEndPosition :: Position
+  , sortElementTree :: Tree }
+
+
+mkJumpSorted :: [(Int, Tree)] -> [SortElement]
+mkJumpSorted = fixParameters . worker Up . zip [0..]
+  where
+    worker _ [] = []
+    worker dir ((nth, (target, elt)):rest) =
+      SortElement
+      { sortElementDirection = dir
+      , sortElementStartTime = 0
+      , sortElementDuration = 1
+      , sortElementStartPosition = nth
+      , sortElementEndPosition = target
+      , sortElementTree = elt
+      } : worker (flip dir) (yoink target rest)
+    flip Up = Down
+    flip Down = Up
+
+-- 10
+-- 1/10
+-- 0 -> 0.1
+-- 0.05 -> 0.25
+-- 0.1
+fixParameters :: [SortElement] -> [SortElement]
+fixParameters elts = map setDuration $ setStartTime 0 elts
+  where
+    setStartTime nth [] = []
+    setStartTime nth (elt:elts)
+      | moving elt = elt{sortElementStartTime = fromIntegral nth * duration / 2} :
+                     setStartTime (nth+1) elts
+      | otherwise = elt{sortElementDirection=Sideways} : setStartTime nth elts
+    setDuration elt =
+      elt{sortElementDuration = duration}
+    duration = 2 / (moved+1)
+    moved = fromIntegral $ length $ filter moving elts
+    moving SortElement{..} =
+      sortElementStartPosition /= sortElementEndPosition
+
+yoink :: Int -> [(Int,a)] -> [(Int, a)]
+yoink n lst =
+  [ (nth, elt) | (nth, elt) <- lst, nth == n ] ++
+  [ (nth, elt) | (nth, elt) <- lst, nth /= n ]
+
+mkSorted :: [(Int, Tree)] -> [SortElement]
+mkSorted lst =
+    [ SortElement
+      { sortElementDirection = if even nth then Up else Down
+      , sortElementStartTime = fromIntegral nth * recip (len*2)
+      , sortElementDuration = recip len
+      , sortElementStartPosition = nth
+      , sortElementEndPosition = target
+      , sortElementTree = elt
+      }
+    | (nth, (target, elt)) <- zip [0..] lst
+    ]
+  where
+    len = fromIntegral (length lst)
+
+renderSortElement :: SortElement -> Double -> Tree
+renderSortElement SortElement{..} t
+  | t < sortElementStartTime =
+    translate (fromIntegral sortElementStartPosition * digitWidth) 0 sortElementTree
+  | t > sortElementStartTime + sortElementDuration =
+    translate (fromIntegral sortElementEndPosition * digitWidth) 0 sortElementTree
+  | otherwise =
+    let pos = signalCurve 2 $ (t - sortElementStartTime) / sortElementDuration
+        from = sortElementStartPosition
+        to = sortElementEndPosition
+        linear = fromIntegral from + (fromIntegral (to-from))*pos
+        y = case sortElementDirection of
+               Down -> (sin (pos*pi) * digitWidth)
+               Up   -> negate (sin (pos*pi) * digitWidth)
+               Sideways -> 0 in
+    translate (linear * digitWidth) y sortElementTree
+
+renderSortElements :: [SortElement] -> Double -> Tree
+renderSortElements elts t =
+    mkGroup $
+      [ renderSortElement elt t | elt <- still ] ++
+      [ renderSortElement elt t | elt <- notStill ]
+  where
+    (notStill, still) = partition isMoving elts
+    isMoving SortElement{..} =
+      t > sortElementStartTime && t < sortElementStartTime + sortElementDuration
+      && sortElementStartPosition /= sortElementEndPosition
+
+-- 0 -> 0.5 Move first wrong elt up
+-- 0.5 1 -> Move first wrong elt down
+--          Move second wrong elt up
+-- 1 1.5 -> Move second wrong elt down
+jumpTransition :: [(Int, Tree)] -> Double -> Tree
+jumpTransition elts s = mkGroup
+    [ case () of
+        () | n < selfBegin ->
+              translate (fromIntegral nth * digitWidth) 0 elt
+           | n > selfEnd ->
+              translate (fromIntegral target * digitWidth) 0 elt
+           | otherwise ->
+              translate (pos * digitWidth) (sin (pos*pi) * digitWidth) elt
+    | (nth, (target, elt)) <- zip [0..] elts
+    , let selfBegin = fromIntegral nth * 0.5
+          selfEnd   = fromIntegral nth * 0.5 + 1
+          pos       = n - selfBegin
+    ]
+  where
+    linear from to = fromIntegral from + (fromIntegral (to-from))*frac
+    n = s * fromIntegral (length elts)
+    frac = n `mod'` 1
+    fracNext = (n+0.5) `mod'` 1
+
+sortingTransition :: [(Int,Tree)] -> Double -> Tree
+sortingTransition elts s = mkGroup
+  [ case () of
+      ()
+        | nth == target ->
+          translate (fromIntegral nth*digitWidth) 0 elt
+        -- | nth == target || canMoveDirectly nth target ->
+        --   translate (linear nth target*digitWidth) 0 elt
+        | nth < target ->
+          translate (linear nth target*digitWidth) (sin (s*pi) * digitWidth) elt
+        | otherwise ->
+          translate (linear nth target*digitWidth) (negate $ sin (s*pi) * digitWidth) elt
+  | (nth, (target, elt)) <- zip [0..] elts
+  -- , canMoveDirectly nth target
+  ]
+  where
+    linear from to = fromIntegral from + (fromIntegral (to-from))*s
+    canMoveDirectly from to
+      | from == to = False
+      | abs (from-to) == 1 = True
+      | otherwise =
+          let next = from + signum (to-from)
+              (target,_) = elts !! next
+          in signum (next-target) == signum (from-to) && canMoveDirectly next to