diff --git a/haddock.txt b/haddock.txt index 39a2f22..9029746 100644 --- a/haddock.txt +++ b/haddock.txt @@ -6,21 +6,27 @@ 100% ( 22 / 22) in 'Reanimate.Effect' 100% ( 17 / 17) in 'Reanimate.Parameters' 100% ( 14 / 14) in 'Reanimate.Raster' + 100% ( 13 / 13) in 'Reanimate.Render' 100% ( 13 / 13) in 'Reanimate.Morph.Common' 100% ( 13 / 13) in 'Reanimate.ColorMap' 100% ( 12 / 12) in 'Reanimate.ColorComponents' + 100% ( 10 / 10) in 'Reanimate.Voice' 100% ( 10 / 10) in 'Reanimate.Ease' - 100% ( 9 / 9) in 'Reanimate.Voice' 100% ( 9 / 9) in 'Reanimate.Povray' + 100% ( 9 / 9) in 'Reanimate.LaTeX' 100% ( 9 / 9) in 'Reanimate.Constants' 100% ( 8 / 8) in 'Reanimate.Transition' 100% ( 8 / 8) in 'Reanimate.Builtin.TernaryPlot' + 100% ( 7 / 7) in 'Reanimate.Svg.LineCommand' 100% ( 7 / 7) in 'Reanimate.Builtin.Documentation' 100% ( 6 / 6) in 'Reanimate.Morph.Linear' 100% ( 6 / 6) in 'Reanimate.Builtin.Images' 100% ( 5 / 5) in 'Reanimate.Transform' 100% ( 4 / 4) in 'Reanimate.Svg.Unuse' 100% ( 4 / 4) in 'Reanimate.Svg.BoundingBox' + 100% ( 4 / 4) in 'Reanimate.Morph.Rotational' + 100% ( 4 / 4) in 'Reanimate.Debug' + 100% ( 3 / 3) in 'Reanimate.Memo' 100% ( 3 / 3) in 'Reanimate.Math.Balloon' 100% ( 3 / 3) in 'Reanimate.Blender' 100% ( 2 / 2) in 'Reanimate.Builtin.CirclePlot' @@ -28,12 +34,6 @@ 89% (101 /113) in 'Reanimate.Scene' 84% ( 31 / 37) in 'Geom2D.CubicBezier.Linear' 61% ( 11 / 18) in 'Reanimate.Svg' - 56% ( 5 / 9) in 'Reanimate.LaTeX' 50% ( 2 / 4) in 'Reanimate.Builtin.Slide' - 38% ( 5 / 13) in 'Reanimate.Render' - 33% ( 1 / 3) in 'Reanimate.Morph.Rotational' - 25% ( 1 / 4) in 'Reanimate.Debug' 20% ( 1 / 5) in 'Reanimate.Builtin.Flip' 10% ( 1 / 10) in 'Reanimate.ColorSpace' - 6% ( 1 / 18) in 'Reanimate.Svg.LineCommand' - 0% ( 0 / 3) in 'Reanimate.Memo' diff --git a/haddock_badge.json b/haddock_badge.json index 7a1302c..d0298ce 100644 --- a/haddock_badge.json +++ b/haddock_badge.json @@ -1 +1 @@ - { "schemaVersion": 1, "label": "api docs", "message": "87%", "color": "success" } + { "schemaVersion": 1, "label": "api docs", "message": "94%", "color": "success" } diff --git a/hpc_index.html b/hpc_index.html index 9bed9ee..556c84d 100644 --- a/hpc_index.html +++ b/hpc_index.html @@ -107,13 +107,13 @@ table.dashboard { border-collapse: collapse ; border: solid 1px black } 38%5/13
18%15/80
41%323/777
  module reanimate-0.4.1.0-inplace/Reanimate.Svg.BoundingBox -40%2/5
16%6/36
27%76/281
+40%2/5
16%6/36
26%76/282
  module reanimate-0.4.1.0-inplace/Reanimate.Svg.Constructors 67%33/49
37%3/8
65%369/565
  module reanimate-0.4.1.0-inplace/Reanimate.Svg.LineCommand -75%12/16
58%43/74
69%659/943
+80%12/15
58%43/74
70%659/937
  module reanimate-0.4.1.0-inplace/Reanimate.Svg.Unuse 33%1/3
0%0/14
21%28/128
@@ -125,5 +125,5 @@ table.dashboard { border-collapse: collapse ; border: solid 1px black } 100%6/6
50%1/2
95%43/45
  Program Coverage Total -31%246/786
16%131/805
29%4646/15516
+31%246/785
16%131/805
29%4646/15511
diff --git a/hpc_index_alt.html b/hpc_index_alt.html index d9ae2b0..d9ca8cf 100644 --- a/hpc_index_alt.html +++ b/hpc_index_alt.html @@ -20,7 +20,7 @@ table.dashboard { border-collapse: collapse ; border: solid 1px black } 30%40/130
60%15/25
36%545/1483
  module reanimate-0.4.1.0-inplace/Reanimate.Svg.LineCommand -75%12/16
58%43/74
69%659/943
+80%12/15
58%43/74
70%659/937
  module reanimate-0.4.1.0-inplace/Reanimate.Animation 90%28/31
57%8/14
87%298/341
@@ -50,7 +50,7 @@ table.dashboard { border-collapse: collapse ; border: solid 1px black } 40%2/5
16%1/6
26%22/83
  module reanimate-0.4.1.0-inplace/Reanimate.Svg.BoundingBox -40%2/5
16%6/36
27%76/281
+40%2/5
16%6/36
26%76/282
  module reanimate-0.4.1.0-inplace/Reanimate.LaTeX 33%4/12
11%1/9
7%12/167
@@ -125,5 +125,5 @@ table.dashboard { border-collapse: collapse ; border: solid 1px black } 15%3/20
- 0/0 14%7/49
  Program Coverage Total -31%246/786
16%131/805
29%4646/15516
+31%246/785
16%131/805
29%4646/15511
diff --git a/hpc_index_exp.html b/hpc_index_exp.html index e99ad3c..22f0704 100644 --- a/hpc_index_exp.html +++ b/hpc_index_exp.html @@ -26,7 +26,7 @@ table.dashboard { border-collapse: collapse ; border: solid 1px black } 75%9/12
50%1/2
81%135/166
  module reanimate-0.4.1.0-inplace/Reanimate.Svg.LineCommand -75%12/16
58%43/74
69%659/943
+80%12/15
58%43/74
70%659/937
  module reanimate-0.4.1.0-inplace/Reanimate.Svg.Constructors 67%33/49
37%3/8
65%369/565
@@ -55,12 +55,12 @@ table.dashboard { border-collapse: collapse ; border: solid 1px black }   module reanimate-0.4.1.0-inplace/Reanimate.Builtin.Slide 33%1/3
- 0/0 30%18/60
-  module reanimate-0.4.1.0-inplace/Reanimate.Svg.BoundingBox -40%2/5
16%6/36
27%76/281
-   module reanimate-0.4.1.0-inplace/Reanimate.Morph.Linear 40%2/5
16%1/6
26%22/83
+  module reanimate-0.4.1.0-inplace/Reanimate.Svg.BoundingBox +40%2/5
16%6/36
26%76/282
+   module reanimate-0.4.1.0-inplace/Reanimate.Svg.Unuse 33%1/3
0%0/14
21%28/128
@@ -125,5 +125,5 @@ table.dashboard { border-collapse: collapse ; border: solid 1px black } 0%0/1
0%0/4
0%0/61
  Program Coverage Total -31%246/786
16%131/805
29%4646/15516
+31%246/785
16%131/805
29%4646/15511
diff --git a/hpc_index_fun.html b/hpc_index_fun.html index e1e1b8b..698e4e2 100644 --- a/hpc_index_fun.html +++ b/hpc_index_fun.html @@ -25,12 +25,12 @@ table.dashboard { border-collapse: collapse ; border: solid 1px black }   module reanimate-0.4.1.0-inplace/Reanimate.Transform 83%5/6
33%4/12
45%76/166
+  module reanimate-0.4.1.0-inplace/Reanimate.Svg.LineCommand +80%12/15
58%43/74
70%659/937
+   module reanimate-0.4.1.0-inplace/Reanimate.ColorComponents 75%9/12
50%1/2
81%135/166
-  module reanimate-0.4.1.0-inplace/Reanimate.Svg.LineCommand -75%12/16
58%43/74
69%659/943
-   module reanimate-0.4.1.0-inplace/Reanimate.Svg.Constructors 67%33/49
37%3/8
65%369/565
@@ -44,7 +44,7 @@ table.dashboard { border-collapse: collapse ; border: solid 1px black } 40%2/5
16%1/6
26%22/83
  module reanimate-0.4.1.0-inplace/Reanimate.Svg.BoundingBox -40%2/5
16%6/36
27%76/281
+40%2/5
16%6/36
26%76/282
  module reanimate-0.4.1.0-inplace/Reanimate.Svg 38%5/13
18%15/80
41%323/777
@@ -125,5 +125,5 @@ table.dashboard { border-collapse: collapse ; border: solid 1px black } 0%0/1
0%0/4
0%0/61
  Program Coverage Total -31%246/786
