diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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. diff --git a/reanimate.cabal b/reanimate.cabal --- a/reanimate.cabal +++ b/reanimate.cabal @@ -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 diff --git a/src/Reanimate/Driver.hs b/src/Reanimate/Driver.hs --- a/src/Reanimate/Driver.hs +++ b/src/Reanimate/Driver.hs @@ -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] diff --git a/src/Reanimate/Misc.hs b/src/Reanimate/Misc.hs --- a/src/Reanimate/Misc.hs +++ b/src/Reanimate/Misc.hs @@ -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 diff --git a/src/Reanimate/Monad.hs b/src/Reanimate/Monad.hs --- a/src/Reanimate/Monad.hs +++ b/src/Reanimate/Monad.hs @@ -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) diff --git a/src/Reanimate/Morph.hs b/src/Reanimate/Morph.hs new file mode 100644 --- /dev/null +++ b/src/Reanimate/Morph.hs @@ -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 [] diff --git a/src/Reanimate/Render.hs b/src/Reanimate/Render.hs --- a/src/Reanimate/Render.hs +++ b/src/Reanimate/Render.hs @@ -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 diff --git a/src/Reanimate/Svg.hs b/src/Reanimate/Svg.hs --- a/src/Reanimate/Svg.hs +++ b/src/Reanimate/Svg.hs @@ -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