Path manipulation tools and a corresponding gif example.

reanimate.cabal

@@ -25,7 +25,7 @@ library
   other-modules:      Reanimate.Misc
   build-depends:       base >=4.12 && <4.13,
                        lucid-svg, time, text, unix, lucid, filepath, process, directory,
-                       containers, svg-tree, xml, bytestring, lens
+                       containers, svg-tree, xml, bytestring, lens, linear, mtl
 
 executable reanimate-viewer
   main-is:             SvgViewer.hs
@@ -40,6 +40,6 @@ executable reanimate-viewer
   build-depends:       base >=4.12 && <4.13, cairo >=0.13 && <0.14, gtk,
                        svgcairo, lucid-svg, time, text, unix, lucid, reanimate,
                        filepath, process, directory, containers, svg-tree, xml,
-                       bytestring, lens
+                       bytestring, lens, linear, mtl
   hs-source-dirs:      src
   default-language:    Haskell2010

src/Reanimate/Combinators.hs

@@ -65,6 +65,10 @@ par a b = proc t -> do
   a -< t
   b -< t
 
+pauseAtEnd :: Double -> Animation a () -> Animation a ()
+pauseAtEnd d (Animation d' fn) = Animation (d+d') $ \d t a ->
+  fn d (min d' t) a
+
 type Path = [(Double, Double)]
 
 approxFnData :: Int -> (Double -> (Double, Double)) -> Path
@@ -141,6 +145,12 @@ freeze :: Double -> Ani a -> Ani a
 freeze d (Animation d' fn) =
   Animation (d+d') (\dur t -> if t > d' then fn d' d' else fn d' t)
 
+pause :: Double -> Ani ()
+pause d = Animation d (\d t _ -> pure ())
+
+andThen :: Ani () -> Ani () -> Ani ()
+andThen a b = sim [a, pause (animationDuration a) `before` b]
+
 loop :: Ani a -> Ani a
 loop (Animation d fn) =
   Animation d (\dur t -> fn dur (mod' t d))

src/Reanimate/Examples.hs

@@ -4,9 +4,12 @@
 module Reanimate.Examples where
 
 import           Control.Arrow         (returnA, (>>>))
+import           Control.Lens
 import           Control.Monad
 import           Data.Monoid           ((<>))
 import           Data.Text             (Text, pack)
+import qualified Graphics.Svg          as S
+import           Linear.V2
 import           Lucid.Svg
 import           Numeric
 import           Text.Printf
@@ -14,6 +17,7 @@ import           Text.Printf
 import           Reanimate.Arrow
 import           Reanimate.Combinators
 import           Reanimate.LaTeX
+import           Reanimate.Svg
 
 sinewave :: Ani ()
 sinewave = proc () -> do
@@ -349,7 +353,7 @@ latex_basic = proc () -> do
       g_ [stroke_ "white", fill_opacity_ "0", stroke_width_ "0.1"] text
       g_ [fill_ "white", num_ fill_opacity_ s]                     text
   where
-    text = latex "\\sum_{k=1}^\\infty {1 \\over k^2} = {\\pi^2 \\over 6}"
+    text = toHtml $ latexAlign "\\sum_{k=1}^\\infty {1 \\over k^2} = {\\pi^2 \\over 6}"
 
 bezier :: Ani ()
 bezier = adjustSpeed 0.4 $ proc () -> do
@@ -394,3 +398,40 @@ bezier = adjustSpeed 0.4 $ proc () -> do
     between (x1, y1) (x2, y2) idx =
       ( x1 + idx * (x2 - x1)
       , y1 + idx * (x2-x1) * (y2 - y1) / (x2 - x1))
+
+pathSquare :: Ani ()
+pathSquare = proc () -> do
+    duration 2 -< ()
+    s <- signalOscillate 0 1 -< ()
+    emit -< rect_ [width_ "100%", height_ "100%", fill_ "black"]
+    emit -< g_ [stroke_ "white"] $ toHtml (square s)
+  where
+    square s = S.PathTree (myPath s)
+    myPath s = S.defaultSvg
+      & S.pathDefinition .~ interpolatePathCommands s myPathCmds
+    myPathCmds =
+      [ S.MoveTo S.OriginAbsolute [V2 100 100]
+      , S.LineTo S.OriginAbsolute [V2 200 150]
+      , S.LineTo S.OriginRelative [V2 (-10) (-100)]
+      , S.EndPath
+      ]
+
+latex_draw :: Ani ()
+latex_draw = pauseAtEnd 1 $ defineAnimation $ proc () -> do
+  emit -< rect_ [width_ "100%", height_ "100%", fill_ "black"]
+  drawText msg `andThen` fillText msg -< ()
+  where
+    msg = "\\sum_{k=1}^\\infty {1 \\over k^2} = {\\pi^2 \\over 6}"
+    placement = g_ [transform_ $ translate 20 15 <> " " <> scale 5 5]
+    fillText txt = defineAnimation $ proc () -> do
+      duration 1 -< ()
+      s <- signal 0 1 -< ()
+      emit -< placement $
+          g_ [fill_ "white", num_ fill_opacity_ s] $
+            toHtml $ latexAlign txt
+    drawText txt = defineAnimation $ proc () -> do
+      duration 2 -< ()
+      s <- signal 0 1 -< ()
+      emit -< placement $
+          g_ [stroke_ "white", fill_opacity_ "0", stroke_width_ "0.1"] $
+            toHtml $ partialSvg s $ latexAlign txt

src/Reanimate/LaTeX.hs

@@ -1,6 +1,6 @@
 {-# LANGUAGE OverloadedStrings   #-}
 {-# LANGUAGE ScopedTypeVariables #-}
-module Reanimate.LaTeX (latex) where
+module Reanimate.LaTeX (latex,latexAlign) where
 
 import           Control.Exception     (SomeException, handle)
 import qualified Data.ByteString       as B
@@ -15,7 +15,7 @@ import           System.FilePath       (replaceExtension, takeFileName, (</>))
 import           System.IO.Unsafe      (unsafePerformIO)
 
 import           Graphics.Svg          (loadSvgFile, parseSvgFile,
-                                        xmlOfDocument, Tree, elements, defaultSvg, Document)
+                                        xmlOfDocument, Tree, elements, defaultSvg, Document(..))
 import           Text.XML.Light.Output (ppcElement, ppcContent, prettyConfigPP)
 import           Text.XML.Light (elContent)
 import Control.Lens (over, (^.),set, (.~), (&), (%~) )
@@ -30,11 +30,26 @@ instance ToHtml Document where
     where
       elt = xmlOfDocument doc
 
+instance ToHtml Tree where
+  toHtml = toHtmlRaw
+  toHtmlRaw tree = toHtmlRaw doc
+    where
+      doc = Document
+        { _viewBox = Nothing
+        , _width = Nothing
+        , _height = Nothing
+        , _elements = [tree]
+        , _definitions = Map.empty
+        , _description = ""
+        , _styleRules = []
+        , _documentLocation = ""
+        }
+
 {-# NOINLINE cache #-}
-cache :: IORef (Map String (Svg ()))
+cache :: IORef (Map String Tree)
 cache = unsafePerformIO (newIORef Map.empty)
 
-latex :: String -> Svg ()
+latex :: String -> Tree
 latex tex = unsafePerformIO $ do
   store <- readIORef cache
   case Map.lookup tex store of
@@ -43,8 +58,11 @@ latex tex = unsafePerformIO $ do
       svg <- latexToSVG tex
       atomicModifyIORef cache (\store -> (Map.insert tex svg store, svg))
 
+latexAlign :: String -> Tree
+latexAlign tex = latex $ unlines ["\\begin{align*}", tex, "\\end{align*}"]
 
-latexToSVG :: String -> IO (Svg ())
+
+latexToSVG :: String -> IO Tree
 latexToSVG tex = handle (\(e::SomeException) -> return (failedSvg tex)) $ do
   latex <- requireExecutable "latex"
   dvisvgm <- requireExecutable "dvisvgm"
@@ -62,12 +80,12 @@ latexToSVG tex = handle (\(e::SomeException) -> return (failedSvg tex)) $ do
     svg_data <- B.readFile svg_file
     case parseSvgFile svg_file svg_data of
       Nothing -> error "Malformed svg"
-      Just svg -> return $ toHtmlRaw $ unbox $ replaceUses svg
+      Just svg -> return $ unbox $ replaceUses svg
 
-failedSvg :: String -> Svg ()
-failedSvg tex =
-  text_ [ font_size_ "20"
-        , fill_ "white"] (toHtml $ "bad latex: "++tex)
+failedSvg :: String -> Tree
+failedSvg tex = defaultSvg
+  -- text_ [ font_size_ "20"
+  --       , fill_ "white"] (toHtml $ "bad latex: "++tex)
 
 tex_prologue =
   "\\documentclass[preview]{standalone}\n\
@@ -90,10 +108,8 @@ tex_prologue =
   \\\DisableLigatures{encoding = *, family = * }\n\
   \%\\usepackage[UTF8]{ctex}\n\
   \\\linespread{1}\n\
-  \\\begin{document}\n\
-  \\\begin{align*}\n"
+  \\\begin{document}\n"
 
 tex_epilogue =
   "\n\
-  \\\end{align*}\n\
   \\\end{document}"

src/Reanimate/Svg.hs

@@ -1,9 +1,17 @@
 module Reanimate.Svg where
 
-import Data.Maybe
-import qualified Data.Map as Map
-import Control.Lens (over, (^.),set, (.~), (&), (%~) )
-import Graphics.Svg
+import           Control.Lens               (over, set, (%~), (&), (.~), (^.))
+import           Control.Monad.State
+import           Control.Monad.Fix
+import qualified Data.Map                   as Map
+import           Data.Maybe
+import           Data.List
+import           Graphics.Svg
+import           Linear.Metric
+import           Linear.V2
+import           Linear.Vector
+
+import           Debug.Trace
 
 replaceUses :: Document -> Document
 replaceUses doc = doc & elements %~ map (mapTree replace)
@@ -28,10 +36,10 @@ replaceUses doc = doc & elements %~ map (mapTree replace)
             Map.mapMaybe elementToTree (doc^.definitions)
     updMap m tree =
       case tree^.drawAttr.attrId of
-        Nothing -> m
+        Nothing  -> m
         Just tid -> Map.insert tid tree m
     elementToTree (ElementGeometry t) = Just t
-    elementToTree _ = Nothing
+    elementToTree _                   = Nothing
 
 docIds :: Document -> [String]
 docIds doc = Map.keys idMap ++ Map.keys (doc^.definitions)
@@ -40,18 +48,224 @@ docIds doc = Map.keys idMap ++ Map.keys (doc^.definitions)
     idMap = foldTree updMap Map.empty docTree
     updMap m tree =
       case tree^.drawAttr.attrId of
-        Nothing -> m
+        Nothing  -> m
         Just tid -> Map.insert tid tree m
 
 
 -- Transform out viewbox. defs and CSS rules are discarded.
-unbox :: Document -> Document
+unbox :: Document -> Tree
 unbox doc@Document{_viewBox = Just (minx, minw, _width, _height)} =
-  doc & viewBox .~ Nothing
-      & width .~ Nothing
-      & height .~ Nothing
-      & elements .~
-        [ GroupTree $ defaultSvg
+  GroupTree $ defaultSvg
           & groupChildren .~ doc^.elements
-          & drawAttr .~ (defaultSvg & transform .~ Just [Translate (-minx) (-minw)]) ]
-unbox doc = doc
+          & drawAttr .~ (defaultSvg & transform .~ Just [Translate (-minx) (-minw)])
+unbox doc =
+  GroupTree $ defaultSvg
+    & groupChildren .~ doc^.elements
+
+type CmdM a = State RPoint a
+
+data LineCommand
+  = LineMove RPoint
+  | LineDraw RPoint
+  | LineBezier [RPoint]
+  deriving (Show)
+
+lineToPath :: [LineCommand] -> [PathCommand]
+lineToPath = map worker
+  where
+    worker (LineMove p) = MoveTo OriginAbsolute [p]
+    worker (LineDraw p) = LineTo OriginAbsolute [p]
+    worker (LineBezier [a,b,c]) = CurveTo OriginAbsolute [(a,b,c)]
+    worker (LineBezier [a,b]) = QuadraticBezier OriginAbsolute [(a,b)]
+
+partialLine :: Double -> [LineCommand] -> [LineCommand]
+partialLine alpha cmds = evalState (worker 0 cmds) zero
+  where
+    worker d [] = pure []
+    worker d (cmd:xs) = do
+      from <- get
+      len <- lineLength cmd
+      let frac = (targetLen-d) / len
+      if len == 0 || frac > 1
+        then (cmd:) <$> worker (d+len) xs
+        else pure [adjustLineLength frac from cmd]
+    totalLen = evalState (sum <$> mapM lineLength cmds) zero
+    targetLen = totalLen * alpha
+
+adjustLineLength :: Double -> RPoint -> LineCommand -> LineCommand
+adjustLineLength alpha from cmd =
+  case cmd of
+    LineBezier points -> LineBezier $ drop 1 $ partial_bezier_points (from:points) 0 alpha
+    LineMove p -> LineMove p
+    LineDraw t -> LineDraw (lerp alpha t from)
+
+lineLength :: LineCommand -> CmdM Double
+lineLength cmd =
+      case cmd of
+        LineMove to       -> pure 0 <* put to
+        LineDraw to       -> gets (distance to) <* put to
+        LineBezier points -> gets (distance (last points)) <* put (last points)
+
+toLineCommands :: [PathCommand] -> [LineCommand]
+toLineCommands ps = evalState (worker zero Nothing ps) zero
+  where
+    worker startPos mbPrevControlPt [] = pure []
+    worker startPos mbPrevControlPt (cmd:cmds) = do
+      lcmds <- toLineCommand startPos mbPrevControlPt cmd
+      let startPos' =
+            case lcmds of
+              [LineMove pos] -> pos
+              _              -> startPos
+      (lcmds++) <$> worker startPos' (cmdToControlPoint $ last lcmds) cmds
+
+cmdToControlPoint (LineBezier points) = Just (last (init points))
+cmdToControlPoint _ = Nothing
+
+toLineCommand :: RPoint -> Maybe RPoint -> PathCommand -> CmdM [LineCommand]
+toLineCommand startPos mbPrevControlPt cmd = do
+  case cmd of
+    MoveTo OriginAbsolute []  -> pure []
+    MoveTo OriginAbsolute lst -> put (last lst) *> gets (pure.LineMove)
+    MoveTo OriginRelative lst -> modify (+ sum lst) *> gets (pure.LineMove)
+    LineTo OriginAbsolute lst -> forM lst (\to -> put to *> pure (LineDraw to))
+    LineTo OriginRelative lst -> forM lst (\to -> modify (+to) *> gets LineDraw)
+    HorizontalTo OriginAbsolute lst ->
+      forM lst $ \x -> modify (_x .~ x) *> gets LineDraw
+    HorizontalTo OriginRelative lst ->
+      forM lst $ \x -> modify (_x %~ (+x)) *> gets LineDraw
+    VerticalTo OriginAbsolute lst ->
+      forM lst $ \y -> modify (_y .~ y) *> gets LineDraw
+    VerticalTo OriginRelative lst ->
+      forM lst $ \y -> modify (_y %~ (+y)) *> gets LineDraw
+    CurveTo OriginAbsolute quads -> do
+      forM quads $ \(a,b,c) -> put c *> pure (LineBezier [a,b,c])
+    CurveTo OriginRelative quads -> do
+      forM quads $ \(a,b,c) -> do
+        from <- get <* modify (+c)
+        pure $ LineBezier $ map (+from) [a,b,c]
+    SmoothCurveTo o lst -> mfix $ \result -> do
+      let ctrl = mbPrevControlPt : map cmdToControlPoint result
+      forM (zip lst ctrl) $ \((c2,to), mbControl) -> do
+        from <- get <* adjustPosition o to
+        let c1 = maybe (makeAbsolute o from c2) (mirrorPoint from) mbControl
+        pure $ LineBezier [c1,makeAbsolute o from c2,makeAbsolute o from to]
+    QuadraticBezier OriginAbsolute pairs -> do
+      forM pairs $ \(a,b) -> put b *> pure (LineBezier [a,b])
+    QuadraticBezier OriginRelative pairs -> do
+      forM pairs $ \(a,b) -> do
+        from <- get <* modify (+b)
+        pure $ LineBezier $ map (+from) [a,b]
+    SmoothQuadraticBezierCurveTo o lst -> mfix $ \result -> do
+      let ctrl = mbPrevControlPt : map cmdToControlPoint result
+      forM (zip lst ctrl) $ \(to, mbControl) -> do
+        from <- get <* adjustPosition o to
+        let c1 = maybe from (mirrorPoint from) mbControl
+        pure $ LineBezier [c1,makeAbsolute o from to]
+    EllipticalArc origin points -> undefined
+    EndPath -> put startPos *> pure [LineDraw startPos]
+  where
+    mirrorPoint c p = c*2-p
+    adjustPosition OriginRelative p = modify (+p)
+    adjustPosition OriginAbsolute p = put p
+    makeAbsolute OriginAbsolute from p = p
+    makeAbsolute OriginRelative from p = from+p
+
+
+-- Algorithm taken from manim. It's magic.
+bezier :: [RPoint] -> Double -> RPoint
+bezier points t = sum
+    [ point ^* (((1-t)**(fromIntegral $ n-k)) * (t**fromIntegral k) * fromIntegral (choose n k))
+    | (k, point) <- zip [0..] points ]
+  where
+    n = length points -1
+    choose n k = product [n,n-1 .. n-k+1] `div` product [1..k]
+partial_bezier_points points a b
+  | isNaN end_prop || isInfinite end_prop = replicate (length points) (last points)
+  | otherwise = [ bezier (take (i+1) a_to_1) end_prop | i <- [0..length points-1] ]
+  where
+    a_to_1 = [ bezier (drop i points) a | i <- [0..length points-1] ]
+    end_prop = (b-a) / (1-a)
+
+
+
+interpolatePathCommands :: Double -> [PathCommand] -> [PathCommand]
+interpolatePathCommands alpha = lineToPath . partialLine alpha . toLineCommands
+--     evalState (worker 0 cmds) zero
+--   where
+--     worker d [] = pure []
+--     worker d (x:xs) | d > minDistance = pure []
+--     worker d (LineTo OriginAbsolute []:xs) = worker d xs
+--     worker d (LineTo OriginAbsolute (to:tos):xs) = do
+--       from <- get <* put to
+--       let d' = distance from to
+--           out = LineTo OriginAbsolute [lerp (min 1 ((minDistance-d)/d')) to from]
+--           rest = LineTo OriginAbsolute tos
+--       (out:) <$> worker (d+d') (rest:xs)
+--     worker d (LineTo OriginRelative []:xs) = worker d xs
+--     worker d (LineTo OriginRelative (to:tos):xs) = do
+--       from <- get <* modify (+to)
+--       let d' = distance zero to
+--           out = LineTo OriginRelative [lerp (min 1 ((minDistance-d)/d')) to zero]
+--           rest = LineTo OriginRelative tos
+--       (out:) <$> worker (d+d') (rest:xs)
+--     worker d (x:xs) = do
+--       d' <- estimateCmdLength x
+--       (x:) <$> worker (d+d') xs
+--     minDistance = estimatePathLength cmds * alpha
+--
+-- splitPathCommands :: [PathCommand] -> [PathCommand]
+-- splitPathCommands cmds = evalState (concat <$> mapM splitPathCommand cmds) zero
+--
+-- splitPathCommand :: PathCommand -> CmdM [PathCommand]
+-- splitPathCommand cmd = do
+--   case cmd of
+--     MoveTo OriginAbsolute [] -> pure [cmd]
+--     MoveTo OriginAbsolute lst -> put (last lst) *> pure [cmd]
+--     MoveTo OriginRelative lst -> modify (+ sum lst) *> pure [cmd]
+--     -- LineTo OriginAbsolute lst -> do
+--     --   concat <$> forM lst (\to -> do
+--     --     from <- get <* put (to :: RPoint)
+--     --     let towardsTo = (to - from) / fromIntegral pieces :: RPoint
+--     --     return $ replicate pieces (LineTo OriginRelative [towardsTo]))
+--     -- LineTo OriginRelative lst -> do
+--     --   concat <$> forM lst (\to -> do
+--     --     from <- get <* modify (+to)
+--     --     let towardsTo = to / fromIntegral pieces :: RPoint
+--     --     return $ replicate pieces (LineTo OriginRelative [towardsTo]))
+--     _ -> pure [cmd]
+--   where
+--     pieces = 100 :: Int
+--
+-- estimatePathLength :: [PathCommand] -> Double
+-- estimatePathLength cmds = evalState (sum <$> mapM estimateCmdLength cmds) zero
+--
+-- estimateCmdLength :: PathCommand -> CmdM Double
+-- estimateCmdLength cmd =
+--   case cmd of
+--     MoveTo OriginAbsolute []  -> pure 0
+--     MoveTo OriginAbsolute lst -> put (last lst) *> pure 0
+--     MoveTo OriginRelative lst -> modify (+ sum lst) *> pure 0
+--     LineTo OriginAbsolute lst ->
+--       sum <$> forM lst (\to -> gets (distance to) <* put to)
+--     LineTo OriginRelative lst ->
+--       sum <$> forM lst (\to -> modify (+to) *> pure (distance zero to))
+--     HorizontalTo OriginAbsolute lst -> undefined
+--     HorizontalTo OriginRelative lst -> undefined
+--     VerticalTo OriginAbsolute lst -> undefined
+--     VerticalTo OriginRelative lst -> undefined
+--     CurveTo origin quads -> undefined
+--     SmoothCurveTo origin lst -> undefined
+--     QuadraticBezier origin pairs -> undefined
+--     SmoothQuadraticBezierCurveTo origin points -> undefined
+--     EllipticalArc origin points -> undefined
+--     EndPath -> pure 0
+
+-- lineToPath :: [LineCommand] -> [PathCommand]
+-- partialLine :: Double -> [LineCommand] -> [LineCommand]
+
+partialSvg :: Double -> Tree -> Tree
+partialSvg alpha = mapTree worker
+  where
+    worker (PathTree path) =
+      PathTree $ path & pathDefinition %~ lineToPath . partialLine alpha . toLineCommands
+    worker t = t