reanimate 0.1.4.1 → 0.1.5.0

raw patch · 8 files changed

+539/−41 lines, 8 filesdep +open-browserdep −unixPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: open-browser

Dependencies removed: unix

API changes (from Hackage documentation)

Files

• ChangeLog.md +7/−0
• reanimate.cabal +4/−3
• src/Reanimate/Driver.hs +14/−17
• src/Reanimate/Misc.hs +2/−2
• src/Reanimate/Monad.hs +4/−1
• src/Reanimate/Morph.hs +384/−0
• src/Reanimate/Render.hs +3/−1
• src/Reanimate/Svg.hs +121/−17

@@ -1,5 +1,12 @@ # Revision history for reani +## 0.1.5.0 -- 2019-07-07++* Basic driver for live previewing and rendering.+* Basic tools for manipulating SVGs (pathification, simplification, lowering+  transformations, etc).+* Automated CI builds (azure).+ ## 0.1.0.0 -- YYYY-mm-dd  * First version. Released on an unsuspecting world.

@@ -2,7 +2,7 @@ --  see http://haskell.org/cabal/users-guide/  name:                reanimate-version:             0.1.4.1+version:             0.1.5.0 -- synopsis: -- description: license:             PublicDomain@@ -46,16 +46,17 @@                       Reanimate.Transform                       Reanimate.Driver                       Reanimate.Misc+                      Reanimate.Morph   other-modules:      Reanimate.Svg.NamedColors                       Reanimate.Cache                       Paths_reanimate   build-depends:       base >=4.10 && <4.13,-                       time, text, unix, filepath, process, directory,+                       time, text, filepath, process, directory,                        containers, reanimate-svg >= 0.7.0.0, xml, bytestring, lens, linear, mtl, matrix,                        JuicyPixels, attoparsec, parallel, diagrams, diagrams-svg,                        diagrams-core, diagrams-lib, diagrams-contrib,                        svg-builder, matrices, cubicbezier, palette, websockets,-                       hashable, fsnotify+                       hashable, fsnotify, open-browser  Flag server   Description: Enable rendering server

