From 1ce3a4f1a9a7631b5c8bfb0a798c7c4dd88d2734 Mon Sep 17 00:00:00 2001 From: David Himmelstrup Date: Thu, 4 Jul 2019 18:16:34 +0800 Subject: [PATCH] Random updates. --- README.md | 4 +- examples/latex_color.hs | 2 +- reanimate.cabal | 1 + src/Reanimate/Misc.hs | 4 +- src/Reanimate/Monad.hs | 5 +- src/Reanimate/Svg.hs | 173 ++++++++++++++++++++++++++++++++++++---- stack.yaml | 8 +- 7 files changed, 173 insertions(+), 24 deletions(-) diff --git a/README.md b/README.md index c41bc3f..97d1af0 100644 --- a/README.md +++ b/README.md @@ -33,7 +33,9 @@ animation source code, the browser window will automatically reload and show the * Select desired FPS in web previewer * Download rendered animations in web previewer * alignment and positioning combinators - +* Driver: + * Command line options for rendering videos. + * Flags for selecting fps in web viewer # Examples diff --git a/examples/latex_color.hs b/examples/latex_color.hs index 605ef8f..36099ca 100755 --- a/examples/latex_color.hs +++ b/examples/latex_color.hs @@ -1,5 +1,5 @@ #!/usr/bin/env stack --- stack --resolver lts-11.22 runghc --package reanimate +-- stack --resolver lts-12.26 runghc --package reanimate {-# LANGUAGE OverloadedStrings #-} module Main (main) where diff --git a/reanimate.cabal b/reanimate.cabal index 81946b3..28ce413 100644 --- a/reanimate.cabal +++ b/reanimate.cabal @@ -46,6 +46,7 @@ library Reanimate.Transform Reanimate.Driver Reanimate.Misc + Reanimate.Morph other-modules: Reanimate.Svg.NamedColors Reanimate.Cache Paths_reanimate diff --git a/src/Reanimate/Misc.hs b/src/Reanimate/Misc.hs index 6f389a3..c7ba5db 100644 --- a/src/Reanimate/Misc.hs +++ b/src/Reanimate/Misc.hs @@ -73,11 +73,11 @@ withTempDir action = do 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 index 54b1c39..49f421d 100644 --- a/src/Reanimate/Monad.hs +++ b/src/Reanimate/Monad.hs @@ -5,12 +5,14 @@ import qualified Control.Category as C 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 :: Tree -> String 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/Svg.hs b/src/Reanimate/Svg.hs index c8ba16b..f620396 100644 --- a/src/Reanimate/Svg.hs +++ b/src/Reanimate/Svg.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE LambdaCase #-} module Reanimate.Svg where import Codec.Picture (PixelRGBA8 (..)) @@ -29,6 +30,10 @@ replaceUses :: Document -> Document 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 @@ -42,15 +47,13 @@ replaceUses doc = doc & elements %~ map (mapTree replace) 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) @@ -77,17 +80,20 @@ type CmdM a = State RPoint a 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 partialLine :: Double -> [LineCommand] -> [LineCommand] partialLine alpha cmds = evalState (worker 0 cmds) zero @@ -108,14 +114,16 @@ 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) + -- 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 @@ -132,22 +140,24 @@ toLineCommands ps = evalState (worker zero Nothing ps) zero 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 @@ -176,7 +186,7 @@ toLineCommand startPos mbPrevControlPt cmd = do (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) @@ -201,7 +211,7 @@ convertSvgArc (V2 x0 y0) radiusX radiusY angle largeArcFlag sweepFlag (V2 x y) | 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 @@ -309,10 +319,12 @@ linePoints = worker zero 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] @@ -334,7 +346,7 @@ svgBoundingPoints t = map (Transform.transformPoint m) $ (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{} -> [] @@ -343,6 +355,57 @@ svgBoundingPoints t = map (Transform.transformPoint m) $ 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 @@ -494,3 +557,79 @@ withSubglyphs target fn t = evalState (worker t) 0 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 + where + worker = + \case + RectangleTree rect | Just (x,y,w,h) <- unpackRect rect -> + PathTree $ defaultSvg + & drawAttributes .~ rect ^. drawAttributes & strokeLineCap .~ pure CapSquare + & pathDefinition .~ + [MoveTo OriginAbsolute [V2 x y] + ,HorizontalTo OriginRelative [w] + ,VerticalTo OriginRelative [h] + ,HorizontalTo OriginRelative [-w] + ,EndPath ] + LineTree line | Just (x1,y1, x2, y2) <- unpackLine line -> + PathTree $ defaultSvg + & drawAttributes .~ line ^. drawAttributes + & pathDefinition .~ + [MoveTo OriginAbsolute [V2 x1 y1] + ,LineTo OriginAbsolute [V2 x2 y2] ] + CircleTree circ | Just (x, y, r) <- unpackCircle circ -> + PathTree $ defaultSvg + & drawAttributes .~ circ ^. drawAttributes + & pathDefinition .~ + [MoveTo OriginAbsolute [V2 (x-r) y] + ,EllipticalArc OriginRelative [(r, r, 0,True,False,(V2 (r*2) 0)) + ,(r, r, 0,True,False,(V2 (-r*2) 0))]] + t -> t + unpackCircle circ = do + let (x,y) = circ ^. circleCenter + liftM3 (,,) (unpackNumber x) (unpackNumber y) (unpackNumber $ circ ^. circleRadius) + unpackLine line = do + let (x1,y1) = line ^. linePoint1 + (x2,y2) = line ^. linePoint2 + liftM4 (,,,) (unpackNumber x1) (unpackNumber y1) (unpackNumber x2) (unpackNumber y2) + unpackRect rect = do + let (x', y') = rect ^. rectUpperLeftCorner + x <- unpackNumber x' + y <- unpackNumber y' + w <- unpackNumber =<< rect ^. rectWidth + h <- unpackNumber =<< rect ^. rectHeight + return (x,y,w,h) + unpackNumber n = + case toUserUnit defaultDPI n of + Num d -> Just d + _ -> Nothing diff --git a/stack.yaml b/stack.yaml index 475f9c1..96b2a48 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,9 +1,13 @@ -resolver: lts-11.22 +resolver: lts-13.14 allow-newer: false +packages: +- . + extra-deps: -- reanimate-svg-0.8.2.0 +- reanimate-svg-0.9.0.0 +- palette-0.3.0.2 - diagrams-1.4@sha256:3e36369e84115b900fd9dcb570672a188339a470eb19ca62170775cd835cf8ca - diagrams-contrib-1.4.3@sha256:bcfa6c85f8c33b8c48c3a61b7216afdebd51cd793c50da3a2dd358827d25fc76 - diagrams-core-1.4.1.1@sha256:6ef6b17785d77997c481eb085570e21b6a00cc91d086fbf49490504130ebc7d1