16%131/805
29%4646/15516
+31%246/785
16%131/805
29%4646/15511
diff --git a/playground/snippets.js b/playground/snippets.js index d9ca18f..54ca0f2 100644 --- a/playground/snippets.js +++ b/playground/snippets.js @@ -9,4 +9,4 @@ const snippets = [{"title": "Hello World","url": "https://reanimate.clozecards.c ,{"title": "Object Positions","url": "https://reanimate.clozecards.com/IAQhjO0Ke7h/195.svg","code": "env =\n addStatic (mkBackground \"white\") .\n mapA (withStrokeColor \"black\")\n\nanimation :: Animation\nanimation = env $\n sceneAnimation $ do\n -- Configure objects\n txt <- newText \"Center\"\n top <- newText \"Top\"\n oModifyS top $ \n oTopY .= screenTop\n topR <- newText \"Top right\"\n oModifyS topR $ do\n oTopY .= screenTop\n oRightX .= screenRight\n botR <- newText \"Bottom right\"\n oModifyS botR $ do\n oBottomY .= screenBottom\n oRightX .= screenRight\n botL <- newText \"Bottom left\"\n oModifyS botL $ do\n oBottomY .= screenBottom\n oLeftX .= screenLeft\n topL <- newText \"Top left\"\n oModifyS topL $ do\n oTopY .= screenTop\n oLeftX .= screenLeft\n -- Show objects\n oShow txt\n wait 1\n switchTo txt top\n switchTo top topR\n switchTo topR botR\n switchTo botR botL\n switchTo botL topL\n switchTo topL txt\n\nswitchTo src dst = do\n fork $ oFadeOut src 1\n oModify dst $ oOpacity .~ 1\n oFadeIn dst 1\n wait 1\n\nnewText txt =\n newObject $ scale 1.5 $ center $ latex txt\n"} ,{"title": "Camera","url": "https://reanimate.clozecards.com/CD5Bg7AwVkF/150.svg","code": "animation :: Animation\nanimation = docEnv $ mapA (withFillOpacity 1) $ sceneAnimation $ do\n cam <- newObject Camera\n\n txt <- newObject $ center $ latex \"Fixed (non-cam)\"\n oModifyS txt $ do\n oTopY .= screenTop \n oZIndex .= 2\n\n circle <- newObject $ Circle 1\n cameraAttach cam circle\n oModify circle $ oContext .~ withFillColor \"blue\"\n circleRight <- oRead circle oRightX\n\n box <- newObject $ Rectangle 2 2\n cameraAttach cam box\n oModify box $ oContext .~ withFillColor \"green\"\n oModify box $ oLeftX .~ circleRight\n boxCenter <- oRead box oCenterXY\n\n small <- newObject $ center $ latex \"This text is very small\"\n cameraAttach cam small\n oModifyS small $ do\n oCenterXY .= boxCenter\n oScale .= 0.1\n \n oShow txt\n oShow small\n oShow circle\n oShow box\n\n wait 1\n\n cameraFocus cam boxCenter\n waitOn $ do\n fork $ cameraPan cam 3 boxCenter\n fork $ cameraZoom cam 3 15\n \n wait 2\n cameraZoom cam 3 1\n cameraPan cam 1 (0,0)\n"} ]; -const playgroundVersion = "2020-08-27 (0ea12)"; +const playgroundVersion = "2020-08-27 (aa465)"; diff --git a/reanimate-0.4.1.0-inplace/Reanimate.LaTeX.hs.html b/reanimate-0.4.1.0-inplace/Reanimate.LaTeX.hs.html index ad2867c..1204688 100644 --- a/reanimate-0.4.1.0-inplace/Reanimate.LaTeX.hs.html +++ b/reanimate-0.4.1.0-inplace/Reanimate.LaTeX.hs.html @@ -66,135 +66,139 @@ span.spaces { background: white } 47 latex :: T.Text -> Tree 48 latex = latexWithHeaders [] 49 - 50 latexWithHeaders :: [T.Text] -> T.Text -> Tree - 51 latexWithHeaders = someTexWithHeaders "latex" "dvi" [] - 52 - 53 someTexWithHeaders :: String -> String -> [String] -> [T.Text] -> T.Text -> Tree - 54 someTexWithHeaders _exec _dvi _args _headers tex | pNoExternals = mkText tex - 55 someTexWithHeaders exec dvi args headers tex = - 56 (unsafePerformIO . (cacheMem . cacheDiskSvg) (latexToSVG dvi exec args)) - 57 script - 58 where - 59 script = mkTexScript exec args headers tex - 60 - 61 latexChunks :: [T.Text] -> [Tree] - 62 latexChunks chunks | pNoExternals = map mkText chunks - 63 latexChunks chunks = worker (svgGlyphs $ latex $ T.concat chunks) chunks - 64 where - 65 merge lst = mkGroup [ fmt svg | (fmt, _, svg) <- lst ] - 66 worker [] [] = [] - 67 worker _ [] = error "latex chunk mismatch" - 68 worker everything (x : xs) = - 69 let width = length $ svgGlyphs (latex x) - 70 in merge (take width everything) : worker (drop width everything) xs - 71 - 72 -- | Invoke xelatex and import the result as an SVG object. SVG objects are - 73 -- cached to improve performance. Xelatex has support for non-western scripts. - 74 xelatex :: Text -> Tree - 75 xelatex = xelatexWithHeaders [] - 76 - 77 xelatexWithHeaders :: [T.Text] -> T.Text -> Tree - 78 xelatexWithHeaders = someTexWithHeaders "xelatex" "xdv" ["-no-pdf"] - 79 - 80 -- | Invoke xelatex with "\usepackage[UTF8]{ctex}" and import the result as an - 81 -- SVG object. SVG objects are cached to improve performance. Xelatex has - 82 -- support for non-western scripts. - 83 -- - 84 -- Example: - 85 -- - 86 -- > ctex "中文" - 87 -- - 88 -- <<docs/gifs/doc_ctex.gif>> - 89 ctex :: T.Text -> Tree - 90 ctex = ctexWithHeaders [] - 91 - 92 ctexWithHeaders :: [T.Text] -> T.Text -> Tree - 93 ctexWithHeaders headers = xelatexWithHeaders ("\\usepackage[UTF8]{ctex}" : headers) + 50 -- | Invoke latex with extra script headers. + 51 latexWithHeaders :: [T.Text] -> T.Text -> Tree + 52 latexWithHeaders = someTexWithHeaders "latex" "dvi" [] + 53 + 54 someTexWithHeaders :: String -> String -> [String] -> [T.Text] -> T.Text -> Tree + 55 someTexWithHeaders _exec _dvi _args _headers tex | pNoExternals = mkText tex + 56 someTexWithHeaders exec dvi args headers tex = + 57 (unsafePerformIO . (cacheMem . cacheDiskSvg) (latexToSVG dvi exec args)) + 58 script + 59 where + 60 script = mkTexScript exec args headers tex + 61 + 62 -- | Invoke latex and separate results. + 63 latexChunks :: [T.Text] -> [Tree] + 64 latexChunks chunks | pNoExternals = map mkText chunks + 65 latexChunks chunks = worker (svgGlyphs $ latex $ T.concat chunks) chunks + 66 where + 67 merge lst = mkGroup [ fmt svg | (fmt, _, svg) <- lst ] + 68 worker [] [] = [] + 69 worker _ [] = error "latex chunk mismatch" + 70 worker everything (x : xs) = + 71 let width = length $ svgGlyphs (latex x) + 72 in merge (take width everything) : worker (drop width everything) xs + 73 + 74 -- | Invoke xelatex and import the result as an SVG object. SVG objects are + 75 -- cached to improve performance. Xelatex has support for non-western scripts. + 76 xelatex :: Text -> Tree + 77 xelatex = xelatexWithHeaders [] + 78 + 79 -- | Invoke xelatex with extra script headers. + 80 xelatexWithHeaders :: [T.Text] -> T.Text -> Tree + 81 xelatexWithHeaders = someTexWithHeaders "xelatex" "xdv" ["-no-pdf"] + 82 + 83 -- | Invoke xelatex with "\usepackage[UTF8]{ctex}" and import the result as an + 84 -- SVG object. SVG objects are cached to improve performance. Xelatex has + 85 -- support for non-western scripts. + 86 -- + 87 -- Example: + 88 -- + 89 -- > ctex "中文" + 90 -- + 91 -- <<docs/gifs/doc_ctex.gif>> + 92 ctex :: T.Text -> Tree + 93 ctex = ctexWithHeaders [] 94 - 95 -- | Invoke latex and import the result as an SVG object. SVG objects are - 96 -- cached to improve performance. This wraps the TeX code in an 'align*' - 97 -- context. - 98 -- - 99 -- Example: - 100 -- - 101 -- > latexAlign "R = \\frac{{\\Delta x}}{{kA}}" + 95 -- | Invoke xelatex with extra script headers + ctex headers. + 96 ctexWithHeaders :: [T.Text] -> T.Text -> Tree + 97 ctexWithHeaders headers = xelatexWithHeaders ("\\usepackage[UTF8]{ctex}" : headers) + 98 + 99 -- | Invoke latex and import the result as an SVG object. SVG objects are + 100 -- cached to improve performance. This wraps the TeX code in an 'align*' + 101 -- context. 102 -- - 103 -- <<docs/gifs/doc_latexAlign.gif>> - 104 latexAlign :: Text -> Tree - 105 latexAlign tex = latex $ T.unlines ["\\begin{align*}", tex, "\\end{align*}"] - 106 - 107 postprocess :: Tree -> Tree - 108 postprocess = simplify - 109 - 110 -- executable, arguments, header, tex - 111 latexToSVG :: String -> String -> [String] -> Text -> IO Tree - 112 latexToSVG dviExt latexExec latexArgs tex = do - 113 latexBin <- requireExecutable latexExec - 114 dvisvgm <- requireExecutable "dvisvgm" - 115 withTempDir $ \tmp_dir -> withTempFile "tex" $ \tex_file -> - 116 withTempFile "svg" $ \svg_file -> do - 117 let dvi_file = - 118 tmp_dir </> replaceExtension (takeFileName tex_file) dviExt - 119 B.writeFile tex_file (T.encodeUtf8 tex) - 120 runCmd - 121 latexBin - 122 ( latexArgs - 123 ++ [ "-interaction=nonstopmode" - 124 , "-halt-on-error" - 125 , "-output-directory=" ++ tmp_dir - 126 , tex_file - 127 ] - 128 ) - 129 runCmd - 130 dvisvgm - 131 [ dvi_file - 132 , "--precision=5" - 133 , "--exact" -- better bboxes. - 134 , "--no-fonts" -- use glyphs instead of fonts. - 135 , "--scale=0.1,-0.1" - 136 , "--verbosity=0" - 137 , "-o" - 138 , svg_file - 139 ] - 140 svg_data <- B.readFile svg_file - 141 case parseSvgFile svg_file svg_data of - 142 Nothing -> error "Malformed svg" - 143 Just svg -> return $ postprocess $ unbox $ replaceUses svg - 144 - 145 mkTexScript :: String -> [String] -> [Text] -> Text -> Text - 146 mkTexScript latexExec latexArgs texHeaders tex = - 147 T.unlines - 148 $ [ "% " <> T.pack (unwords (latexExec : latexArgs)) - 149 , "\\documentclass[preview]{standalone}" - 150 , "\\usepackage{amsmath}" - 151 , "\\usepackage{gensymb}" - 152 ] - 153 ++ texHeaders - 154 ++ [ "\\usepackage[english]{babel}" - 155 , "\\linespread{1}" - 156 , "\\begin{document}" - 157 , tex - 158 , "\\end{document}" - 159 ] - 160 - 161 {- Packages used by manim. - 162 - 163 \\\usepackage{amsmath}\n\ - 164 \\\usepackage{amssymb}\n\ - 165 \\\usepackage{dsfont}\n\ - 166 \\\usepackage{setspace}\n\ - 167 \\\usepackage{relsize}\n\ - 168 \\\usepackage{textcomp}\n\ - 169 \\\usepackage{mathrsfs}\n\ - 170 \\\usepackage{calligra}\n\ - 171 \\\usepackage{wasysym}\n\ - 172 \\\usepackage{ragged2e}\n\ - 173 \\\usepackage{physics}\n\ - 174 \\\usepackage{xcolor}\n\ - 175 \\\usepackage{textcomp}\n\ - 176 \\\usepackage{xfrac}\n\ - 177 \\\usepackage{microtype}\n\ - 178 -} + 103 -- Example: + 104 -- + 105 -- > latexAlign "R = \\frac{{\\Delta x}}{{kA}}" + 106 -- + 107 -- <<docs/gifs/doc_latexAlign.gif>> + 108 latexAlign :: Text -> Tree + 109 latexAlign tex = latex $ T.unlines ["\\begin{align*}", tex, "\\end{align*}"] + 110 + 111 postprocess :: Tree -> Tree + 112 postprocess = simplify + 113 + 114 -- executable, arguments, header, tex + 115 latexToSVG :: String -> String -> [String] -> Text -> IO Tree + 116 latexToSVG dviExt latexExec latexArgs tex = do + 117 latexBin <- requireExecutable latexExec + 118 dvisvgm <- requireExecutable "dvisvgm" + 119 withTempDir $ \tmp_dir -> withTempFile "tex" $ \tex_file -> + 120 withTempFile "svg" $ \svg_file -> do + 121 let dvi_file = + 122 tmp_dir </> replaceExtension (takeFileName tex_file) dviExt + 123 B.writeFile tex_file (T.encodeUtf8 tex) + 124 runCmd + 125 latexBin + 126 ( latexArgs + 127 ++ [ "-interaction=nonstopmode" + 128 , "-halt-on-error" + 129 , "-output-directory=" ++ tmp_dir + 130 , tex_file + 131 ] + 132 ) + 133 runCmd + 134 dvisvgm + 135 [ dvi_file + 136 , "--precision=5" + 137 , "--exact" -- better bboxes. + 138 , "--no-fonts" -- use glyphs instead of fonts. + 139 , "--scale=0.1,-0.1" + 140 , "--verbosity=0" + 141 , "-o" + 142 , svg_file + 143 ] + 144 svg_data <- B.readFile svg_file + 145 case parseSvgFile svg_file svg_data of + 146 Nothing -> error "Malformed svg" + 147 Just svg -> return $ postprocess $ unbox $ replaceUses svg + 148 + 149 mkTexScript :: String -> [String] -> [Text] -> Text -> Text + 150 mkTexScript latexExec latexArgs texHeaders tex = + 151 T.unlines + 152 $ [ "% " <> T.pack (unwords (latexExec : latexArgs)) + 153 , "\\documentclass[preview]{standalone}" + 154 , "\\usepackage{amsmath}" + 155 , "\\usepackage{gensymb}" + 156 ] + 157 ++ texHeaders + 158 ++ [ "\\usepackage[english]{babel}" + 159 , "\\linespread{1}" + 160 , "\\begin{document}" + 161 , tex + 162 , "\\end{document}" + 163 ] + 164 + 165 {- Packages used by manim. + 166 + 167 \\\usepackage{amsmath}\n\ + 168 \\\usepackage{amssymb}\n\ + 169 \\\usepackage{dsfont}\n\ + 170 \\\usepackage{setspace}\n\ + 171 \\\usepackage{relsize}\n\ + 172 \\\usepackage{textcomp}\n\ + 173 \\\usepackage{mathrsfs}\n\ + 174 \\\usepackage{calligra}\n\ + 175 \\\usepackage{wasysym}\n\ + 176 \\\usepackage{ragged2e}\n\ + 177 \\\usepackage{physics}\n\ + 178 \\\usepackage{xcolor}\n\ + 179 \\\usepackage{textcomp}\n\ + 180 \\\usepackage{xfrac}\n\ + 181 \\\usepackage{microtype}\n\ + 182 -} diff --git a/reanimate-0.4.1.0-inplace/Reanimate.Render.hs.html b/reanimate-0.4.1.0-inplace/Reanimate.Render.hs.html index 3a2dd15..cc4c724 100644 --- a/reanimate-0.4.1.0-inplace/Reanimate.Render.hs.html +++ b/reanimate-0.4.1.0-inplace/Reanimate.Render.hs.html @@ -24,395 +24,413 @@ span.spaces { background: white } 5 Maintainer : lemmih@gmail.com 6 Stability : experimental 7 Portability : POSIX - 8 -} - 9 module Reanimate.Render - 10 ( render - 11 , renderSvgs - 12 , renderSnippets -- :: Animation -> IO () - 13 , renderOneFrame - 14 , Format(..) - 15 , Raster(..) - 16 , Width, Height, FPS - 17 , requireRaster -- :: Raster -> IO Raster - 18 , selectRaster -- :: Raster -> IO Raster - 19 , applyRaster -- :: Raster -> FilePath -> IO () - 20 ) where - 21 - 22 import Control.Concurrent - 23 import Control.Exception - 24 import Control.Monad (forM_, forever, unless, void, when) - 25 import Data.Either - 26 import Data.Function - 27 import qualified Data.Text as T - 28 import qualified Data.Text.IO as T - 29 import Data.Time - 30 import Graphics.SvgTree (Number (..)) - 31 import Numeric - 32 import Reanimate.Animation - 33 import Reanimate.Driver.Check - 34 import Reanimate.Driver.Magick - 35 import Reanimate.Misc - 36 import Reanimate.Parameters - 37 import System.Console.ANSI.Codes - 38 import System.Exit - 39 import System.FileLock (withTryFileLock, SharedExclusive(..), unlockFile) - 40 import System.Directory - 41 import System.FilePath (replaceExtension, (<.>), (</>)) - 42 import System.IO - 43 import Text.Printf (printf) - 44 - 45 idempotentFile :: FilePath -> IO () -> IO () - 46 idempotentFile path action = do - 47 _ <- withTryFileLock lockFile Exclusive $ \lock -> do - 48 haveFile <- doesFileExist path - 49 unless haveFile action - 50 unlockFile lock - 51 _ <- try (removeFile lockFile) :: IO (Either SomeException ()) - 52 return () - 53 return () - 54 where - 55 lockFile = path <.> "lock" - 56 - 57 renderSvgs :: FilePath -> Int -> Bool -> Animation -> IO () - 58 renderSvgs folder offset _prettyPrint ani = do - 59 print frameCount - 60 lock <- newMVar () - 61 - 62 handle errHandler $ concurrentForM_ (frameOrder rate frameCount) $ \nth' -> do - 63 let nth = (nth'+offset) `mod` frameCount - 64 now = (duration ani / (fromIntegral frameCount - 1)) * fromIntegral nth - 65 frame = frameAt (if frameCount <= 1 then 0 else now) ani - 66 svg = renderSvg Nothing Nothing frame - 67 path = folder </> show nth <.> "svg" - 68 - 69 idempotentFile path $ writeFile path svg - 70 withMVar lock $ \_ -> do - 71 print nth - 72 hFlush stdout - 73 where - 74 rate = 60 - 75 frameCount = round (duration ani * fromIntegral rate) :: Int - 76 errHandler (ErrorCall msg) = do - 77 hPutStrLn stderr msg - 78 exitWith (ExitFailure 1) - 79 - 80 renderOneFrame :: FilePath -> Int -> Bool -> Int -> Animation -> IO () - 81 renderOneFrame folder offset _prettyPrint rate ani = - 82 worker (frameOrder rate frameCount) - 83 where - 84 worker [] = putStrLn "Done" - 85 worker (x:xs) = do - 86 let nth = (x+offset) `mod` frameCount - 87 now = (duration ani / (fromIntegral frameCount - 1)) * fromIntegral nth - 88 frame = frameAt (if frameCount <= 1 then 0 else now) ani - 89 svg = renderSvg Nothing Nothing frame - 90 path = folder </> show nth <.> "svg" - 91 tmpPath = path <.> "tmp" - 92 haveFile <- doesFileExist path - 93 if haveFile - 94 then worker xs - 95 else do - 96 writeFile tmpPath svg - 97 renameOrCopyFile tmpPath path - 98 print nth - 99 frameCount = round (duration ani * fromIntegral rate) :: Int - 100 - 101 -- XXX: Merge with 'renderSvgs' - 102 renderSnippets :: Animation -> IO () - 103 renderSnippets ani = forM_ [0 .. frameCount - 1] $ \nth -> do - 104 let now = (duration ani / (fromIntegral frameCount - 1)) * fromIntegral nth - 105 frame = frameAt now ani - 106 svg = renderSvg Nothing Nothing frame - 107 putStr (show nth) - 108 T.putStrLn $ T.concat . T.lines . T.pack $ svg - 109 where frameCount = 10 :: Integer - 110 - 111 frameOrder :: Int -> Int -> [Int] - 112 frameOrder fps nFrames = worker [] fps - 113 where - 114 worker _seen 0 = [] - 115 worker seen nthFrame = filterFrameList seen nthFrame nFrames - 116 ++ worker (nthFrame : seen) (nthFrame `div` 2) - 117 - 118 filterFrameList :: [Int] -> Int -> Int -> [Int] - 119 filterFrameList seen nthFrame nFrames = filter (not . isSeen) - 120 [0, nthFrame .. nFrames - 1] - 121 where isSeen x = any (\y -> x `mod` y == 0) seen - 122 - 123 data Format = RenderMp4 | RenderGif | RenderWebm - 124 deriving (Show) - 125 - 126 mp4Arguments :: FPS -> FilePath -> FilePath -> FilePath -> [String] - 127 mp4Arguments fps progress template target = - 128 [ "-r" - 129 , show fps - 130 , "-i" - 131 , template - 132 , "-y" - 133 , "-c:v" - 134 , "libx264" - 135 , "-vf" - 136 , "fps=" ++ show fps - 137 , "-preset" - 138 , "slow" - 139 , "-crf" - 140 , "18" - 141 , "-movflags" - 142 , "+faststart" - 143 , "-progress" - 144 , progress - 145 , "-pix_fmt" - 146 , "yuv420p" - 147 , target - 148 ] - 149 - 150 -- gifArguments :: FPS -> FilePath -> FilePath -> FilePath -> [String] - 151 -- gifArguments fps progress template target = - 152 - 153 render - 154 :: Animation - 155 -> FilePath - 156 -> Raster - 157 -> Format - 158 -> Width - 159 -> Height - 160 -> FPS - 161 -> Bool - 162 -> IO () - 163 render ani target raster format width height fps partial = do - 164 printf "Starting render of animation: %.1f\n" (duration ani) - 165 ffmpeg <- requireExecutable "ffmpeg" - 166 generateFrames raster ani width height fps partial $ \template -> - 167 withTempFile "txt" $ \progress -> do - 168 writeFile progress "" - 169 progressH <- openFile progress ReadMode - 170 hSetBuffering progressH NoBuffering - 171 allFinished <- newEmptyMVar - 172 void $ forkIO $ do - 173 progressPrinter "rendered" (animationFrameCount ani fps) - 174 $ \done -> fix $ \loop -> do - 175 eof <- hIsEOF progressH - 176 if eof - 177 then threadDelay 1000000 >> loop - 178 else do - 179 l <- try (hGetLine progressH) - 180 case l of - 181 Left SomeException{} -> return () - 182 Right str -> - 183 case take 6 str of - 184 "frame=" -> do - 185 void $ swapMVar done (read (drop 6 str)) - 186 loop - 187 _ | str == "progress=end" -> return () - 188 _ -> loop - 189 putMVar allFinished () - 190 case format of - 191 RenderMp4 -> runCmd ffmpeg (mp4Arguments fps progress template target) - 192 RenderGif -> withTempFile "png" $ \palette -> do - 193 runCmd - 194 ffmpeg - 195 [ "-i" - 196 , template - 197 , "-y" - 198 , "-vf" - 199 , "fps=" - 200 ++ show fps - 201 ++ ",scale=" - 202 ++ show width - 203 ++ ":" - 204 ++ show height - 205 ++ ":flags=lanczos,palettegen" - 206 , "-t" - 207 , showFFloat Nothing (duration ani) "" - 208 , palette - 209 ] - 210 runCmd - 211 ffmpeg - 212 [ "-framerate" - 213 , show fps - 214 , "-i" - 215 , template - 216 , "-y" - 217 , "-i" - 218 , palette - 219 , "-progress" - 220 , progress - 221 , "-filter_complex" - 222 , "fps=" - 223 ++ show fps - 224 ++ ",scale=" - 225 ++ show width - 226 ++ ":" - 227 ++ show height - 228 ++ ":flags=lanczos[x];[x][1:v]paletteuse" - 229 , "-t" - 230 , showFFloat Nothing (duration ani) "" - 231 , target - 232 ] - 233 RenderWebm -> runCmd - 234 ffmpeg - 235 [ "-r" - 236 , show fps - 237 , "-i" - 238 , template - 239 , "-y" - 240 , "-progress" - 241 , progress - 242 , "-c:v" - 243 , "libvpx-vp9" - 244 , "-vf" - 245 , "fps=" ++ show fps - 246 , target - 247 ] - 248 takeMVar allFinished - 249 - 250 --------------------------------------------------------------------------------- - 251 -- Helpers - 252 - 253 progressPrinter :: String -> Int -> (MVar Int -> IO ()) -> IO () - 254 progressPrinter typeName maxCount action = do - 255 printf "\rFrames %s: 0/%d" typeName maxCount - 256 putStr $ clearFromCursorToLineEndCode ++ "\r" - 257 done <- newMVar (0 :: Int) - 258 start <- getCurrentTime - 259 let bgThread = forever $ do - 260 nDone <- readMVar done - 261 now <- getCurrentTime - 262 let spent = diffUTCTime now start - 263 remaining = - 264 (spent / (fromIntegral nDone / fromIntegral maxCount)) - spent - 265 printf "\rFrames %s: %d/%d" typeName nDone maxCount - 266 putStr $ ", time spent: " ++ ppDiff spent - 267 unless (nDone == 0) $ do - 268 putStr $ ", time remaining: " ++ ppDiff remaining - 269 putStr $ ", total time: " ++ ppDiff (remaining + spent) - 270 putStr $ clearFromCursorToLineEndCode ++ "\r" - 271 hFlush stdout - 272 threadDelay 1000000 - 273 withBackgroundThread bgThread $ action done - 274 now <- getCurrentTime - 275 let spent = diffUTCTime now start - 276 printf "\rFrames %s: %d/%d" typeName maxCount maxCount - 277 putStr $ ", time spent: " ++ ppDiff spent - 278 putStr $ clearFromCursorToLineEndCode ++ "\n" - 279 - 280 animationFrameCount :: Animation -> FPS -> Int - 281 animationFrameCount ani rate = round (duration ani * fromIntegral rate) :: Int - 282 - 283 generateFrames - 284 :: Raster -> Animation -> Width -> Height -> FPS -> Bool -> (FilePath -> IO a) -> IO a - 285 generateFrames raster ani width_ height_ rate partial action = withTempDir $ \tmp -> do - 286 let frameName nth = tmp </> printf nameTemplate nth - 287 setRootDirectory tmp - 288 progressPrinter "generated" frameCount - 289 $ \done -> handle h $ concurrentForM_ frames $ \n -> do - 290 writeFile (frameName n) $ renderSvg width height $ nthFrame n - 291 modifyMVar_ done $ \nDone -> return (nDone + 1) - 292 - 293 when (isValidRaster raster) - 294 $ progressPrinter "rastered" frameCount - 295 $ \done -> handle h $ concurrentForM_ frames $ \n -> do - 296 applyRaster raster (frameName n) - 297 modifyMVar_ done $ \nDone -> return (nDone + 1) - 298 - 299 action (tmp </> rasterTemplate raster) - 300 where - 301 isValidRaster RasterNone = False - 302 isValidRaster RasterAuto = False - 303 isValidRaster _ = True + 8 + 9 Internal tools for rastering SVGs and rendering videos. You are unlikely + 10 to ever directly use the functions in this module. + 11 + 12 -} + 13 module Reanimate.Render + 14 ( render + 15 , renderSvgs + 16 , renderSnippets -- :: Animation -> IO () + 17 , renderOneFrame + 18 , Format(..) + 19 , Raster(..) + 20 , Width, Height, FPS + 21 , requireRaster -- :: Raster -> IO Raster + 22 , selectRaster -- :: Raster -> IO Raster + 23 , applyRaster -- :: Raster -> FilePath -> IO () + 24 ) where + 25 + 26 import Control.Concurrent + 27 import Control.Exception + 28 import Control.Monad (forM_, forever, unless, void, when) + 29 import Data.Either + 30 import Data.Function + 31 import qualified Data.Text as T + 32 import qualified Data.Text.IO as T + 33 import Data.Time + 34 import Graphics.SvgTree (Number (..)) + 35 import Numeric + 36 import Reanimate.Animation + 37 import Reanimate.Driver.Check + 38 import Reanimate.Driver.Magick + 39 import Reanimate.Misc + 40 import Reanimate.Parameters + 41 import System.Console.ANSI.Codes + 42 import System.Exit + 43 import System.FileLock (withTryFileLock, SharedExclusive(..), unlockFile) + 44 import System.Directory + 45 import System.FilePath (replaceExtension, (<.>), (</>)) + 46 import System.IO + 47 import Text.Printf (printf) + 48 + 49 idempotentFile :: FilePath -> IO () -> IO () + 50 idempotentFile path action = do + 51 _ <- withTryFileLock lockFile Exclusive $ \lock -> do + 52 haveFile <- doesFileExist path + 53 unless haveFile action + 54 unlockFile lock + 55 _ <- try (removeFile lockFile) :: IO (Either SomeException ()) + 56 return () + 57 return () + 58 where + 59 lockFile = path <.> "lock" + 60 + 61 -- | Generate SVGs at 60fps and put them in a folder. + 62 renderSvgs :: FilePath -> Int -> Bool -> Animation -> IO () + 63 renderSvgs folder offset _prettyPrint ani = do + 64 print frameCount + 65 lock <- newMVar () + 66 + 67 handle errHandler $ concurrentForM_ (frameOrder rate frameCount) $ \nth' -> do + 68 let nth = (nth'+offset) `mod` frameCount + 69 now = (duration ani / (fromIntegral frameCount - 1)) * fromIntegral nth + 70 frame = frameAt (if frameCount <= 1 then 0 else now) ani + 71 svg = renderSvg Nothing Nothing frame + 72 path = folder </> show nth <.> "svg" + 73 + 74 idempotentFile path $ writeFile path svg + 75 withMVar lock $ \_ -> do + 76 print nth + 77 hFlush stdout + 78 where + 79 rate = 60 + 80 frameCount = round (duration ani * fromIntegral rate) :: Int + 81 errHandler (ErrorCall msg) = do + 82 hPutStrLn stderr msg + 83 exitWith (ExitFailure 1) + 84 + 85 -- | Select a single frame that doesn't already exist in the output + 86 -- folder and render it. If all frames have been rendered, print "Done". + 87 renderOneFrame :: FilePath -> Int -> Bool -> Int -> Animation -> IO () + 88 renderOneFrame folder offset _prettyPrint rate ani = + 89 worker (frameOrder rate frameCount) + 90 where + 91 worker [] = putStrLn "Done" + 92 worker (x:xs) = do + 93 let nth = (x+offset) `mod` frameCount + 94 now = (duration ani / (fromIntegral frameCount - 1)) * fromIntegral nth + 95 frame = frameAt (if frameCount <= 1 then 0 else now) ani + 96 svg = renderSvg Nothing Nothing frame + 97 path = folder </> show nth <.> "svg" + 98 tmpPath = path <.> "tmp" + 99 haveFile <- doesFileExist path + 100 if haveFile + 101 then worker xs + 102 else do + 103 writeFile tmpPath svg + 104 renameOrCopyFile tmpPath path + 105 print nth + 106 frameCount = round (duration ani * fromIntegral rate) :: Int + 107 + 108 -- XXX: Merge with 'renderSvgs' + 109 -- | Render 10 frames and print them to stdout. Used for testing. + 110 -- + 111 -- XXX: Not related to the snippets in the playground. + 112 renderSnippets :: Animation -> IO () + 113 renderSnippets ani = forM_ [0 .. frameCount - 1] $ \nth -> do + 114 let now = (duration ani / (fromIntegral frameCount - 1)) * fromIntegral nth + 115 frame = frameAt now ani + 116 svg = renderSvg Nothing Nothing frame + 117 putStr (show nth) + 118 T.putStrLn $ T.concat . T.lines . T.pack $ svg + 119 where frameCount = 10 :: Integer + 120 + 121 frameOrder :: Int -> Int -> [Int] + 122 frameOrder fps nFrames = worker [] fps + 123 where + 124 worker _seen 0 = [] + 125 worker seen nthFrame = filterFrameList seen nthFrame nFrames + 126 ++ worker (nthFrame : seen) (nthFrame `div` 2) + 127 + 128 filterFrameList :: [Int] -> Int -> Int -> [Int] + 129 filterFrameList seen nthFrame nFrames = filter (not . isSeen) + 130 [0, nthFrame .. nFrames - 1] + 131 where isSeen x = any (\y -> x `mod` y == 0) seen + 132 + 133 -- | Video formats supported by reanimate. + 134 data Format = RenderMp4 | RenderGif | RenderWebm + 135 deriving (Show) + 136 + 137 mp4Arguments :: FPS -> FilePath -> FilePath -> FilePath -> [String] + 138 mp4Arguments fps progress template target = + 139 [ "-r" + 140 , show fps + 141 , "-i" + 142 , template + 143 , "-y" + 144 , "-c:v" + 145 , "libx264" + 146 , "-vf" + 147 , "fps=" ++ show fps + 148 , "-preset" + 149 , "slow" + 150 , "-crf" + 151 , "18" + 152 , "-movflags" + 153 , "+faststart" + 154 , "-progress" + 155 , progress + 156 , "-pix_fmt" + 157 , "yuv420p" + 158 , target + 159 ] + 160 + 161 -- gifArguments :: FPS -> FilePath -> FilePath -> FilePath -> [String] + 162 -- gifArguments fps progress template target = + 163 + 164 -- | Render animation to a video file with given parameters. + 165 render + 166 :: Animation + 167 -> FilePath + 168 -> Raster + 169 -> Format + 170 -> Width + 171 -> Height + 172 -> FPS + 173 -> Bool + 174 -> IO () + 175 render ani target raster format width height fps partial = do + 176 printf "Starting render of animation: %.1f\n" (duration ani) + 177 ffmpeg <- requireExecutable "ffmpeg" + 178 generateFrames raster ani width height fps partial $ \template -> + 179 withTempFile "txt" $ \progress -> do + 180 writeFile progress "" + 181 progressH <- openFile progress ReadMode + 182 hSetBuffering progressH NoBuffering + 183 allFinished <- newEmptyMVar + 184 void $ forkIO $ do + 185 progressPrinter "rendered" (animationFrameCount ani fps) + 186 $ \done -> fix $ \loop -> do + 187 eof <- hIsEOF progressH + 188 if eof + 189 then threadDelay 1000000 >> loop + 190 else do + 191 l <- try (hGetLine progressH) + 192 case l of + 193 Left SomeException{} -> return () + 194 Right str -> + 195 case take 6 str of + 196 "frame=" -> do + 197 void $ swapMVar done (read (drop 6 str)) + 198 loop + 199 _ | str == "progress=end" -> return () + 200 _ -> loop + 201 putMVar allFinished () + 202 case format of + 203 RenderMp4 -> runCmd ffmpeg (mp4Arguments fps progress template target) + 204 RenderGif -> withTempFile "png" $ \palette -> do + 205 runCmd + 206 ffmpeg + 207 [ "-i" + 208 , template + 209 , "-y" + 210 , "-vf" + 211 , "fps=" + 212 ++ show fps + 213 ++ ",scale=" + 214 ++ show width + 215 ++ ":" + 216 ++ show height + 217 ++ ":flags=lanczos,palettegen" + 218 , "-t" + 219 , showFFloat Nothing (duration ani) "" + 220 , palette + 221 ] + 222 runCmd + 223 ffmpeg + 224 [ "-framerate" + 225 , show fps + 226 , "-i" + 227 , template + 228 , "-y" + 229 , "-i" + 230 , palette + 231 , "-progress" + 232 , progress + 233 , "-filter_complex" + 234 , "fps=" + 235 ++ show fps + 236 ++ ",scale=" + 237 ++ show width + 238 ++ ":" + 239 ++ show height + 240 ++ ":flags=lanczos[x];[x][1:v]paletteuse" + 241 , "-t" + 242 , showFFloat Nothing (duration ani) "" + 243 , target + 244 ] + 245 RenderWebm -> runCmd + 246 ffmpeg + 247 [ "-r" + 248 , show fps + 249 , "-i" + 250 , template + 251 , "-y" + 252 , "-progress" + 253 , progress + 254 , "-c:v" + 255 , "libvpx-vp9" + 256 , "-vf" + 257 , "fps=" ++ show fps + 258 , target + 259 ] + 260 takeMVar allFinished + 261 + 262 --------------------------------------------------------------------------------- + 263 -- Helpers + 264 + 265 progressPrinter :: String -> Int -> (MVar Int -> IO ()) -> IO () + 266 progressPrinter typeName maxCount action = do + 267 printf "\rFrames %s: 0/%d" typeName maxCount + 268 putStr $ clearFromCursorToLineEndCode ++ "\r" + 269 done <- newMVar (0 :: Int) + 270 start <- getCurrentTime + 271 let bgThread = forever $ do + 272 nDone <- readMVar done + 273 now <- getCurrentTime + 274 let spent = diffUTCTime now start + 275 remaining = + 276 (spent / (fromIntegral nDone / fromIntegral maxCount)) - spent + 277 printf "\rFrames %s: %d/%d" typeName nDone maxCount + 278 putStr $ ", time spent: " ++ ppDiff spent + 279 unless (nDone == 0) $ do + 280 putStr $ ", time remaining: " ++ ppDiff remaining + 281 putStr $ ", total time: " ++ ppDiff (remaining + spent) + 282 putStr $ clearFromCursorToLineEndCode ++ "\r" + 283 hFlush stdout + 284 threadDelay 1000000 + 285 withBackgroundThread bgThread $ action done + 286 now <- getCurrentTime + 287 let spent = diffUTCTime now start + 288 printf "\rFrames %s: %d/%d" typeName maxCount maxCount + 289 putStr $ ", time spent: " ++ ppDiff spent + 290 putStr $ clearFromCursorToLineEndCode ++ "\n" + 291 + 292 animationFrameCount :: Animation -> FPS -> Int + 293 animationFrameCount ani rate = round (duration ani * fromIntegral rate) :: Int + 294 + 295 generateFrames + 296 :: Raster -> Animation -> Width -> Height -> FPS -> Bool -> (FilePath -> IO a) -> IO a + 297 generateFrames raster ani width_ height_ rate partial action = withTempDir $ \tmp -> do + 298 let frameName nth = tmp </> printf nameTemplate nth + 299 setRootDirectory tmp + 300 progressPrinter "generated" frameCount + 301 $ \done -> handle h $ concurrentForM_ frames $ \n -> do + 302 writeFile (frameName n) $ renderSvg width height $ nthFrame n + 303 modifyMVar_ done $ \nDone -> return (nDone + 1) 304 - 305 width = Just $ Px $ fromIntegral width_ - 306 height = Just $ Px $ fromIntegral height_ - 307 h UserInterrupt | partial = do - 308 hPutStrLn - 309 stderr - 310 "\nCtrl-C detected. Trying to generate video with available frames. \ - 311 \Hit ctrl-c again to abort." - 312 return () - 313 h other = throwIO other - 314 -- frames = [0..frameCount-1] - 315 frames = frameOrder rate frameCount - 316 nthFrame nth = frameAt (recip (fromIntegral rate) * fromIntegral nth) ani - 317 frameCount = animationFrameCount ani rate - 318 nameTemplate :: String - 319 nameTemplate = "render-%05d.svg" - 320 - 321 withBackgroundThread :: IO () -> IO a -> IO a - 322 withBackgroundThread t = bracket (forkIO t) killThread . const - 323 - 324 ppDiff :: NominalDiffTime -> String - 325 ppDiff diff | hours == 0 && mins == 0 = show secs ++ "s" - 326 | hours == 0 = printf "%.2d:%.2d" mins secs - 327 | otherwise = printf "%.2d:%.2d:%.2d" hours mins secs - 328 where - 329 (osecs, secs) = round diff `divMod` (60 :: Int) - 330 (hours, mins) = osecs `divMod` 60 - 331 - 332 rasterTemplate :: Raster -> String - 333 rasterTemplate RasterNone = "render-%05d.svg" - 334 rasterTemplate RasterAuto = "render-%05d.svg" - 335 rasterTemplate _ = "render-%05d.png" - 336 - 337 requireRaster :: Raster -> IO Raster - 338 requireRaster raster = do - 339 raster' <- selectRaster (if raster == RasterNone then RasterAuto else raster) - 340 case raster' of - 341 RasterNone -> do - 342 hPutStrLn - 343 stderr - 344 "Raster required but none could be found. \ - 345 \Please install either inkscape, imagemagick, or rsvg-convert." - 346 exitWith (ExitFailure 1) - 347 _ -> pure raster' + 305 when (isValidRaster raster) + 306 $ progressPrinter "rastered" frameCount + 307 $ \done -> handle h $ concurrentForM_ frames $ \n -> do + 308 applyRaster raster (frameName n) + 309 modifyMVar_ done $ \nDone -> return (nDone + 1) + 310 + 311 action (tmp </> rasterTemplate raster) + 312 where + 313 isValidRaster RasterNone = False + 314 isValidRaster RasterAuto = False + 315 isValidRaster _ = True + 316 + 317 width = Just $ Px $ fromIntegral width_ + 318 height = Just $ Px $ fromIntegral height_ + 319 h UserInterrupt | partial = do + 320 hPutStrLn + 321 stderr + 322 "\nCtrl-C detected. Trying to generate video with available frames. \ + 323 \Hit ctrl-c again to abort." + 324 return () + 325 h other = throwIO other + 326 -- frames = [0..frameCount-1] + 327 frames = frameOrder rate frameCount + 328 nthFrame nth = frameAt (recip (fromIntegral rate) * fromIntegral nth) ani + 329 frameCount = animationFrameCount ani rate + 330 nameTemplate :: String + 331 nameTemplate = "render-%05d.svg" + 332 + 333 withBackgroundThread :: IO () -> IO a -> IO a + 334 withBackgroundThread t = bracket (forkIO t) killThread . const + 335 + 336 ppDiff :: NominalDiffTime -> String + 337 ppDiff diff | hours == 0 && mins == 0 = show secs ++ "s" + 338 | hours == 0 = printf "%.2d:%.2d" mins secs + 339 | otherwise = printf "%.2d:%.2d:%.2d" hours mins secs + 340 where + 341 (osecs, secs) = round diff `divMod` (60 :: Int) + 342 (hours, mins) = osecs `divMod` 60 + 343 + 344 rasterTemplate :: Raster -> String + 345 rasterTemplate RasterNone = "render-%05d.svg" + 346 rasterTemplate RasterAuto = "render-%05d.svg" + 347 rasterTemplate _ = "render-%05d.png" 348 - 349 selectRaster :: Raster -> IO Raster - 350 selectRaster RasterAuto = do - 351 rsvg <- hasRSvg - 352 ink <- hasInkscape - 353 magick <- hasMagick - 354 if - 355 | isRight rsvg -> pure RasterRSvg - 356 | isRight ink -> pure RasterInkscape - 357 | isRight magick -> pure RasterMagick - 358 | otherwise -> pure RasterNone - 359 selectRaster r = pure r - 360 - 361 applyRaster :: Raster -> FilePath -> IO () - 362 applyRaster RasterNone _ = return () - 363 applyRaster RasterAuto _ = return () - 364 applyRaster RasterInkscape path = runCmd - 365 "inkscape" - 366 [ "--without-gui" - 367 , "--file=" ++ path - 368 , "--export-png=" ++ replaceExtension path "png" - 369 ] - 370 applyRaster RasterRSvg path = runCmd - 371 "rsvg-convert" - 372 [path, "--unlimited", "--output", replaceExtension path "png"] - 373 applyRaster RasterMagick path = - 374 runCmd magickCmd [path, replaceExtension path "png"] - 375 - 376 concurrentForM_ :: [a] -> (a -> IO ()) -> IO () - 377 concurrentForM_ lst action = do - 378 n <- getNumCapabilities - 379 sem <- newQSemN n - 380 eVar <- newEmptyMVar - 381 forM_ lst $ \elt -> do - 382 waitQSemN sem 1 - 383 emp <- isEmptyMVar eVar - 384 if emp - 385 then - 386 void - 387 $ forkIO - 388 ( catch (action elt) (void . tryPutMVar eVar) - 389 `finally` signalQSemN sem 1 - 390 ) - 391 else signalQSemN sem 1 - 392 waitQSemN sem n - 393 mbE <- tryTakeMVar eVar - 394 case mbE of - 395 Nothing -> return () - 396 Just e -> throwIO (e :: SomeException) + 349 -- | Resolve RasterNone and RasterAuto. If no valid raster can + 350 -- be found, exit with an error message. + 351 requireRaster :: Raster -> IO Raster + 352 requireRaster raster = do + 353 raster' <- selectRaster (if raster == RasterNone then RasterAuto else raster) + 354 case raster' of + 355 RasterNone -> do + 356 hPutStrLn + 357 stderr + 358 "Raster required but none could be found. \ + 359 \Please install either inkscape, imagemagick, or rsvg-convert." + 360 exitWith (ExitFailure 1) + 361 _ -> pure raster' + 362 + 363 -- | Resolve RasterNone and RasterAuto. If no valid raster can + 364 -- be found, return RasterNone. + 365 selectRaster :: Raster -> IO Raster + 366 selectRaster RasterAuto = do + 367 rsvg <- hasRSvg + 368 ink <- hasInkscape + 369 magick <- hasMagick + 370 if + 371 | isRight rsvg -> pure RasterRSvg + 372 | isRight ink -> pure RasterInkscape + 373 | isRight magick -> pure RasterMagick + 374 | otherwise -> pure RasterNone + 375 selectRaster r = pure r + 376 + 377 -- | Convert SVG file to a PNG file with selected raster engine. If + 378 -- raster engine is RasterAuto or RasterNone, do nothing. + 379 applyRaster :: Raster -> FilePath -> IO () + 380 applyRaster RasterNone _ = return () + 381 applyRaster RasterAuto _ = return () + 382 applyRaster RasterInkscape path = runCmd + 383 "inkscape" + 384 [ "--without-gui" + 385 , "--file=" ++ path + 386 , "--export-png=" ++ replaceExtension path "png" + 387 ] + 388 applyRaster RasterRSvg path = runCmd + 389 "rsvg-convert" + 390 [path, "--unlimited", "--output", replaceExtension path "png"] + 391 applyRaster RasterMagick path = + 392 runCmd magickCmd [path, replaceExtension path "png"] + 393 + 394 concurrentForM_ :: [a] -> (a -> IO ()) -> IO () + 395 concurrentForM_ lst action = do + 396 n <- getNumCapabilities + 397 sem <- newQSemN n + 398 eVar <- newEmptyMVar + 399 forM_ lst $ \elt -> do + 400 waitQSemN sem 1 + 401 emp <- isEmptyMVar eVar + 402 if emp + 403 then + 404 void + 405 $ forkIO + 406 ( catch (action elt) (void . tryPutMVar eVar) + 407 `finally` signalQSemN sem 1 + 408 ) + 409 else signalQSemN sem 1 + 410 waitQSemN sem n + 411 mbE <- tryTakeMVar eVar + 412 case mbE of + 413 Nothing -> return () + 414 Just e -> throwIO (e :: SomeException) diff --git a/reanimate-0.4.1.0-inplace/Reanimate.Svg.BoundingBox.hs.html b/reanimate-0.4.1.0-inplace/Reanimate.Svg.BoundingBox.hs.html index 76ff596..143e939 100644 --- a/reanimate-0.4.1.0-inplace/Reanimate.Svg.BoundingBox.hs.html +++ b/reanimate-0.4.1.0-inplace/Reanimate.Svg.BoundingBox.hs.html @@ -30,18 +30,18 @@ span.spaces { background: white } 11 , svgWidth 12 ) where 13 - 14 import Control.Arrow ((***)) - 15 import Control.Lens ((^.)) + 14 import Control.Arrow ((***)) + 15 import Control.Lens ((^.)) 16 import Data.List - 17 import Data.Maybe (mapMaybe) - 18 import Graphics.SvgTree hiding (height, line, path, use, - 19 width) - 20 import Linear.V2 hiding (angle) - 21 import Linear.Vector - 22 import Reanimate.Constants - 23 import Reanimate.Svg.LineCommand - 24 import qualified Reanimate.Transform as Transform - 25 -- import qualified Geom2D.CubicBezier as Bezier + 17 import Data.Maybe (mapMaybe) + 18 import qualified Data.Vector.Unboxed as V + 19 import qualified Geom2D.CubicBezier.Linear as Bezier + 20 import Graphics.SvgTree hiding (height, line, path, use, width) + 21 import Linear.V2 hiding (angle) + 22 import Linear.Vector + 23 import Reanimate.Constants + 24 import Reanimate.Svg.LineCommand + 25 import qualified Reanimate.Transform as Transform 26 27 -- | Return bounding box of SVG tree. 28 -- The four numbers returned are (minimal X-coordinate, minimal Y-coordinate, width, height) @@ -86,66 +86,67 @@ span.spaces { background: white } 67 LineBezier [p] -> 68 p : worker p xs 69 LineBezier ctrl -> -- approximation - 70 [ last (partialBezierPoints (from:ctrl) 0 (recip chunks*i)) | i <- [0..chunks]] ++ - 71 worker (last ctrl) xs - 72 LineEnd p -> p : worker p xs - 73 chunks = 10 - 74 - 75 svgBoundingPoints :: Tree -> [RPoint] - 76 svgBoundingPoints t = map (Transform.transformPoint m) $ - 77 case t of - 78 None -> [] - 79 UseTree{} -> [] - 80 GroupTree g -> concatMap svgBoundingPoints (g^.groupChildren) - 81 SymbolTree (Symbol g) -> concatMap svgBoundingPoints (g^.groupChildren) - 82 FilterTree{} -> [] - 83 DefinitionTree{} -> [] - 84 PathTree p -> linePoints $ toLineCommands (p^.pathDefinition) - 85 CircleTree c -> circleBoundingPoints c - 86 PolyLineTree pl -> pl ^. polyLinePoints - 87 EllipseTree e -> ellipseBoundingPoints e - 88 LineTree line -> map pointToRPoint [line^.linePoint1, line^.linePoint2] - 89 RectangleTree rect -> - 90 case pointToRPoint (rect^.rectUpperLeftCorner) of - 91 V2 x y -> V2 x y : - 92 case mapTuple (fmap $ toUserUnit defaultDPI) (rect^.rectWidth, rect^.rectHeight) of - 93 (Just (Num w), Just (Num h)) -> [V2 (x+w) (y+h)] - 94 _ -> [] - 95 TextTree{} -> [] - 96 ImageTree img -> - 97 case (img^.imageCornerUpperLeft, img^.imageWidth, img^.imageHeight) of - 98 ((Num x, Num y), Num w, Num h) -> - 99 [V2 x y, V2 (x+w) (y+h)] - 100 _ -> [] - 101 MeshGradientTree{} -> [] - 102 _ -> [] - 103 where - 104 m = Transform.mkMatrix (t^.transform) - 105 mapTuple f = f *** f - 106 pointToRPoint p = - 107 case mapTuple (toUserUnit defaultDPI) p of - 108 (Num x, Num y) -> V2 x y - 109 _ -> error "Reanimate.Svg.svgBoundingPoints: Unrecognized number format." - 110 - 111 circleBoundingPoints circ = - 112 let (xnum, ynum) = circ ^. circleCenter - 113 rnum = circ ^. circleRadius - 114 in case mapMaybe unpackNumber [xnum, ynum, rnum] of - 115 [x, y, r] -> [ V2 (x + r * cos angle) (y + r * sin angle) | angle <- [0, pi/10 .. 2 * pi]] - 116 _ -> [] - 117 - 118 ellipseBoundingPoints e = - 119 let (xnum,ynum) = e ^. ellipseCenter - 120 xrnum = e ^. ellipseXRadius - 121 yrnum = e ^. ellipseYRadius - 122 in case mapMaybe unpackNumber [xnum, ynum, xrnum, yrnum] of - 123 [x,y,xr,yr] -> [V2 (x + xr * cos angle) (y + yr * sin angle) | angle <- [0, pi/10 .. 2 * pi]] - 124 _ -> [] - 125 - 126 unpackNumber n = - 127 case toUserUnit defaultDPI n of - 128 Num d -> Just d - 129 _ -> Nothing + 70 let bezier = Bezier.AnyBezier (V.fromList (from:ctrl)) + 71 in [ Bezier.evalBezier bezier (recip chunks*i) | i <- [0..chunks]] ++ + 72 worker (last ctrl) xs + 73 LineEnd p -> p : worker p xs + 74 chunks = 10 + 75 + 76 svgBoundingPoints :: Tree -> [RPoint] + 77 svgBoundingPoints t = map (Transform.transformPoint m) $ + 78 case t of + 79 None -> [] + 80 UseTree{} -> [] + 81 GroupTree g -> concatMap svgBoundingPoints (g^.groupChildren) + 82 SymbolTree (Symbol g) -> concatMap svgBoundingPoints (g^.groupChildren) + 83 FilterTree{} -> [] + 84 DefinitionTree{} -> [] + 85 PathTree p -> linePoints $ toLineCommands (p^.pathDefinition) + 86 CircleTree c -> circleBoundingPoints c + 87 PolyLineTree pl -> pl ^. polyLinePoints + 88 EllipseTree e -> ellipseBoundingPoints e + 89 LineTree line -> map pointToRPoint [line^.linePoint1, line^.linePoint2] + 90 RectangleTree rect -> + 91 case pointToRPoint (rect^.rectUpperLeftCorner) of + 92 V2 x y -> V2 x y : + 93 case mapTuple (fmap $ toUserUnit defaultDPI) (rect^.rectWidth, rect^.rectHeight) of + 94 (Just (Num w), Just (Num h)) -> [V2 (x+w) (y+h)] + 95 _ -> [] + 96 TextTree{} -> [] + 97 ImageTree img -> + 98 case (img^.imageCornerUpperLeft, img^.imageWidth, img^.imageHeight) of + 99 ((Num x, Num y), Num w, Num h) -> + 100 [V2 x y, V2 (x+w) (y+h)] + 101 _ -> [] + 102 MeshGradientTree{} -> [] + 103 _ -> [] + 104 where + 105 m = Transform.mkMatrix (t^.transform) + 106 mapTuple f = f *** f + 107 pointToRPoint p = + 108 case mapTuple (toUserUnit defaultDPI) p of + 109 (Num x, Num y) -> V2 x y + 110 _ -> error "Reanimate.Svg.svgBoundingPoints: Unrecognized number format." + 111 + 112 circleBoundingPoints circ = + 113 let (xnum, ynum) = circ ^. circleCenter + 114 rnum = circ ^. circleRadius + 115 in case mapMaybe unpackNumber [xnum, ynum, rnum] of + 116 [x, y, r] -> [ V2 (x + r * cos angle) (y + r * sin angle) | angle <- [0, pi/10 .. 2 * pi]] + 117 _ -> [] + 118 + 119 ellipseBoundingPoints e = + 120 let (xnum,ynum) = e ^. ellipseCenter + 121 xrnum = e ^. ellipseXRadius + 122 yrnum = e ^. ellipseYRadius + 123 in case mapMaybe unpackNumber [xnum, ynum, xrnum, yrnum] of + 124 [x,y,xr,yr] -> [V2 (x + xr * cos angle) (y + yr * sin angle) | angle <- [0, pi/10 .. 2 * pi]] + 125 _ -> [] + 126 + 127 unpackNumber n = + 128 case toUserUnit defaultDPI n of + 129 Num d -> Just d + 130 _ -> Nothing diff --git a/reanimate-0.4.1.0-inplace/Reanimate.Svg.LineCommand.hs.html b/reanimate-0.4.1.0-inplace/Reanimate.Svg.LineCommand.hs.html index 3ff0961..9676d24 100644 --- a/reanimate-0.4.1.0-inplace/Reanimate.Svg.LineCommand.hs.html +++ b/reanimate-0.4.1.0-inplace/Reanimate.Svg.LineCommand.hs.html @@ -17,267 +17,283 @@ span.spaces { background: white } never executed always true always false 
-    1 module Reanimate.Svg.LineCommand where
-    2 
-    3 import           Control.Lens        ((%~), (&), (.~))
-    4 import           Control.Monad.Fix
-    5 import           Control.Monad.State
-    6 import           Data.Functor
-    7 import qualified Data.Vector.Unboxed as V
-    8 import qualified Geom2D.CubicBezier.Linear as Bezier
-    9 import           Graphics.SvgTree    hiding (height, line, path, use, width)
-   10 import           Linear.Metric
-   11 import           Linear.V2           hiding (angle)
-   12 import           Linear.Vector
-   13 
-   14 type CmdM a = State RPoint a
-   15 
-   16 data LineCommand
-   17   = LineMove RPoint
-   18   -- | LineDraw RPoint
-   19   | LineBezier [RPoint]
-   20   | LineEnd RPoint
-   21   deriving (Show)
-   22 
-   23 lineToPath :: [LineCommand] -> [PathCommand]
-   24 lineToPath = map worker
-   25   where
-   26     worker (LineMove p)         = MoveTo OriginAbsolute [p]
-   27     -- worker (LineDraw p)         = LineTo OriginAbsolute [p]
-   28     worker (LineBezier [a,b,c]) = CurveTo OriginAbsolute [(a,b,c)]
-   29     worker (LineBezier [a,b])   = QuadraticBezier OriginAbsolute [(a,b)]
-   30     worker (LineBezier [a])     = LineTo OriginAbsolute [a]
-   31     worker LineBezier{}         = error "Reanimate.Svg.lineToPath: invalid bezier curve"
-   32     worker LineEnd{}            = EndPath
-   33 
-   34 lineToPoints :: Int -> [LineCommand] -> [RPoint]
-   35 lineToPoints nPoints cmds =
-   36     map lineEnd lineSegments
-   37   where
-   38     lineSegments = [ partialLine (fromIntegral n/ fromIntegral nPoints) cmds | n <- [0 .. nPoints-1] ]
-   39     lineEnd [LineBezier pts] = last pts
-   40     lineEnd (_:xs)           = lineEnd xs
-   41     lineEnd _                = error "invalid line"
-   42 
-   43 partialLine :: Double -> [LineCommand] -> [LineCommand]
-   44 partialLine alpha cmds = evalState (worker 0 cmds) zero
-   45   where
-   46     worker _d [] = pure []
-   47     worker d (cmd:xs) = do
-   48       from <- get
-   49       len <- lineLength cmd
-   50       let frac = (targetLen-d) / len
-   51       if len == 0 || frac >= 1
-   52         then (cmd:) <$> worker (d+len) xs
-   53         else pure [adjustLineLength frac from cmd]
-   54     totalLen = evalState (sum <$> mapM lineLength cmds) zero
-   55     targetLen = totalLen * alpha
-   56 
-   57 adjustLineLength :: Double -> RPoint -> LineCommand -> LineCommand
-   58 adjustLineLength alpha from cmd =
-   59   case cmd of
-   60     LineBezier points -> LineBezier $ drop 1 $ partialBezierPoints (from:points) 0 alpha
-   61     LineMove p -> LineMove p
-   62     -- LineDraw t -> LineDraw (lerp alpha t from)
-   63     LineEnd p -> LineBezier [lerp alpha p from]
-   64 
-   65 lineLength :: LineCommand -> CmdM Double
-   66 lineLength cmd =
-   67   case cmd of
-   68     LineMove to       -> 0 <$ put to
-   69     -- Straight line:
-   70     LineBezier [dst] -> gets (distance dst) <* put dst
-   71     -- Some kind of curve:
-   72     LineBezier lst -> do
-   73       from <- get
-   74       let bezier = rpointsToBezier (from:lst)
-   75           tol = 0.0001
-   76       put (last lst)
-   77       pure $ Bezier.arcLength bezier 1 tol
-   78     LineEnd to        -> gets (distance to) <* put to
-   79 
-   80 rpointsToBezier :: [RPoint] -> Bezier.CubicBezier Double
-   81 rpointsToBezier lst =
-   82   case lst of
-   83     [a,b] -> Bezier.CubicBezier a a b b
-   84     [a,b,c] -> Bezier.quadToCubic (Bezier.QuadBezier a b c)
-   85     [a,b,c,d] -> Bezier.CubicBezier a b c d
-   86     _ -> error $ "rpointsToBezier: Invalid list of points: " ++ show lst
-   87 
-   88 toLineCommands :: [PathCommand] -> [LineCommand]
-   89 toLineCommands ps = evalState (worker zero Nothing ps) zero
-   90   where
-   91     worker _startPos _mbPrevControlPt [] = pure []
-   92     worker startPos mbPrevControlPt (cmd:cmds) = do
-   93       lcmds <- toLineCommand startPos mbPrevControlPt cmd
-   94       let startPos' =
-   95             case lcmds of
-   96               [LineMove pos] -> pos
-   97               _              -> startPos
-   98       (lcmds++) <$> worker startPos' (cmdToControlPoint $ last lcmds) cmds
-   99 
-  100 cmdToControlPoint :: LineCommand -> Maybe RPoint
-  101 cmdToControlPoint (LineBezier points) = Just (last (init points))
-  102 cmdToControlPoint _                   = Nothing
-  103 
-  104 mkStraightLine :: RPoint -> LineCommand
-  105 mkStraightLine p = LineBezier [p]
-  106 
-  107 toLineCommand :: RPoint -> Maybe RPoint -> PathCommand -> CmdM [LineCommand]
-  108 toLineCommand startPos mbPrevControlPt cmd =
-  109   case cmd of
-  110     MoveTo OriginAbsolute []  -> pure []
-  111     MoveTo OriginAbsolute lst -> put (last lst) *> gets (pure.LineMove)
-  112     MoveTo OriginRelative lst -> modify (+ sum lst) *> gets (pure.LineMove)
-  113     LineTo OriginAbsolute lst -> forM lst (\to -> put to $> mkStraightLine to)
-  114     LineTo OriginRelative lst -> forM lst (\to -> modify (+to) *> gets mkStraightLine)
-  115     HorizontalTo OriginAbsolute lst ->
-  116       forM lst $ \x -> modify (_x .~ x) *> gets mkStraightLine
-  117     HorizontalTo OriginRelative lst ->
-  118       forM lst $ \x -> modify (_x %~ (+x)) *> gets mkStraightLine
-  119     VerticalTo OriginAbsolute lst ->
-  120       forM lst $ \y -> modify (_y .~ y) *> gets mkStraightLine
-  121     VerticalTo OriginRelative lst ->
-  122       forM lst $ \y -> modify (_y %~ (+y)) *> gets mkStraightLine
-  123     CurveTo OriginAbsolute quads ->
-  124       forM quads $ \(a,b,c) -> put c $> LineBezier [a,b,c]
-  125     CurveTo OriginRelative quads ->
-  126       forM quads $ \(a,b,c) -> do
-  127         from <- get <* modify (+c)
-  128         pure $ LineBezier $ map (+from) [a,b,c]
-  129     SmoothCurveTo o lst -> mfix $ \result -> do
-  130       let ctrl = mbPrevControlPt : map cmdToControlPoint result
-  131       forM (zip lst ctrl) $ \((c2,to), mbControl) -> do
-  132         from <- get <* adjustPosition o to
-  133         let c1 = maybe (makeAbsolute o from c2) (mirrorPoint from) mbControl
-  134         pure $ LineBezier [c1,makeAbsolute o from c2,makeAbsolute o from to]
-  135     QuadraticBezier OriginAbsolute pairs ->
-  136       forM pairs $ \(a,b) -> put b $> LineBezier [a,b]
-  137     QuadraticBezier OriginRelative pairs ->
-  138       forM pairs $ \(a,b) -> do
-  139         from <- get <* modify (+b)
-  140         pure $ LineBezier $ map (+from) [a,b]
-  141     SmoothQuadraticBezierCurveTo o lst -> mfix $ \result -> do
-  142       let ctrl = mbPrevControlPt : map cmdToControlPoint result
-  143       forM (zip lst ctrl) $ \(to, mbControl) -> do
-  144         from <- get <* adjustPosition o to
-  145         let c1 = maybe from (mirrorPoint from) mbControl
-  146         pure $ LineBezier [c1,makeAbsolute o from to]
-  147     EllipticalArc o points -> concat <$>
-  148       forM points (\(rotX, rotY, angle, largeArc, sweepFlag, to) -> do
-  149         from <- get <* adjustPosition o to
-  150         return $ convertSvgArc from rotX rotY angle largeArc sweepFlag (makeAbsolute o from to))
-  151     EndPath -> put startPos $> [LineEnd startPos]
-  152   where
-  153     mirrorPoint c p = c*2-p
-  154     adjustPosition OriginRelative p = modify (+p)
-  155     adjustPosition OriginAbsolute p = put p
-  156     makeAbsolute OriginAbsolute _from p = p
-  157     makeAbsolute OriginRelative from p  = from+p
-  158 
-  159 
-  160 calculateVectorAngle :: Double -> Double -> Double -> Double -> Double
-  161 calculateVectorAngle ux uy vx vy
-  162     | tb >= ta
-  163         = tb - ta
-  164     | otherwise
-  165         = pi * 2 - (ta - tb)
-  166     where
-  167         ta = atan2 uy ux
-  168         tb = atan2 vy vx
-  169 
-  170 -- ported from: https://github.com/vvvv/SVG/blob/master/Source/Paths/SvgArcSegment.cs
-  171 {- HLINT ignore convertSvgArc -}
-  172 convertSvgArc :: RPoint -> Coord -> Coord -> Coord -> Bool -> Bool -> RPoint -> [LineCommand]
-  173 convertSvgArc (V2 x0 y0) radiusX radiusY angle largeArcFlag sweepFlag (V2 x y)
-  174     | x0 == x && y0 == y
-  175         = []
-  176     | radiusX == 0.0 && radiusY == 0.0
-  177         = [LineBezier [V2 x y]]
-  178     | otherwise
-  179         = calcSegments x0 y0 theta1' segments'
-  180     where
-  181         sinPhi = sin (angle * pi/180)
-  182         cosPhi = cos (angle * pi/180)
-  183 
-  184         x1dash = cosPhi * (x0 - x) / 2.0 + sinPhi * (y0 - y) / 2.0
-  185         y1dash = -sinPhi * (x0 - x) / 2.0 + cosPhi * (y0 - y) / 2.0
-  186 
-  187         numerator = radiusX * radiusX * radiusY * radiusY - radiusX * radiusX * y1dash * y1dash - radiusY * radiusY * x1dash * x1dash
-  188 
-  189         s = sqrt(1.0 - numerator / (radiusX * radiusX * radiusY * radiusY))
-  190         rx   = if (numerator < 0.0) then (radiusX * s) else radiusX
-  191         ry   = if (numerator < 0.0) then (radiusY * s) else radiusY
-  192         root = if (numerator < 0.0)
-  193                 then (0.0)
-  194                 else ((if ((largeArcFlag && sweepFlag) || (not largeArcFlag && not sweepFlag)) then (-1.0) else 1.0) *
-  195                         sqrt(numerator / (radiusX * radiusX * y1dash * y1dash + radiusY * radiusY * x1dash * x1dash)))
-  196 
-  197         cxdash = root * rx * y1dash / ry
-  198         cydash = -root * ry * x1dash / rx
-  199 
-  200         cx = cosPhi * cxdash - sinPhi * cydash + (x0 + x) / 2.0
-  201         cy = sinPhi * cxdash + cosPhi * cydash + (y0 + y) / 2.0
+    1 {-|
+    2 Copyright   : Written by David Himmelstrup
+    3 License     : Unlicense
+    4 Maintainer  : lemmih@gmail.com
+    5 Stability   : experimental
+    6 Portability : POSIX
+    7 -}
+    8 module Reanimate.Svg.LineCommand
+    9   ( LineCommand(..)
+   10   , lineLength
+   11   , toLineCommands
+   12   , lineToPath
+   13   , lineToPoints
+   14   , partialSvg
+   15   ) where
+   16 
+   17 import           Control.Lens              ((%~), (&), (.~))
+   18 import           Control.Monad.Fix
+   19 import           Control.Monad.State
+   20 import           Data.Functor
+   21 import qualified Data.Vector.Unboxed       as V
+   22 import qualified Geom2D.CubicBezier.Linear as Bezier
+   23 import           Graphics.SvgTree          hiding (height, line, path, use, width)
+   24 import           Linear.Metric
+   25 import           Linear.V2                 hiding (angle)
+   26 import           Linear.Vector
+   27 
+   28 type CmdM a = State RPoint a
+   29 
+   30 -- | Simplified version of a PathCommand where all points are absolute.
+   31 data LineCommand
+   32   = LineMove RPoint
+   33   -- | LineDraw RPoint
+   34   | LineBezier [RPoint]
+   35   | LineEnd RPoint
+   36   deriving (Show)
+   37 
+   38 -- | Convert from line commands to path commands.
+   39 lineToPath :: [LineCommand] -> [PathCommand]
+   40 lineToPath = map worker
+   41   where
+   42     worker (LineMove p)         = MoveTo OriginAbsolute [p]
+   43     -- worker (LineDraw p)         = LineTo OriginAbsolute [p]
+   44     worker (LineBezier [a,b,c]) = CurveTo OriginAbsolute [(a,b,c)]
+   45     worker (LineBezier [a,b])   = QuadraticBezier OriginAbsolute [(a,b)]
+   46     worker (LineBezier [a])     = LineTo OriginAbsolute [a]
+   47     worker LineBezier{}         = error "Reanimate.Svg.lineToPath: invalid bezier curve"
+   48     worker LineEnd{}            = EndPath
+   49 
+   50 -- | Using @n@ control points, approximate the path of the curves.
+   51 lineToPoints :: Int -> [LineCommand] -> [RPoint]
+   52 lineToPoints nPoints cmds =
+   53     map lineEnd lineSegments
+   54   where
+   55     lineSegments = [ partialLine (fromIntegral n/ fromIntegral nPoints) cmds | n <- [0 .. nPoints-1] ]
+   56     lineEnd [LineBezier pts] = last pts
+   57     lineEnd (_:xs)           = lineEnd xs
+   58     lineEnd _                = error "invalid line"
+   59 
+   60 partialLine :: Double -> [LineCommand] -> [LineCommand]
+   61 partialLine alpha cmds = evalState (worker 0 cmds) zero
+   62   where
+   63     worker _d [] = pure []
+   64     worker d (cmd:xs) = do
+   65       from <- get
+   66       len <- lineLength cmd
+   67       let frac = (targetLen-d) / len
+   68       if len == 0 || frac >= 1
+   69         then (cmd:) <$> worker (d+len) xs
+   70         else pure [adjustLineLength frac from cmd]
+   71     totalLen = evalState (sum <$> mapM lineLength cmds) zero
+   72     targetLen = totalLen * alpha
+   73 
+   74 adjustLineLength :: Double -> RPoint -> LineCommand -> LineCommand
+   75 adjustLineLength alpha from cmd =
+   76   case cmd of
+   77     LineBezier points -> LineBezier $ drop 1 $ partialBezierPoints (from:points) 0 alpha
+   78     LineMove p        -> LineMove p
+   79     -- LineDraw t -> LineDraw (lerp alpha t from)
+   80     LineEnd p         -> LineBezier [lerp alpha p from]
+   81 
+   82 -- | Estimated length of all segments in a line.
+   83 lineLength :: LineCommand -> CmdM Double
+   84 lineLength cmd =
+   85   case cmd of
+   86     LineMove to       -> 0 <$ put to
+   87     -- Straight line:
+   88     LineBezier [dst] -> gets (distance dst) <* put dst
+   89     -- Some kind of curve:
+   90     LineBezier lst -> do
+   91       from <- get
+   92       let bezier = rpointsToBezier (from:lst)
+   93           tol = 0.0001
+   94       put (last lst)
+   95       pure $ Bezier.arcLength bezier 1 tol
+   96     LineEnd to        -> gets (distance to) <* put to
+   97 
+   98 rpointsToBezier :: [RPoint] -> Bezier.CubicBezier Double
+   99 rpointsToBezier lst =
+  100   case lst of
+  101     [a,b]     -> Bezier.CubicBezier a a b b
+  102     [a,b,c]   -> Bezier.quadToCubic (Bezier.QuadBezier a b c)
+  103     [a,b,c,d] -> Bezier.CubicBezier a b c d
+  104     _         -> error $ "rpointsToBezier: Invalid list of points: " ++ show lst
+  105 
+  106 -- | Convert from path commands to line commands.
+  107 toLineCommands :: [PathCommand] -> [LineCommand]
+  108 toLineCommands ps = evalState (worker zero Nothing ps) zero
+  109   where
+  110     worker _startPos _mbPrevControlPt [] = pure []
+  111     worker startPos mbPrevControlPt (cmd:cmds) = do
+  112       lcmds <- toLineCommand startPos mbPrevControlPt cmd
+  113       let startPos' =
+  114             case lcmds of
+  115               [LineMove pos] -> pos
+  116               _              -> startPos
+  117       (lcmds++) <$> worker startPos' (cmdToControlPoint $ last lcmds) cmds
+  118 
+  119 cmdToControlPoint :: LineCommand -> Maybe RPoint
+  120 cmdToControlPoint (LineBezier points) = Just (last (init points))
+  121 cmdToControlPoint _                   = Nothing
+  122 
+  123 mkStraightLine :: RPoint -> LineCommand
+  124 mkStraightLine p = LineBezier [p]
+  125 
+  126 toLineCommand :: RPoint -> Maybe RPoint -> PathCommand -> CmdM [LineCommand]
+  127 toLineCommand startPos mbPrevControlPt cmd =
+  128   case cmd of
+  129     MoveTo OriginAbsolute []  -> pure []
+  130     MoveTo OriginAbsolute lst -> put (last lst) *> gets (pure.LineMove)
+  131     MoveTo OriginRelative lst -> modify (+ sum lst) *> gets (pure.LineMove)
+  132     LineTo OriginAbsolute lst -> forM lst (\to -> put to $> mkStraightLine to)
+  133     LineTo OriginRelative lst -> forM lst (\to -> modify (+to) *> gets mkStraightLine)
+  134     HorizontalTo OriginAbsolute lst ->
+  135       forM lst $ \x -> modify (_x .~ x) *> gets mkStraightLine
+  136     HorizontalTo OriginRelative lst ->
+  137       forM lst $ \x -> modify (_x %~ (+x)) *> gets mkStraightLine
+  138     VerticalTo OriginAbsolute lst ->
+  139       forM lst $ \y -> modify (_y .~ y) *> gets mkStraightLine
+  140     VerticalTo OriginRelative lst ->
+  141       forM lst $ \y -> modify (_y %~ (+y)) *> gets mkStraightLine
+  142     CurveTo OriginAbsolute quads ->
+  143       forM quads $ \(a,b,c) -> put c $> LineBezier [a,b,c]
+  144     CurveTo OriginRelative quads ->
+  145       forM quads $ \(a,b,c) -> do
+  146         from <- get <* modify (+c)
+  147         pure $ LineBezier $ map (+from) [a,b,c]
+  148     SmoothCurveTo o lst -> mfix $ \result -> do
+  149       let ctrl = mbPrevControlPt : map cmdToControlPoint result
+  150       forM (zip lst ctrl) $ \((c2,to), mbControl) -> do
+  151         from <- get <* adjustPosition o to
+  152         let c1 = maybe (makeAbsolute o from c2) (mirrorPoint from) mbControl
+  153         pure $ LineBezier [c1,makeAbsolute o from c2,makeAbsolute o from to]
+  154     QuadraticBezier OriginAbsolute pairs ->
+  155       forM pairs $ \(a,b) -> put b $> LineBezier [a,b]
+  156     QuadraticBezier OriginRelative pairs ->
+  157       forM pairs $ \(a,b) -> do
+  158         from <- get <* modify (+b)
+  159         pure $ LineBezier $ map (+from) [a,b]
+  160     SmoothQuadraticBezierCurveTo o lst -> mfix $ \result -> do
+  161       let ctrl = mbPrevControlPt : map cmdToControlPoint result
+  162       forM (zip lst ctrl) $ \(to, mbControl) -> do
+  163         from <- get <* adjustPosition o to
+  164         let c1 = maybe from (mirrorPoint from) mbControl
+  165         pure $ LineBezier [c1,makeAbsolute o from to]
+  166     EllipticalArc o points -> concat <$>
+  167       forM points (\(rotX, rotY, angle, largeArc, sweepFlag, to) -> do
+  168         from <- get <* adjustPosition o to
+  169         return $ convertSvgArc from rotX rotY angle largeArc sweepFlag (makeAbsolute o from to))
+  170     EndPath -> put startPos $> [LineEnd startPos]
+  171   where
+  172     mirrorPoint c p = c*2-p
+  173     adjustPosition OriginRelative p = modify (+p)
+  174     adjustPosition OriginAbsolute p = put p
+  175     makeAbsolute OriginAbsolute _from p = p
+  176     makeAbsolute OriginRelative from p  = from+p
+  177 
+  178 
+  179 calculateVectorAngle :: Double -> Double -> Double -> Double -> Double
+  180 calculateVectorAngle ux uy vx vy
+  181     | tb >= ta
+  182         = tb - ta
+  183     | otherwise
+  184         = pi * 2 - (ta - tb)
+  185     where
+  186         ta = atan2 uy ux
+  187         tb = atan2 vy vx
+  188 
+  189 -- ported from: https://github.com/vvvv/SVG/blob/master/Source/Paths/SvgArcSegment.cs
+  190 {- HLINT ignore convertSvgArc -}
+  191 convertSvgArc :: RPoint -> Coord -> Coord -> Coord -> Bool -> Bool -> RPoint -> [LineCommand]
+  192 convertSvgArc (V2 x0 y0) radiusX radiusY angle largeArcFlag sweepFlag (V2 x y)
+  193     | x0 == x && y0 == y
+  194         = []
+  195     | radiusX == 0.0 && radiusY == 0.0
+  196         = [LineBezier [V2 x y]]
+  197     | otherwise
+  198         = calcSegments x0 y0 theta1' segments'
+  199     where
+  200         sinPhi = sin (angle * pi/180)
+  201         cosPhi = cos (angle * pi/180)
   202 
-  203         theta1'  = calculateVectorAngle 1.0 0.0 ((x1dash - cxdash) / rx) ((y1dash - cydash) / ry)
-  204         dtheta' = calculateVectorAngle ((x1dash - cxdash) / rx) ((y1dash - cydash) / ry) ((-x1dash - cxdash) / rx) ((-y1dash - cydash) / ry)
-  205         dtheta  = if (not sweepFlag && dtheta' > 0)
-  206                     then  (dtheta' - 2 * pi)
-  207                     else  (if (sweepFlag && dtheta' < 0) then dtheta' + 2 * pi else dtheta')
-  208 
-  209         segments' = ceiling (abs (dtheta / (pi / 2.0)))
-  210         delta = dtheta / fromInteger segments'
-  211         t = 8.0 / 3.0 * sin(delta / 4.0) * sin(delta / 4.0) / sin(delta / 2.0)
-  212 
-  213         calcSegments startX startY theta1 segments
-  214             | segments == 0
-  215                 = []
-  216             | otherwise
-  217                 = LineBezier [ V2 (startX + dx1) (startY + dy1)
-  218                              , V2 (endpointX + dxe) (endpointY + dye)
-  219                              , V2 endpointX endpointY ] : calcSegments endpointX endpointY theta2 (segments - 1)
-  220             where
-  221                 cosTheta1 = cos theta1
-  222                 sinTheta1 = sin theta1
-  223                 theta2 = theta1 + delta
-  224                 cosTheta2 = cos theta2
-  225                 sinTheta2 = sin theta2
-  226 
-  227                 endpointX = cosPhi * rx * cosTheta2 - sinPhi * ry * sinTheta2 + cx
-  228                 endpointY = sinPhi * rx * cosTheta2 + cosPhi * ry * sinTheta2 + cy
-  229 
-  230                 dx1 = t * (-cosPhi * rx * sinTheta1 - sinPhi * ry * cosTheta1)
-  231                 dy1 = t * (-sinPhi * rx * sinTheta1 + cosPhi * ry * cosTheta1)
-  232 
-  233                 dxe = t * (cosPhi * rx * sinTheta2 + sinPhi * ry * cosTheta2)
-  234                 dye = t * (sinPhi * rx * sinTheta2 - cosPhi * ry * cosTheta2)
-  235 
-  236 partialBezierPoints :: [RPoint] -> Double -> Double -> [RPoint]
-  237 partialBezierPoints ps a b =
-  238   let c1 = Bezier.AnyBezier (V.fromList ps)
-  239       Bezier.AnyBezier os = Bezier.bezierSubsegment c1 a b
-  240   in V.toList os
-  241 
-  242 interpolatePathCommands :: Double -> [PathCommand] -> [PathCommand]
-  243 interpolatePathCommands alpha = lineToPath . partialLine alpha . toLineCommands
-  244 
-  245 {- | Create an image showing portion of a path.
-  246      Note that this only affects paths (see 'Reanimate.Svg.Constructors.mkPath').
-  247      You can also use this with other SVG shapes if you convert them to path first (see 'Reanimate.Svg.pathify').
-  248 
-  249      Typical usage:
-  250 
-  251     > animate $ \t -> partialSvg t myPath
-  252 -}
-  253 partialSvg :: Double -- ^ number between 0 and 1 inclusively, determining what portion of the path to show
-  254            -> Tree -- ^ Image representing a path, of which we only want to display a portion determined by the first argument
-  255            -> Tree
-  256 partialSvg alpha | alpha >= 1 = id
-  257 partialSvg alpha = mapTree worker
-  258   where
-  259     worker (PathTree path) =
-  260       PathTree $ path & pathDefinition %~ lineToPath . partialLine alpha . toLineCommands
-  261     worker t = t
+  203         x1dash = cosPhi * (x0 - x) / 2.0 + sinPhi * (y0 - y) / 2.0
+  204         y1dash = -sinPhi * (x0 - x) / 2.0 + cosPhi * (y0 - y) / 2.0
+  205 
+  206         numerator = radiusX * radiusX * radiusY * radiusY - radiusX * radiusX * y1dash * y1dash - radiusY * radiusY * x1dash * x1dash
+  207 
+  208         s = sqrt(1.0 - numerator / (radiusX * radiusX * radiusY * radiusY))
+  209         rx   = if (numerator < 0.0) then (radiusX * s) else radiusX
+  210         ry   = if (numerator < 0.0) then (radiusY * s) else radiusY
+  211         root = if (numerator < 0.0)
+  212                 then (0.0)
+  213                 else ((if ((largeArcFlag && sweepFlag) || (not largeArcFlag && not sweepFlag)) then (-1.0) else 1.0) *
+  214                         sqrt(numerator / (radiusX * radiusX * y1dash * y1dash + radiusY * radiusY * x1dash * x1dash)))
+  215 
+  216         cxdash = root * rx * y1dash / ry
+  217         cydash = -root * ry * x1dash / rx
+  218 
+  219         cx = cosPhi * cxdash - sinPhi * cydash + (x0 + x) / 2.0
+  220         cy = sinPhi * cxdash + cosPhi * cydash + (y0 + y) / 2.0
+  221 
+  222         theta1'  = calculateVectorAngle 1.0 0.0 ((x1dash - cxdash) / rx) ((y1dash - cydash) / ry)
+  223         dtheta' = calculateVectorAngle ((x1dash - cxdash) / rx) ((y1dash - cydash) / ry) ((-x1dash - cxdash) / rx) ((-y1dash - cydash) / ry)
+  224         dtheta  = if (not sweepFlag && dtheta' > 0)
+  225                     then  (dtheta' - 2 * pi)
+  226                     else  (if (sweepFlag && dtheta' < 0) then dtheta' + 2 * pi else dtheta')
+  227 
+  228         segments' = ceiling (abs (dtheta / (pi / 2.0)))
+  229         delta = dtheta / fromInteger segments'
+  230         t = 8.0 / 3.0 * sin(delta / 4.0) * sin(delta / 4.0) / sin(delta / 2.0)
+  231 
+  232         calcSegments startX startY theta1 segments
+  233             | segments == 0
+  234                 = []
+  235             | otherwise
+  236                 = LineBezier [ V2 (startX + dx1) (startY + dy1)
+  237                              , V2 (endpointX + dxe) (endpointY + dye)
+  238                              , V2 endpointX endpointY ] : calcSegments endpointX endpointY theta2 (segments - 1)
+  239             where
+  240                 cosTheta1 = cos theta1
+  241                 sinTheta1 = sin theta1
+  242                 theta2 = theta1 + delta
+  243                 cosTheta2 = cos theta2
+  244                 sinTheta2 = sin theta2
+  245 
+  246                 endpointX = cosPhi * rx * cosTheta2 - sinPhi * ry * sinTheta2 + cx
+  247                 endpointY = sinPhi * rx * cosTheta2 + cosPhi * ry * sinTheta2 + cy
+  248 
+  249                 dx1 = t * (-cosPhi * rx * sinTheta1 - sinPhi * ry * cosTheta1)
+  250                 dy1 = t * (-sinPhi * rx * sinTheta1 + cosPhi * ry * cosTheta1)
+  251 
+  252                 dxe = t * (cosPhi * rx * sinTheta2 + sinPhi * ry * cosTheta2)
+  253                 dye = t * (sinPhi * rx * sinTheta2 - cosPhi * ry * cosTheta2)
+  254 
+  255 partialBezierPoints :: [RPoint] -> Double -> Double -> [RPoint]
+  256 partialBezierPoints ps a b =
+  257   let c1 = Bezier.AnyBezier (V.fromList ps)
+  258       Bezier.AnyBezier os = Bezier.bezierSubsegment c1 a b
+  259   in V.toList os
+  260 
+  261 {- | Create an image showing portion of a path.
+  262      Note that this only affects paths (see 'Reanimate.Svg.Constructors.mkPath').
+  263      You can also use this with other SVG shapes if you convert them to path first (see 'Reanimate.Svg.pathify').
+  264 
+  265      Typical usage:
+  266 
+  267     > animate $ \t -> partialSvg t myPath
+  268 -}
+  269 partialSvg :: Double -- ^ number between 0 and 1 inclusively, determining what portion of the path to show
+  270            -> Tree -- ^ Image representing a path, of which we only want to display a portion determined by the first argument
+  271            -> Tree
+  272 partialSvg alpha | alpha >= 1 = id
+  273 partialSvg alpha = mapTree worker
+  274   where
+  275     worker (PathTree path) =
+  276       PathTree $ path & pathDefinition %~ lineToPath . partialLine alpha . toLineCommands
+  277     worker t = t
diff --git a/reanimate-0.4.1.0-inplace/Reanimate.Transform.hs.html b/reanimate-0.4.1.0-inplace/Reanimate.Transform.hs.html index f830464..a1b9996 100644 --- a/reanimate-0.4.1.0-inplace/Reanimate.Transform.hs.html +++ b/reanimate-0.4.1.0-inplace/Reanimate.Transform.hs.html @@ -37,57 +37,55 @@ span.spaces { background: white } 18 import Graphics.SvgTree 19 import Linear.V2 20 - 21 type TMatrix = Matrix Coord - 22 - 23 -- | Identity matrix. - 24 -- - 25 -- @transformPoints identity x = x@ - 26 identity :: TMatrix - 27 identity = M.identity 3 - 28 - 29 fromList :: [Coord] -> TMatrix - 30 fromList [a,b,c,d,e,f] = M.fromList 3 3 [a,c,e,b,d,f,0,0,1] - 31 fromList _ = error "Reanimate.Transform.fromList: bad input" - 32 - 33 -- | Apply a transformation matrix to a 2D point. - 34 transformPoint :: TMatrix -> RPoint -> RPoint - 35 transformPoint m (V2 x y) = V2 (a*x +c*y + e) (b*x + d*y +f) - 36 where - 37 !a = M.unsafeGet 1 1 m - 38 !c = M.unsafeGet 1 2 m - 39 !e = M.unsafeGet 1 3 m - 40 !b = M.unsafeGet 2 1 m - 41 !d = M.unsafeGet 2 2 m - 42 !f = M.unsafeGet 2 3 m - 43 -- (a:c:e:b:d:f:_) = M.toList m - 44 - 45 -- | Convert multiple SVG transformations into a single transformation matrix. - 46 mkMatrix :: Maybe [Transformation] -> TMatrix - 47 mkMatrix Nothing = identity - 48 mkMatrix (Just ts) = foldl' (*) identity (map transformationMatrix ts) - 49 - 50 -- | Convert an SVG transformation into a transformation matrix. - 51 transformationMatrix :: Transformation -> TMatrix - 52 transformationMatrix transformation = - 53 case transformation of - 54 TransformMatrix a b c d e f -> fromList [a,b,c,d,e,f] - 55 Translate x y -> translate x y - 56 Scale sx mbSy -> fromList [sx,0,0,fromMaybe sx mbSy,0,0] - 57 Rotate a Nothing -> rotate a - 58 Rotate a (Just (x,y)) -> translate x y * rotate a * translate (-x) (-y) - 59 SkewX a -> fromList [1,0,tan (a*pi/180),1,0,0] - 60 SkewY a -> fromList [1,tan (a*pi/180),0,1,0,0] - 61 TransformUnknown -> identity - 62 where - 63 translate x y = fromList [1,0,0,1,x,y] - 64 rotate a = fromList [cos r,sin r,-sin r,cos r,0,0] - 65 where r = a * pi / 180 - 66 - 67 -- | Convert a transformation matrix back into an SVG transformation. - 68 toTransformation :: TMatrix -> Transformation - 69 toTransformation m = TransformMatrix a b c d e f - 70 where - 71 [a,c,e,b,d,f,_,_,_] = M.toList m + 21 -- | Identity matrix. + 22 -- + 23 -- @transformPoints identity x = x@ + 24 identity :: Matrix Coord + 25 identity = M.identity 3 + 26 + 27 fromList :: [Coord] -> Matrix Coord + 28 fromList [a,b,c,d,e,f] = M.fromList 3 3 [a,c,e,b,d,f,0,0,1] + 29 fromList _ = error "Reanimate.Transform.fromList: bad input" + 30 + 31 -- | Apply a transformation matrix to a 2D point. + 32 transformPoint :: Matrix Coord -> RPoint -> RPoint + 33 transformPoint m (V2 x y) = V2 (a*x +c*y + e) (b*x + d*y +f) + 34 where + 35 !a = M.unsafeGet 1 1 m + 36 !c = M.unsafeGet 1 2 m + 37 !e = M.unsafeGet 1 3 m + 38 !b = M.unsafeGet 2 1 m + 39 !d = M.unsafeGet 2 2 m + 40 !f = M.unsafeGet 2 3 m + 41 -- (a:c:e:b:d:f:_) = M.toList m + 42 + 43 -- | Convert multiple SVG transformations into a single transformation matrix. + 44 mkMatrix :: Maybe [Transformation] -> Matrix Coord + 45 mkMatrix Nothing = identity + 46 mkMatrix (Just ts) = foldl' (*) identity (map transformationMatrix ts) + 47 + 48 -- | Convert an SVG transformation into a transformation matrix. + 49 transformationMatrix :: Transformation -> Matrix Coord + 50 transformationMatrix transformation = + 51 case transformation of + 52 TransformMatrix a b c d e f -> fromList [a,b,c,d,e,f] + 53 Translate x y -> translate x y + 54 Scale sx mbSy -> fromList [sx,0,0,fromMaybe sx mbSy,0,0] + 55 Rotate a Nothing -> rotate a + 56 Rotate a (Just (x,y)) -> translate x y * rotate a * translate (-x) (-y) + 57 SkewX a -> fromList [1,0,tan (a*pi/180),1,0,0] + 58 SkewY a -> fromList [1,tan (a*pi/180),0,1,0,0] + 59 TransformUnknown -> identity + 60 where + 61 translate x y = fromList [1,0,0,1,x,y] + 62 rotate a = fromList [cos r,sin r,-sin r,cos r,0,0] + 63 where r = a * pi / 180 + 64 + 65 -- | Convert a transformation matrix back into an SVG transformation. + 66 toTransformation :: Matrix Coord -> Transformation + 67 toTransformation m = TransformMatrix a b c d e f + 68 where + 69 [a,c,e,b,d,f,_,_,_] = M.toList m