@@ -6,7 +6,7 @@ import           Control.Monad.Fix  (fix) import qualified Data.Text          as T import           Network.WebSockets-import           System.Directory   (findExecutable, findFile, listDirectory)+import           System.Directory   (findFile, listDirectory) import           System.Environment (getArgs, getProgName) import           System.FilePath import           System.FSNotify@@ -15,10 +15,11 @@  import           Data.Maybe import           Paths_reanimate-import           Reanimate.Misc     (runCmd, runCmdLazy, runCmd_, withTempDir,+import           Reanimate.Misc     (runCmdLazy, runCmd_, withTempDir,                                      withTempFile) import           Reanimate.Monad    (Animation)-import           Reanimate.Render   (renderSvgs)+import           Reanimate.Render   (renderSvgs, render)+import           Web.Browser        (openBrowser)  opts = defaultConnectionOptions   { connectionCompressionOptions = PermessageDeflateCompression defaultPermessageDeflate }@@ -30,11 +31,17 @@   hSetBuffering stdin NoBuffering   case args of     ["once"] -> renderSvgs animation+    ["render", target] ->+      render animation target     _ -> withTempDir $ \tmpDir -> do       url <- getDataFileName "viewer/build/index.html"-      openBrowser url+      putStrLn "Opening browser..."+      bSucc <- openBrowser url+      if bSucc+          then putStrLn "Browser opened."+          else hPutStrLn stderr $ "Failed to open browser. Manually visit: " ++ url       runServerWith "127.0.0.1" 9161 opts $ \pending -> do-        putStrLn "Server pending."+        putStrLn "Server pending..."         prog <- getProgName         lst <- listDirectory "."         mbSelf <- findFile ("." : lst) prog@@ -47,7 +54,7 @@             slave <- newEmptyMVar             let handler = modifyMVar_ slave $ \tid -> do                   sendTextData conn (T.pack "Compiling")-                  putStrLn "Kill and respawn."+                  putStrLn "Killing and respawning..."                   killThread tid                   tid <- forkIO $ withTempFile ".exe" $ \tmpExecutable -> do                     ret <- runCmd_ "stack" $ ["ghc", "--"] ++ ghcOptions tmpDir ++ [self, "-o", tmpExecutable]@@ -69,7 +76,7 @@                               sendTextData conn frame                               loop (frame : acc)                   return tid-            putStrLn "Found self. Listening."+            putStrLn "Found self. Listening..."             stop <- watchFile watch self handler             putMVar slave =<< forkIO (return ())             let loop = do@@ -86,13 +93,3 @@ ghcOptions tmpDir =     ["-rtsopts", "--make", "-threaded", "-O2"] ++     ["-odir", tmpDir, "-hidir", tmpDir]--openBrowser :: String -> IO ()-openBrowser url = do-  xdgOpen <- findExecutable "xdg-open"-  open <- findExecutable "open"-  case listToMaybe (catMaybes [xdgOpen, open]) of-    Nothing ->-      hPutStrLn stderr $ "Failed to open browser. Manually visit: " ++ url-    Just prog ->-      runCmd prog [url]

@@ -73,11 +73,11 @@   hClose handle   removeFile path   createDirectory (dir </> path)-  action (dir </> path) `finally` removeDirectoryRecursive (dir </> path)+  action (dir </> path) -- `finally` removeDirectoryRecursive (dir </> path)  withTempFile :: String -> (FilePath -> IO a) -> IO a withTempFile ext action = do   dir <- getTemporaryDirectory   (path, handle) <- openTempFile dir ("reanimate-XXXXXX" <.> ext)   hClose handle-  action path `finally` removeFile path+  action path -- `finally` removeFile path

@@ -5,12 +5,14 @@ import           Control.Monad.State import           Data.Fixed import           Data.Fixed            (mod')+import Text.Printf import qualified Data.Map              as M import           Data.Monoid           ((<>)) import           Data.Text             (Text, pack) import           Graphics.SvgTree      (Document (..), Number (..), Text (..),                                         TextSpan (..), TextSpanContent (..),                                         Tree, Tree (..), xmlOfDocument, xmlOfTree)+import           Graphics.SvgTree.Printer import           Reanimate.Svg import           Text.XML.Light        (elContent) import           Text.XML.Light.Output@@ -103,7 +105,8 @@ renderTree t = maybe "" ppElement $ xmlOfTree t  renderSvg :: Maybe Number -> Maybe Number -> Tree -> String-renderSvg w h t = ppElement $ xmlOfDocument doc+renderSvg w h t = ppDocument doc+-- renderSvg w h t = ppFastElement (xmlOfDocument doc)   where     width = 320     height = width / (16/9)

@@ -0,0 +1,384 @@+{-# LANGUAGE ParallelListComp #-}+module Reanimate.Morph where++import           Control.Lens+import           Control.Monad.State+import           Linear.Metric+import           Linear.V2+import Data.List+import Data.Ord+import           Linear.Vector+import qualified Geom2D.CubicBezier          as Bezier+import           Graphics.SvgTree++import Reanimate.Svg+import Reanimate.Monad+import Reanimate.LaTeX++import Debug.Trace++{-+alignCommands :: [LineCommand] -> [LineCommand] -> ([LineCommand], [LineCommand])+alignCommands a b =+    (worker (glyphs [] a) (glyphs [] b)+    ,worker (glyphs [] b) (glyphs [] a))+  where+    glyphs acc [] = [reverse acc]+    glyphs [] (LineMove p:cs) = glyphs [LineMove p] cs+    glyphs acc (LineMove p:cs) = reverse acc : glyphs [LineMove p] cs+    glyphs acc (c:cs) = glyphs (c:acc) cs++    worker :: [[LineCommand]] -> [[LineCommand]] -> [LineCommand]+    worker [] [] = []+    worker xs [] = concat xs+    worker [] ((LineMove p:ps):xs) = LineMove p : [LineBezier [p,p,p] | _ <- ps]+    worker (x:xs) (y:ys) = align x y ++ worker xs ys++    align :: [LineCommand] -> [LineCommand] -> [LineCommand]+    align x y = addControlPoints (length y - length x) x++addControlPoints :: Int -> [LineCommand] -> [LineCommand]+addControlPoints n cmds | n <= 0 = cmds+addControlPoints n cmds = evalState (worker 0 cmds) zero+  where+    worker d [] = pure []+    worker d (cmd:xs) = do+      from <- get+      len <- lineLength cmd+      if d+len > pointDistance+        then do+          put from+          let newLen = pointDistance-d+              (cmdBefore, cmdAfter) = splitLineLength (newLen / len) from cmd+          _ <- lineLength cmdBefore+          (cmdBefore:) <$> worker 0 (cmdAfter : xs)+        else (cmd:) <$> worker (d+len) xs+    totalLen = evalState (sum <$> mapM lineLength cmds) zero+    pointDistance = totalLen / fromIntegral (n+1)++splitLineLength :: Double -> RPoint -> LineCommand -> (LineCommand, LineCommand)+splitLineLength alpha from cmd =+  case cmd of+    LineBezier points ->+      (LineBezier $ drop 1 $ partial_bezier_points (from:points) 0 alpha+      ,LineBezier $ drop 1 $ partial_bezier_points (from:points) alpha 1)+    LineMove p -> (LineMove p, LineMove p)+    LineEnd -> (LineEnd, LineEnd)+-}+interpolateLineCommands :: Double -> [LineCommand] -> [LineCommand] -> [LineCommand]+interpolateLineCommands alpha x y = map worker (zip x y)+  where+    worker (LineMove p1, LineMove p2) = LineMove (lerp alpha p1 p2)+    worker (LineBezier ps1, LineBezier ps2) =+      LineBezier [lerp alpha x y | (x,y) <- merge ps1 ps2]+    worker (LineEnd, LineEnd) = LineEnd+    worker (x,y) = error (show (x,y))+    merge [] [] = []+    merge [x] [y] = [(x,y)]+    merge (x:xs) [y] = (x,y) : merge xs [y]+    merge [x] (y:ys) = (x,y) : merge [x] ys+    merge (x:xs) (y:ys) = (x,y) : merge xs ys+++boxCommands :: [LineCommand]+boxCommands = toLineCommands $ extractPath $ center $ mkPathString+  "M10,5 v-5 h-10 v10 h10 z M5,8 h-3 v-6 h6 v6 z"++squareCommands :: [LineCommand]+squareCommands = toLineCommands $ extractPath $ center $ scale 4 $ mkPathString+  "M10,5 v-5 h-10 v10 h10 z"++oCommands :: [LineCommand]+oCommands = toLineCommands $ extractPath $ center $ scale 10 $ mkPathString+  "M4.692403,-2.132005 C4.692403,-3.407223 3.696139,-4.463263 2.49066,-4.463263 C1.24533,-4.463263 0.278954,-3.377335 0.278954,-2.132005 C0.278954,-0.846824 1.315068,0.109589 2.480697,0.109589 C3.686177,0.109589 4.692403,-0.86675 4.692403,-2.132005 L4.692403,-2.132005 z\+  \M2.49066,-0.139477 C2.062267,-0.139477 1.62391,-0.348692 1.354919,-0.806974 C1.105853,-1.24533 1.105853,-1.853051 1.105853,-2.211706 C1.105853,-2.600249 1.105853,-3.138232 1.344956,-3.576588 C1.613948,-4.034869 2.082192,-4.244085 2.480697,-4.244085 C2.919054,-4.244085 3.347447,-4.024907 3.606476,-3.596513 S3.865504,-2.590286 3.865504,-2.211706 C3.865504,-1.853051 3.865504,-1.315068 3.646326,-0.876712 C3.427148,-0.428394 2.988792,-0.139477 2.49066,-0.139477 L2.49066,-0.139477 z"++innerOCommands :: [LineCommand]+innerOCommands = toLineCommands $ extractPath $ center $ scale 10 $ mkPathString+  "M2.49066,-0.139477 C2.062267,-0.139477 1.62391,-0.348692 1.354919,-0.806974 C1.105853,-1.24533 1.105853,-1.853051 1.105853,-2.211706 C1.105853,-2.600249 1.105853,-3.138232 1.344956,-3.576588 C1.613948,-4.034869 2.082192,-4.244085 2.480697,-4.244085 C2.919054,-4.244085 3.347447,-4.024907 3.606476,-3.596513 S3.865504,-2.590286 3.865504,-2.211706 C3.865504,-1.853051 3.865504,-1.315068 3.646326,-0.876712 C3.427148,-0.428394 2.988792,-0.139477 2.49066,-0.139477 L2.49066,-0.139477 z"++{-+A figure consists of a set of objects.+Each object is either a string or a loop.+Each object has a non-negative integer rank.++Strings can be reversed.+Loops can be reversed and shifted left/right.+-}++-- Invariant: End point is the same as starting point+data Loop = Loop RPoint [[RPoint]]+  deriving (Show, Eq)++loopStart :: Loop -> RPoint+loopStart (Loop start _) = start++shiftRight :: Loop -> Loop+shiftRight (Loop start (x:xs)) = Loop (last x) (xs ++ [x])++reverseLoop :: Loop -> Loop+reverseLoop (Loop start ps) = Loop start (drop 1 $ worker [] (reverse $ map reverse ps))+  where+    worker rest [s:cs] = (rest++[s]) : [cs ++ [start]]+    worker rest ((s:cs):xs) = (rest ++ [s]) : worker cs xs++loopToCommands :: Loop -> [LineCommand]+loopToCommands (Loop start curves) =+  LineMove start :+  [ LineBezier bs | bs <- curves ] +++  [LineEnd]++commandsToLoops :: [LineCommand] -> [Loop]+commandsToLoops (LineMove start : xs) = map simplifyLoop $ worker start [] xs+  where+    worker start acc [] = [Loop start (reverse acc)]+    worker start acc (LineMove newStart : xs) =+      Loop start (reverse acc) : worker newStart [] xs+    worker start acc (LineBezier cs : xs) =+      worker start (cs:acc) xs+    worker start acc (LineEnd : xs) =+      worker start acc xs++simplifyLoop :: Loop -> Loop+simplifyLoop (Loop start cs) = Loop start (worker start cs)+  where+    worker from ([x]:xs)+      | from == x = worker from xs+    worker from (curves:cs) =+      curves : worker (last curves) cs+    worker from [] = []++loopLength :: Loop -> Double+loopLength (Loop start curves) = worker start curves+  where+    worker :: RPoint -> [[RPoint]] -> Double+    worker from [] = 0+    worker from (bezier:cs) =+      Bezier.arcLength (mkBezier from bezier) 1 tolerance + worker (last bezier) cs++    tolerance = 0.1++mkBezier :: RPoint -> [RPoint] -> Bezier.CubicBezier Double+mkBezier a cs = case cs of+    [b]   -> Bezier.CubicBezier (mkPoint a) (mkPoint b) (mkPoint b) (mkPoint b)+    [b,c] -> Bezier.quadToCubic (Bezier.QuadBezier (mkPoint a) (mkPoint b) (mkPoint c))+    [b,c,d]   -> Bezier.CubicBezier (mkPoint a) (mkPoint b) (mkPoint c) (mkPoint d)+  where+    mkPoint (V2 a1 a2) = Bezier.Point a1 a2++fromBezier :: Bezier.CubicBezier Double -> [RPoint]+fromBezier (Bezier.CubicBezier _ b c d) =+    [fromPoint b,fromPoint c,fromPoint d]+  where+    fromPoint (Bezier.Point x y) = V2 x y++loopCtrlPoints :: Loop -> [Double]+loopCtrlPoints (Loop start curves) = worker start 0 curves+  where+    worker from d [] = []+    worker from d (bezier:cs) =+      let d' = d + Bezier.arcLength (mkBezier from bezier) 1 0.1 in+      d' / totalLen : worker (last bezier) d' cs+    totalLen = loopLength (Loop start curves)++addCtrlPoints :: Loop -> [Double] -> Loop+addCtrlPoints (Loop start cs) ctrlPoints = Loop start (worker start 0 cs ctrlPoints)+  where+    totalLen = loopLength (Loop start cs)+    worker from d [] _ = []+    worker from d cs [] = cs+    worker from d (curves:cs) (p:ps) =+      let bezier = mkBezier from curves+          len = Bezier.arcLength bezier 1 0.1 in+      if d+len > p*totalLen+        then+          let newLen = p*totalLen - d+              param = Bezier.arcLengthParam bezier newLen 0.1+              (before,after) = Bezier.splitBezier bezier param+              beforeLst = fromBezier before+          in beforeLst : worker (last beforeLst) (d+newLen) (fromBezier after : cs) ps+        else curves: worker (last curves) (d+len) cs (p:ps)++setLoopStart :: Loop -> Double -> Loop+setLoopStart loop newStart =+    worker (loopCtrlPoints loop') loop'+  where+    loop' = addCtrlPoints loop [newStart]+    worker [] l = l+    worker (x:xs) l+      | x < newStart = worker xs (shiftRight l)+      | otherwise = l+++closestPoint :: Loop -> RPoint -> (RPoint, Double)+closestPoint (Loop start cs) p = worker start 0 0 start cs+  where+    pPoint = mkPoint p+    mkPoint (V2 a1 a2) = Bezier.Point a1 a2+    fromPoint (Bezier.Point x y) = V2 x y+    worker :: RPoint -> Double -> Double -> RPoint -> [[RPoint]] -> (RPoint, Double)+    worker point at pos _ [] = (point, at / loopLength (Loop start cs))+    worker point at pos from (curves:cs) =+      let bezier = mkBezier from curves+          c = Bezier.closest bezier pPoint 0.1+          len = Bezier.arcLength bezier c 0.1+          totalLen = Bezier.arcLength bezier 1 0.1+          newPoint = fromPoint $ Bezier.evalBezier bezier c+      in if distance newPoint p < distance point p+        then worker newPoint (pos+len) (pos+totalLen) (last curves) cs+        else worker point at (pos+totalLen) (last curves) cs++loopDistance :: Loop -> Loop -> Double+loopDistance (Loop s1 c1) (Loop s2 c2) =+    distance s1 s2 + worker c1 c2+  where+    worker [] [] = 0+    worker (c1:cs1) (c2:cs2) =+      distance (last c1) (last c2) ++      worker cs1 cs2+    worker _ _ = error $ "Bad lengths: " ++ show (length c1, length c2)++loopBestAlign :: Loop -> Loop -> (Loop, Loop)+loopBestAlign orig foreign_ =+    if loopDistance orig' foreign'' < loopDistance origRev foreignRev+      then (orig', foreign'')+      else (origRev, foreignRev)+  where+    loopStart (Loop s _) = s+    (_, newStartDist) = closestPoint foreign_ (loopStart orig)+    foreign' = setLoopStart foreign_ newStartDist+    foreign'' = addCtrlPoints foreign' (init $ loopCtrlPoints orig)+    foreignRev = addCtrlPoints (reverseLoop foreign') (init $ loopCtrlPoints orig)+    orig' = addCtrlPoints orig (init $ loopCtrlPoints foreign')+    origRev = addCtrlPoints orig (init $ loopCtrlPoints (reverseLoop foreign'))++loopContains :: Loop -> Loop -> Bool+loopContains a (Loop b _) =+  odd (length $ loopIntersections a b)++loopIntersections_ :: Loop -> Loop -> [RPoint]+loopIntersections_ l1 (Loop start _) = loopIntersections l1 start++loopIntersections :: Loop -> RPoint -> [RPoint]+loopIntersections (Loop start cs) point = worker start cs+  where+    V2 pointX pointY = point+    mkPoint (V2 a1 a2) = Bezier.Point a1 a2+    fromPoint (Bezier.Point x y) = V2 x y+    farPoint = (Bezier.Point 1000 pointY) -- FIXME+    -- line = Bezier.Line (mkPoint point) farPoint+    lineBezier = Bezier.CubicBezier (mkPoint point) farPoint farPoint farPoint+    worker from [] = []+    worker from (curves : cs) =+      let bezier = mkBezier from curves+          -- inter = Bezier.bezierLineIntersections bezier line 0+          inter = map fst $ Bezier.bezierIntersection bezier lineBezier 0.00001+          pts = [ V2 x y | V2 x y <- map (fromPoint . Bezier.evalBezier bezier) inter ]+      in pts ++ worker (last curves) cs++data LoopTree = LoopBranch Loop LoopForest+  deriving (Show, Eq)+type LoopForest = [LoopTree]++singleton :: Loop -> LoopTree+singleton l = LoopBranch l []++insertTree :: LoopForest -> Loop -> LoopForest+insertTree [] l = [singleton l]+insertTree (LoopBranch b sub:xs) l+  | loopContains b l = LoopBranch b (insertTree sub l) : xs+  | loopContains l b = LoopBranch l [singleton b] : xs+  | otherwise        = LoopBranch b sub : insertTree xs l++forestFromList :: [Loop] -> LoopForest+forestFromList = foldl insertTree []++zeroLoop :: Loop -> Loop+zeroLoop (Loop start cs) = Loop start (map worker cs)+  where+    worker _bezier = [start]++zeroLoopAt :: Loop -> Maybe RPoint -> Loop+zeroLoopAt (Loop start cs) Nothing = Loop center (map (const [center]) cs)+  where+    center = loopCenter (Loop start cs)+zeroLoopAt (Loop _ cs) (Just start) = Loop start (map (const [start]) cs)++pairLoopForests :: LoopForest -> LoopForest -> [(Loop, Loop)]+pairLoopForests [] [] = []+pairLoopForests [] (LoopBranch b bSub:bs) =+    (zeroLoop b, b) : pairLoopForests [] bSub ++ pairLoopForests [] bs+pairLoopForests (LoopBranch a aSub:as) [] =+    (a, zeroLoop a) : pairLoopForests aSub [] ++ pairLoopForests as []+pairLoopForests (LoopBranch self selfSub:xs) bs =+    let (a, b, sub, rest) = findMatch self bs+    in (a,b) : pairLoopForests selfSub sub ++ pairLoopForests xs rest+  where+    findMatch :: Loop -> LoopForest -> (Loop, Loop, LoopForest, LoopForest)+    findMatch self (t@(LoopBranch l lSub) : xs) =+        let (a,b) = loopBestAlign self l+        in worker a b lSub (delete t bs) xs+      where+        worker a b lSub rest [] = (a,b,lSub, rest)+        worker a b lSub rest (t@(LoopBranch l lSub'): xs) =+          let (a', b') = loopBestAlign self l in+          if loopDistance a b < loopDistance a' b'+            then worker a b lSub rest xs+            else worker a' b' lSub' (delete t bs) xs++-- Assume loops are polygons+loopCenter :: Loop -> RPoint+loopCenter (Loop start cs) = V2 cx cy -- start --FIXME+  where+    pts = start : map last cs+    cx = sum [ (x1+x2)*(x1*y2 - x2*y1) | (V2 x1 y1,V2 x2 y2) <- zip pts (tail pts) ] /+          (6 * area)+    cy = sum [ (y1+y2)*(x1*y2 - x2*y1) | (V2 x1 y1,V2 x2 y2) <- zip pts (tail pts) ] /+          (6 * area)+    area = sum [ x1*y2 - x2*y1 | (V2 x1 y1,V2 x2 y2) <- zip pts (tail pts) ] / 2++permPair :: LoopForest -> LoopForest -> [(Loop,Loop)]+permPair a b =+    minimumBy (comparing loopDistances) $+    simplePair Nothing Nothing <$> permutations a <*> permutations b+  where+    loopDistances ls = sum [ loopDistance a b | (a,b) <- ls ]+    simplePair :: Maybe RPoint -> Maybe RPoint -> LoopForest -> LoopForest -> [(Loop,Loop)]+    simplePair srcCenter dstCenter a b =+      case (a,b) of+        ([],[]) -> []+        (LoopBranch x xSub:xs,[]) ->+          (x,zeroLoopAt x dstCenter) :+            simplePair srcCenter dstCenter xSub [] +++            simplePair srcCenter dstCenter xs []+        ([], LoopBranch x xSub:xs) ->+          (zeroLoopAt x srcCenter,x) :+            simplePair srcCenter dstCenter [] xSub +++            simplePair srcCenter dstCenter [] xs+        (LoopBranch al aSub:as, LoopBranch bl bSub:bs) ->+          let (aBest, bBest) = loopBestAlign al bl+              srcCenter' = Just $ loopCenter aBest+              dstCenter' = Just $ loopCenter bBest+          in+          (aBest, bBest) : simplePair srcCenter' dstCenter' aSub bSub +++                           simplePair srcCenter dstCenter as bs++morph :: Tree -> Tree -> (Double -> Tree)+morph a b =+  let aF = forestFromList $ commandsToLoops $ toLineCommands $ extractPath a+      bF = forestFromList $ commandsToLoops $ toLineCommands $ extractPath b+      -- (aLoops, bLoops) = unzip $ pairLoopForests aF bF+      (aLoops, bLoops) = unzip $ permPair aF bF+      aCmds = concatMap loopToCommands aLoops+      bCmds = concatMap loopToCommands bLoops+  in \d -> PathTree $ defaultSvg & pathDefinition .~ lineToPath (interpolateLineCommands (1-d) aCmds bCmds)++annotatePath :: Tree -> Tree+annotatePath = mkGroup . reverse . map worker . toLineCommands . extractPath+  where+    mkCircle (V2 x y) = CircleTree $ defaultSvg+      & circleCenter .~ (Num x, Num y)+      & circleRadius .~ Num 1+    worker (LineMove p) = withFillColor "green" $ mkCircle p+    worker (LineBezier cs) = withFillColor "red" $ mkCircle (last cs)+    worker LineEnd = mkGroup []

@@ -16,6 +16,7 @@ import           System.Directory            (renameFile) import           System.FilePath             (takeExtension, takeFileName,                                               (</>))+import           System.IO import           Text.Printf                 (printf)  renderSvgs :: Animation ->  IO ()@@ -52,7 +53,7 @@ renderFormat format ani target = do   putStrLn $ "Starting render of animation: " ++ show (round (duration ani)) ++ "s"   ffmpeg <- requireExecutable "ffmpeg"-  generateFrames ani 640 fps $ \template ->+  generateFrames ani 2560 fps $ \template ->     withTempFile "txt" $ \progress -> writeFile progress "" >>     case format of       RenderMp4 ->@@ -93,6 +94,7 @@     forM_ (zip [0::Int ..] rendered) $ \(n, frame) -> do       writeFile (frameName n) frame       putStr $ "\r" ++ show (n+1) ++ "/" ++ show frameCount+      hFlush stdout     putStrLn "\n"     action (tmp </> nameTemplate)   where

@@ -30,6 +30,10 @@ replaceUses doc = doc & elements %~ map (mapTree replace)                       & definitions .~ Map.empty   where+    replaceDefinition PathTree{} = None+    replaceDefinition t = t++    replace t@DefinitionTree{} = mapTree replaceDefinition t     replace (UseTree _ Just{}) = error "replaceUses: subtree in use?"     replace (UseTree use Nothing) =       case Map.lookup (use^.useName) idMap of@@ -43,15 +47,13 @@       case (toUserUnit defaultDPI x, toUserUnit defaultDPI y) of         (Num a, Num b) -> Translate a b         _              -> TransformUnknown-    docTree = GroupTree $ set groupChildren (doc^.elements) defaultSvg+    docTree = mkGroup (doc^.elements)     idMap = foldTree updMap Map.empty docTree `Map.union`             (doc^.definitions)     updMap m tree =       case tree^.attrId of         Nothing  -> m         Just tid -> Map.insert tid tree m-    elementToTree (ElementGeometry t) = Just t-    elementToTree _                   = Nothing  docIds :: Document -> [String] docIds doc = Map.keys idMap ++ Map.keys (doc^.definitions)@@ -78,18 +80,31 @@  data LineCommand   = LineMove RPoint-  | LineDraw RPoint+  -- | LineDraw RPoint   | LineBezier [RPoint]+  | LineEnd   deriving (Show)  lineToPath :: [LineCommand] -> [PathCommand] lineToPath = map worker   where     worker (LineMove p)         = MoveTo OriginAbsolute [p]-    worker (LineDraw p)         = LineTo 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)]+    worker (LineBezier [a])     = LineTo OriginAbsolute [a]+    worker LineEnd              = EndPath +lineToPoints :: Int -> [LineCommand] -> [RPoint]+lineToPoints nPoints cmds =+    map lineEnd lineSegments+  where+    lineSegments = [ partialLine (fromIntegral n/ fromIntegral nPoints) cmds | n <- [0 .. nPoints-1] ]+    totalLen = evalState (sum <$> mapM lineLength cmds) zero+    lineEnd [LineBezier bezier] = last bezier+    lineEnd (_:xs) = lineEnd xs+    lineEnd _ = error "invalid line"+ partialLine :: Double -> [LineCommand] -> [LineCommand] partialLine alpha cmds = evalState (worker 0 cmds) zero   where@@ -109,14 +124,16 @@   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)+    -- LineDraw t -> LineDraw (lerp alpha t from)+    LineEnd -> LineEnd  lineLength :: LineCommand -> CmdM Double lineLength cmd =   case cmd of     LineMove to       -> pure 0 <* put to-    LineDraw to       -> gets (distance to) <* put to+    -- LineDraw to       -> gets (distance to) <* put to     LineBezier points -> gets (distance (last points)) <* put (last points)+    LineEnd           -> pure 0  toLineCommands :: [PathCommand] -> [LineCommand] toLineCommands ps = evalState (worker zero Nothing ps) zero@@ -133,22 +150,24 @@ cmdToControlPoint (LineBezier points) = Just (last (init points)) cmdToControlPoint _                   = Nothing +mkStraightLine p = LineBezier [p]+ 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)+    LineTo OriginAbsolute lst -> forM lst (\to -> put to *> pure (mkStraightLine to))+    LineTo OriginRelative lst -> forM lst (\to -> modify (+to) *> gets mkStraightLine)     HorizontalTo OriginAbsolute lst ->-      forM lst $ \x -> modify (_x .~ x) *> gets LineDraw+      forM lst $ \x -> modify (_x .~ x) *> gets mkStraightLine     HorizontalTo OriginRelative lst ->-      forM lst $ \x -> modify (_x %~ (+x)) *> gets LineDraw+      forM lst $ \x -> modify (_x %~ (+x)) *> gets mkStraightLine     VerticalTo OriginAbsolute lst ->-      forM lst $ \y -> modify (_y .~ y) *> gets LineDraw+      forM lst $ \y -> modify (_y .~ y) *> gets mkStraightLine     VerticalTo OriginRelative lst ->-      forM lst $ \y -> modify (_y %~ (+y)) *> gets LineDraw+      forM lst $ \y -> modify (_y %~ (+y)) *> gets mkStraightLine     CurveTo OriginAbsolute quads -> do       forM quads $ \(a,b,c) -> put c *> pure (LineBezier [a,b,c])     CurveTo OriginRelative quads -> do@@ -177,7 +196,7 @@       (forM points $ \(rotX, rotY, angle, largeArc, sweepFlag, to) -> do         from <- get <* adjustPosition o to         return $ convertSvgArc from rotX rotY angle largeArc sweepFlag (makeAbsolute o from to))-    EndPath -> put startPos *> pure [LineDraw startPos]+    EndPath -> put startPos *> pure [LineBezier [startPos], LineEnd]   where     mirrorPoint c p = c*2-p     adjustPosition OriginRelative p = modify (+p)@@ -202,7 +221,7 @@     | x0 == x && y0 == y         = []     | radiusX == 0.0 && radiusY == 0.0-        = [LineDraw (V2 x y)]+        = [LineBezier [V2 x y]]     | otherwise         = calcSegments x0 y0 theta1' segments'     where@@ -310,10 +329,12 @@     worker from (x:xs) =       case x of         LineMove to     -> worker to xs-        LineDraw to     -> from:to:worker to xs+        -- LineDraw to     -> from:to:worker to xs+        -- FIXME: Use approximation from Geom2D.Bezier         LineBezier ctrl -> -- approximation           [ last (partial_bezier_points (from:ctrl) 0 (recip chunks*i)) | i <- [0..chunks]] ++           worker (last ctrl) xs+        LineEnd -> worker from xs     chunks = 10  svgBoundingPoints :: Tree -> [RPoint]@@ -335,7 +356,7 @@           (Num x, Num y) -> [V2 x y] ++             case mapTuple (fmap $ toUserUnit defaultDPI) (rect^.rectWidth, rect^.rectHeight) of               (Just (Num w), Just (Num h)) -> [V2 (x+w) (y+h)]-              _              -> []+              _                            -> []           _ -> []       TextTree{}      -> []       ImageTree{}     -> []@@ -344,6 +365,57 @@     m = Transform.mkMatrix (t^.transform)     mapTuple f = f *** f +lowerTransformations :: Tree -> Tree+lowerTransformations = worker Transform.identity+  where+    updLineCmd m cmd =+      case cmd of+        LineMove p -> LineMove $ Transform.transformPoint m p+        -- LineDraw p -> LineDraw $ Transform.transformPoint m p+        LineBezier ps -> LineBezier $ map (Transform.transformPoint m) ps+        LineEnd -> LineEnd+    updPath m = lineToPath . map (updLineCmd m) . toLineCommands+    worker m t =+      let m' = m * Transform.mkMatrix (t^.transform) in+      case t of+        PathTree path -> PathTree $+          path & pathDefinition %~ updPath m'+               & transform .~ Nothing+        GroupTree g -> GroupTree $+          g & groupChildren %~ map (worker m')+            & transform .~ Nothing+        _ -> t++lowerIds :: Tree -> Tree+lowerIds = mapTree worker+  where+    worker t@GroupTree{} = t & attrId .~ Nothing+    worker t@PathTree{} = t & attrId .~ Nothing+    worker t = t++simplify :: Tree -> Tree+simplify root =+  case worker root of+    [] -> None+    [x] -> x+    xs -> mkGroup xs+  where+    worker None = []+    worker (DefinitionTree d)+      | null (d ^. groupChildren) = []+      | otherwise = [DefinitionTree $ d & groupChildren %~ concatMap worker]+    worker (GroupTree g)+      | g ^. drawAttributes == defaultSvg = concatMap worker (g^.groupChildren)+      | otherwise = [GroupTree $ g & groupChildren %~ concatMap worker]+    worker t = [t]++extractPath :: Tree -> [PathCommand]+extractPath = worker . simplify . lowerTransformations . pathify+  where+    worker (GroupTree g) = concatMap worker (g^.groupChildren)+    worker (PathTree p) = p^.pathDefinition+    worker _ = []+ withTransformations :: [Transformation] -> Tree -> Tree withTransformations transformations t =   mkGroup [t] & transform .~ Just transformations@@ -412,6 +484,9 @@ withStrokeColor :: String -> Tree -> Tree withStrokeColor color = strokeColor .~ pure (mkColor color) +withStrokeLineJoin :: LineJoin -> Tree -> Tree+withStrokeLineJoin join = strokeLineJoin .~ pure join+ withFillColor :: String -> Tree -> Tree withFillColor color = fillColor .~ pure (mkColor color) @@ -495,6 +570,35 @@       if n `elem` target         then return $ fn t         else return t++splitGlyphs :: [Int] -> Tree -> (Tree, Tree)+splitGlyphs target = \t ->+    let (_, l, r) = execState (worker id t) (0, [], [])+    in (mkGroup l, mkGroup r)+  where+    handleGlyph :: Tree -> State (Int, [Tree], [Tree]) ()+    handleGlyph t = do+      (n, l, r) <- get+      if n `elem` target+        then put (n+1, l, t:r)+        else put (n+1, t:l, r)+    worker :: (Tree -> Tree) -> Tree -> State (Int, [Tree], [Tree]) ()+    worker acc t =+      case t of+        GroupTree g -> do+          let acc' t = acc (GroupTree $ g & groupChildren .~ [t])+          mapM_ (worker acc') (g ^. groupChildren)+        PathTree{} -> handleGlyph $ acc t+        CircleTree{} -> handleGlyph $ acc t+        PolyLineTree{} -> handleGlyph $ acc t+        PolygonTree{} -> handleGlyph $ acc t+        EllipseTree{} -> handleGlyph $ acc t+        LineTree{} -> handleGlyph $ acc t+        RectangleTree{} -> handleGlyph $ acc t+        DefinitionTree{} -> return ()+        t ->+          modify $ \(n, l, r) -> (n, acc t:l, r)+  pathify :: Tree -> Tree pathify = mapTree worker