mirror of
https://github.com/reanimate/reanimate.git
synced 2026-09-14 09:32:22 +00:00
Deploying to gh-pages from @ dc54936ba4 🚀
This commit is contained in:
Lemmih
parent
4417f2cf54
commit
46be05569e
19 changed files with 2596 additions and 2540 deletions
29
haddock.txt
29
haddock.txt
|
|
@ -6,37 +6,34 @@
|
|||
100% ( 22 / 22) in 'Reanimate.Effect'
|
||||
100% ( 17 / 17) in 'Reanimate.Parameters'
|
||||
100% ( 14 / 14) in 'Reanimate.Raster'
|
||||
100% ( 13 / 13) in 'Reanimate.Morph.Common'
|
||||
100% ( 13 / 13) in 'Reanimate.ColorMap'
|
||||
100% ( 12 / 12) in 'Reanimate.ColorComponents'
|
||||
100% ( 10 / 10) in 'Reanimate.Ease'
|
||||
100% ( 9 / 9) in 'Reanimate.Voice'
|
||||
100% ( 9 / 9) in 'Reanimate.Povray'
|
||||
100% ( 9 / 9) in 'Reanimate.Constants'
|
||||
100% ( 8 / 8) in 'Reanimate.Transition'
|
||||
100% ( 8 / 8) in 'Reanimate.Builtin.TernaryPlot'
|
||||
100% ( 7 / 7) in 'Reanimate.Builtin.Documentation'
|
||||
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% ( 3 / 3) in 'Reanimate.Math.Balloon'
|
||||
100% ( 3 / 3) in 'Reanimate.Blender'
|
||||
100% ( 2 / 2) in 'Reanimate.Builtin.CirclePlot'
|
||||
97% ( 28 / 29) in 'Reanimate.Math.Common'
|
||||
92% ( 12 / 13) in 'Reanimate.Morph.Common'
|
||||
89% (101 /113) in 'Reanimate.Scene'
|
||||
88% ( 7 / 8) in 'Reanimate.Transition'
|
||||
84% ( 31 / 37) in 'Geom2D.CubicBezier.Linear'
|
||||
75% ( 3 / 4) in 'Reanimate.Svg.Unuse'
|
||||
56% ( 10 / 18) in 'Reanimate.Svg'
|
||||
44% ( 4 / 9) in 'Reanimate.LaTeX'
|
||||
31% ( 4 / 13) in 'Reanimate.Render'
|
||||
25% ( 1 / 4) in 'Reanimate.Builtin.Slide'
|
||||
12% ( 2 / 17) in 'Reanimate.Math.SSSP'
|
||||
6% ( 5 / 84) in 'Reanimate.Math.Polygon'
|
||||
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'
|
||||
14% ( 1 / 7) in 'Reanimate.Morph.Linear'
|
||||
10% ( 1 / 10) in 'Reanimate.ColorSpace'
|
||||
6% ( 1 / 18) in 'Reanimate.Svg.LineCommand'
|
||||
0% ( 0 / 10) in 'Reanimate.ColorSpace'
|
||||
0% ( 0 / 7) in 'Reanimate.Morph.Linear'
|
||||
0% ( 0 / 7) in 'Reanimate.Math.Triangulate'
|
||||
0% ( 0 / 5) in 'Reanimate.Builtin.Flip'
|
||||
0% ( 0 / 4) in 'Reanimate.Debug'
|
||||
0% ( 0 / 3) in 'Reanimate.Morph.Rotational'
|
||||
0% ( 0 / 3) in 'Reanimate.Memo'
|
||||
0% ( 0 / 3) in 'Reanimate.Math.Balloon'
|
||||
|
|
|
|||
|
|
@ -1 +1 @@
|
|||
{ "schemaVersion": 1, "label": "api docs", "message": "69%", "color": "success" }
|
||||
{ "schemaVersion": 1, "label": "api docs", "message": "86%", "color": "success" }
|
||||
|
|
|
|||
|
|
@ -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-26 (ce105)";
|
||||
const playgroundVersion = "2020-08-27 (dc549)";
|
||||
|
|
|
|||
|
|
@ -17,34 +17,41 @@ span.spaces { background: white }
|
|||
<span class="decl"><span class="nottickedoff">never executed</span> <span class="tickonlytrue">always true</span> <span class="tickonlyfalse">always false</span></span>
|
||||
</pre>
|
||||
<pre>
|
||||
<span class="lineno"> 1 </span>module Reanimate.Builtin.Slide where
|
||||
<span class="lineno"> 2 </span>
|
||||
<span class="lineno"> 3 </span>import Reanimate.Transition
|
||||
<span class="lineno"> 4 </span>import Reanimate.Constants
|
||||
<span class="lineno"> 5 </span>import Reanimate.Svg
|
||||
<span class="lineno"> 6 </span>import Reanimate.Effect
|
||||
<span class="lineno"> 7 </span>
|
||||
<span class="lineno"> 8 </span>-- | <<docs/gifs/doc_slideLeftT.gif>>
|
||||
<span class="lineno"> 9 </span>slideLeftT :: Transition
|
||||
<span class="lineno"> 10 </span><span class="decl"><span class="istickedoff">slideLeftT = effectT slideLeft (andE slideLeft moveRight)</span>
|
||||
<span class="lineno"> 11 </span><span class="spaces"> </span><span class="istickedoff">where</span>
|
||||
<span class="lineno"> 12 </span><span class="spaces"> </span><span class="istickedoff">slideLeft = translateE (-screenWidth) 0</span>
|
||||
<span class="lineno"> 13 </span><span class="spaces"> </span><span class="istickedoff">moveRight = constE (translate screenWidth 0)</span>
|
||||
<span class="lineno"> 14 </span><span class="spaces"> </span><span class="istickedoff">andE a b d t = a d t . b <span class="nottickedoff">d</span> <span class="nottickedoff">t</span></span></span>
|
||||
<span class="lineno"> 15 </span>
|
||||
<span class="lineno"> 16 </span>slideDownT :: Transition
|
||||
<span class="lineno"> 17 </span><span class="decl"><span class="nottickedoff">slideDownT = effectT slideDown (andE slideDown moveUp)</span>
|
||||
<span class="lineno"> 18 </span><span class="spaces"> </span><span class="nottickedoff">where</span>
|
||||
<span class="lineno"> 19 </span><span class="spaces"> </span><span class="nottickedoff">slideDown = translateE 0 (-screenHeight)</span>
|
||||
<span class="lineno"> 20 </span><span class="spaces"> </span><span class="nottickedoff">moveUp = constE (translate 0 screenHeight)</span>
|
||||
<span class="lineno"> 21 </span><span class="spaces"> </span><span class="nottickedoff">andE a b d t = a d t . b d t</span></span>
|
||||
<span class="lineno"> 1 </span>{-|
|
||||
<span class="lineno"> 2 </span>Copyright : Written by David Himmelstrup
|
||||
<span class="lineno"> 3 </span>License : Unlicense
|
||||
<span class="lineno"> 4 </span>Maintainer : lemmih@gmail.com
|
||||
<span class="lineno"> 5 </span>Stability : experimental
|
||||
<span class="lineno"> 6 </span>Portability : POSIX
|
||||
<span class="lineno"> 7 </span>-}
|
||||
<span class="lineno"> 8 </span>module Reanimate.Builtin.Slide where
|
||||
<span class="lineno"> 9 </span>
|
||||
<span class="lineno"> 10 </span>import Reanimate.Transition
|
||||
<span class="lineno"> 11 </span>import Reanimate.Constants
|
||||
<span class="lineno"> 12 </span>import Reanimate.Svg
|
||||
<span class="lineno"> 13 </span>import Reanimate.Effect
|
||||
<span class="lineno"> 14 </span>
|
||||
<span class="lineno"> 15 </span>-- | <<docs/gifs/doc_slideLeftT.gif>>
|
||||
<span class="lineno"> 16 </span>slideLeftT :: Transition
|
||||
<span class="lineno"> 17 </span><span class="decl"><span class="istickedoff">slideLeftT = effectT slideLeft (andE slideLeft moveRight)</span>
|
||||
<span class="lineno"> 18 </span><span class="spaces"> </span><span class="istickedoff">where</span>
|
||||
<span class="lineno"> 19 </span><span class="spaces"> </span><span class="istickedoff">slideLeft = translateE (-screenWidth) 0</span>
|
||||
<span class="lineno"> 20 </span><span class="spaces"> </span><span class="istickedoff">moveRight = constE (translate screenWidth 0)</span>
|
||||
<span class="lineno"> 21 </span><span class="spaces"> </span><span class="istickedoff">andE a b d t = a d t . b <span class="nottickedoff">d</span> <span class="nottickedoff">t</span></span></span>
|
||||
<span class="lineno"> 22 </span>
|
||||
<span class="lineno"> 23 </span>slideUpT :: Transition
|
||||
<span class="lineno"> 24 </span><span class="decl"><span class="nottickedoff">slideUpT = effectT slideUp (andE slideUp moveDown)</span>
|
||||
<span class="lineno"> 23 </span>slideDownT :: Transition
|
||||
<span class="lineno"> 24 </span><span class="decl"><span class="nottickedoff">slideDownT = effectT slideDown (andE slideDown moveUp)</span>
|
||||
<span class="lineno"> 25 </span><span class="spaces"> </span><span class="nottickedoff">where</span>
|
||||
<span class="lineno"> 26 </span><span class="spaces"> </span><span class="nottickedoff">slideUp = translateE 0 screenHeight</span>
|
||||
<span class="lineno"> 27 </span><span class="spaces"> </span><span class="nottickedoff">moveDown = constE (translate 0 (-screenHeight))</span>
|
||||
<span class="lineno"> 26 </span><span class="spaces"> </span><span class="nottickedoff">slideDown = translateE 0 (-screenHeight)</span>
|
||||
<span class="lineno"> 27 </span><span class="spaces"> </span><span class="nottickedoff">moveUp = constE (translate 0 screenHeight)</span>
|
||||
<span class="lineno"> 28 </span><span class="spaces"> </span><span class="nottickedoff">andE a b d t = a d t . b d t</span></span>
|
||||
<span class="lineno"> 29 </span>
|
||||
<span class="lineno"> 30 </span>slideUpT :: Transition
|
||||
<span class="lineno"> 31 </span><span class="decl"><span class="nottickedoff">slideUpT = effectT slideUp (andE slideUp moveDown)</span>
|
||||
<span class="lineno"> 32 </span><span class="spaces"> </span><span class="nottickedoff">where</span>
|
||||
<span class="lineno"> 33 </span><span class="spaces"> </span><span class="nottickedoff">slideUp = translateE 0 screenHeight</span>
|
||||
<span class="lineno"> 34 </span><span class="spaces"> </span><span class="nottickedoff">moveDown = constE (translate 0 (-screenHeight))</span>
|
||||
<span class="lineno"> 35 </span><span class="spaces"> </span><span class="nottickedoff">andE a b d t = a d t . b d t</span></span>
|
||||
|
||||
</pre>
|
||||
</body>
|
||||
|
|
|
|||
|
|
@ -25,12 +25,12 @@ span.spaces { background: white }
|
|||
<span class="lineno"> 6 </span>import System.Directory (findExecutable)
|
||||
<span class="lineno"> 7 </span>
|
||||
<span class="lineno"> 8 </span>-- |The name of the ImageMagick command. On Unix-like operating systems, the
|
||||
<span class="lineno"> 9 </span>-- command 'convert' does not conflict with the name of other commands. On
|
||||
<span class="lineno"> 10 </span>-- Windows, ImageMagick version 7 is readily available, the command 'magick'
|
||||
<span class="lineno"> 11 </span>-- should be present, and is preferred over 'convert'. If it is not present,
|
||||
<span class="lineno"> 12 </span>-- 'convert' is assumed to be the relevant command.
|
||||
<span class="lineno"> 9 </span>-- command \'convert\' does not conflict with the name of other commands. On
|
||||
<span class="lineno"> 10 </span>-- Windows, ImageMagick version 7 is readily available, the command \'magick\'
|
||||
<span class="lineno"> 11 </span>-- should be present, and is preferred over \'convert\'. If it is not present,
|
||||
<span class="lineno"> 12 </span>-- \'convert\' is assumed to be the relevant command.
|
||||
<span class="lineno"> 13 </span>magickCmd :: String
|
||||
<span class="lineno"> 14 </span>-- The use of 'unsafeperformIO' is justified on the basis that if 'magick' is
|
||||
<span class="lineno"> 14 </span>-- The use of 'unsafeperformIO' is justified on the basis that if \'magick\' is
|
||||
<span class="lineno"> 15 </span>-- found once, it will always be present.
|
||||
<span class="lineno"> 16 </span><span class="decl"><span class="nottickedoff">magickCmd = unsafePerformIO $ do</span>
|
||||
<span class="lineno"> 17 </span><span class="spaces"> </span><span class="nottickedoff">mPath <- findExecutable "magick"</span>
|
||||
|
|
|
|||
|
|
@ -106,7 +106,7 @@ span.spaces { background: white }
|
|||
<span class="lineno"> 87 </span>> view Play animation in browser window.
|
||||
<span class="lineno"> 88 </span>> render Render animation to file.
|
||||
<span class="lineno"> 89 </span>
|
||||
<span class="lineno"> 90 </span>Neither the 'check' nor the 'view' command take any additional arguments.
|
||||
<span class="lineno"> 90 </span>Neither the \'check\' nor the \'view\' command take any additional arguments.
|
||||
<span class="lineno"> 91 </span>Rendering animation can be controlled with these arguments:
|
||||
<span class="lineno"> 92 </span>
|
||||
<span class="lineno"> 93 </span>> Usage: PROG render [-o|--target FILE] [--fps FPS] [-w|--width PIXELS]
|
||||
|
|
|
|||
|
|
@ -114,7 +114,7 @@ span.spaces { background: white }
|
|||
<span class="lineno"> 95 </span><span class="decl"><span class="istickedoff">bellS steepness = curveS steepness . oscillateS</span></span>
|
||||
<span class="lineno"> 96 </span>
|
||||
<span class="lineno"> 97 </span>-- | Cubic Bezier signal. Gives you a fair amount of control over how the
|
||||
<span class="lineno"> 98 </span>-- signal will 'curve'.
|
||||
<span class="lineno"> 98 </span>-- signal will curve.
|
||||
<span class="lineno"> 99 </span>--
|
||||
<span class="lineno"> 100 </span>-- Example:
|
||||
<span class="lineno"> 101 </span>--
|
||||
|
|
|
|||
|
|
@ -19,175 +19,182 @@ span.spaces { background: white }
|
|||
<pre>
|
||||
<span class="lineno"> 1 </span>{-# LANGUAGE OverloadedStrings #-}
|
||||
<span class="lineno"> 2 </span>{-# LANGUAGE ScopedTypeVariables #-}
|
||||
<span class="lineno"> 3 </span>module Reanimate.LaTeX
|
||||
<span class="lineno"> 4 </span> ( latex
|
||||
<span class="lineno"> 5 </span> , latexWithHeaders
|
||||
<span class="lineno"> 6 </span> , latexChunks
|
||||
<span class="lineno"> 7 </span> , xelatex
|
||||
<span class="lineno"> 8 </span> , xelatexWithHeaders
|
||||
<span class="lineno"> 9 </span> , ctex
|
||||
<span class="lineno"> 10 </span> , ctexWithHeaders
|
||||
<span class="lineno"> 11 </span> , latexAlign
|
||||
<span class="lineno"> 12 </span> )
|
||||
<span class="lineno"> 13 </span>where
|
||||
<span class="lineno"> 14 </span>
|
||||
<span class="lineno"> 15 </span>import qualified Data.ByteString as B
|
||||
<span class="lineno"> 16 </span>import Data.Text ( Text )
|
||||
<span class="lineno"> 17 </span>import qualified Data.Text as T
|
||||
<span class="lineno"> 18 </span>import qualified Data.Text.Encoding as T
|
||||
<span class="lineno"> 19 </span>import Graphics.SvgTree ( Tree(..)
|
||||
<span class="lineno"> 20 </span> , parseSvgFile
|
||||
<span class="lineno"> 21 </span> )
|
||||
<span class="lineno"> 22 </span>import Reanimate.Cache
|
||||
<span class="lineno"> 23 </span>import Reanimate.Misc
|
||||
<span class="lineno"> 24 </span>import Reanimate.Svg
|
||||
<span class="lineno"> 25 </span>import Reanimate.Parameters
|
||||
<span class="lineno"> 26 </span>import System.FilePath ( replaceExtension
|
||||
<span class="lineno"> 27 </span> , takeFileName
|
||||
<span class="lineno"> 28 </span> , (</>)
|
||||
<span class="lineno"> 29 </span> )
|
||||
<span class="lineno"> 30 </span>import System.IO.Unsafe ( unsafePerformIO )
|
||||
<span class="lineno"> 31 </span>
|
||||
<span class="lineno"> 32 </span>-- | Invoke latex and import the result as an SVG object. SVG objects are
|
||||
<span class="lineno"> 33 </span>-- cached to improve performance.
|
||||
<span class="lineno"> 34 </span>--
|
||||
<span class="lineno"> 35 </span>-- Example:
|
||||
<span class="lineno"> 36 </span>--
|
||||
<span class="lineno"> 37 </span>-- > latex "$e^{i\\pi}+1=0$"
|
||||
<span class="lineno"> 38 </span>--
|
||||
<span class="lineno"> 39 </span>-- <<docs/gifs/doc_latex.gif>>
|
||||
<span class="lineno"> 40 </span>latex :: T.Text -> Tree
|
||||
<span class="lineno"> 41 </span><span class="decl"><span class="istickedoff">latex = latexWithHeaders <span class="nottickedoff">[]</span></span></span>
|
||||
<span class="lineno"> 42 </span>
|
||||
<span class="lineno"> 43 </span>latexWithHeaders :: [T.Text] -> T.Text -> Tree
|
||||
<span class="lineno"> 44 </span><span class="decl"><span class="istickedoff">latexWithHeaders = someTexWithHeaders <span class="nottickedoff">"latex"</span> <span class="nottickedoff">"dvi"</span> <span class="nottickedoff">[]</span></span></span>
|
||||
<span class="lineno"> 45 </span>
|
||||
<span class="lineno"> 46 </span>someTexWithHeaders :: String -> String -> [String] -> [T.Text] -> T.Text -> Tree
|
||||
<span class="lineno"> 47 </span><span class="decl"><span class="istickedoff">someTexWithHeaders _exec _dvi _args _headers tex | <span class="tickonlytrue">pNoExternals</span> = mkText tex</span>
|
||||
<span class="lineno"> 48 </span><span class="spaces"></span><span class="istickedoff">someTexWithHeaders exec dvi args headers tex =</span>
|
||||
<span class="lineno"> 49 </span><span class="spaces"> </span><span class="istickedoff"><span class="nottickedoff">(unsafePerformIO . (cacheMem . cacheDiskSvg) (latexToSVG dvi exec args))</span></span>
|
||||
<span class="lineno"> 50 </span><span class="spaces"> </span><span class="istickedoff"><span class="nottickedoff">script</span></span>
|
||||
<span class="lineno"> 51 </span><span class="spaces"> </span><span class="istickedoff">where</span>
|
||||
<span class="lineno"> 52 </span><span class="spaces"> </span><span class="istickedoff"><span class="nottickedoff">script = mkTexScript exec args headers tex</span></span></span>
|
||||
<span class="lineno"> 53 </span>
|
||||
<span class="lineno"> 54 </span>latexChunks :: [T.Text] -> [Tree]
|
||||
<span class="lineno"> 55 </span><span class="decl"><span class="nottickedoff">latexChunks chunks | pNoExternals = map mkText chunks</span>
|
||||
<span class="lineno"> 56 </span><span class="spaces"></span><span class="nottickedoff">latexChunks chunks = worker (svgGlyphs $ latex $ T.concat chunks) chunks</span>
|
||||
<span class="lineno"> 57 </span><span class="spaces"> </span><span class="nottickedoff">where</span>
|
||||
<span class="lineno"> 58 </span><span class="spaces"> </span><span class="nottickedoff">merge lst = mkGroup [ fmt svg | (fmt, _, svg) <- lst ]</span>
|
||||
<span class="lineno"> 59 </span><span class="spaces"> </span><span class="nottickedoff">worker [] [] = []</span>
|
||||
<span class="lineno"> 60 </span><span class="spaces"> </span><span class="nottickedoff">worker _ [] = error "latex chunk mismatch"</span>
|
||||
<span class="lineno"> 61 </span><span class="spaces"> </span><span class="nottickedoff">worker everything (x : xs) =</span>
|
||||
<span class="lineno"> 62 </span><span class="spaces"> </span><span class="nottickedoff">let width = length $ svgGlyphs (latex x)</span>
|
||||
<span class="lineno"> 63 </span><span class="spaces"> </span><span class="nottickedoff">in merge (take width everything) : worker (drop width everything) xs</span></span>
|
||||
<span class="lineno"> 64 </span>
|
||||
<span class="lineno"> 65 </span>-- | Invoke xelatex and import the result as an SVG object. SVG objects are
|
||||
<span class="lineno"> 66 </span>-- cached to improve performance. Xelatex has support for non-western scripts.
|
||||
<span class="lineno"> 67 </span>xelatex :: Text -> Tree
|
||||
<span class="lineno"> 68 </span><span class="decl"><span class="nottickedoff">xelatex = xelatexWithHeaders []</span></span>
|
||||
<span class="lineno"> 69 </span>
|
||||
<span class="lineno"> 70 </span>xelatexWithHeaders :: [T.Text] -> T.Text -> Tree
|
||||
<span class="lineno"> 71 </span><span class="decl"><span class="nottickedoff">xelatexWithHeaders = someTexWithHeaders "xelatex" "xdv" ["-no-pdf"]</span></span>
|
||||
<span class="lineno"> 72 </span>
|
||||
<span class="lineno"> 73 </span>-- | Invoke xelatex with "\usepackage[UTF8]{ctex}" and import the result as an
|
||||
<span class="lineno"> 74 </span>-- SVG object. SVG objects are cached to improve performance. Xelatex has
|
||||
<span class="lineno"> 75 </span>-- support for non-western scripts.
|
||||
<span class="lineno"> 76 </span>--
|
||||
<span class="lineno"> 77 </span>-- Example:
|
||||
<span class="lineno"> 78 </span>--
|
||||
<span class="lineno"> 79 </span>-- > ctex "中文"
|
||||
<span class="lineno"> 80 </span>--
|
||||
<span class="lineno"> 81 </span>-- <<docs/gifs/doc_ctex.gif>>
|
||||
<span class="lineno"> 82 </span>ctex :: T.Text -> Tree
|
||||
<span class="lineno"> 83 </span><span class="decl"><span class="nottickedoff">ctex = ctexWithHeaders []</span></span>
|
||||
<span class="lineno"> 84 </span>
|
||||
<span class="lineno"> 85 </span>ctexWithHeaders :: [T.Text] -> T.Text -> Tree
|
||||
<span class="lineno"> 86 </span><span class="decl"><span class="nottickedoff">ctexWithHeaders headers = xelatexWithHeaders ("\\usepackage[UTF8]{ctex}" : headers)</span></span>
|
||||
<span class="lineno"> 87 </span>
|
||||
<span class="lineno"> 88 </span>-- | Invoke latex and import the result as an SVG object. SVG objects are
|
||||
<span class="lineno"> 89 </span>-- cached to improve performance. This wraps the TeX code in an 'align*'
|
||||
<span class="lineno"> 90 </span>-- context.
|
||||
<span class="lineno"> 91 </span>--
|
||||
<span class="lineno"> 92 </span>-- Example:
|
||||
<span class="lineno"> 93 </span>--
|
||||
<span class="lineno"> 94 </span>-- > latexAlign "R = \\frac{{\\Delta x}}{{kA}}"
|
||||
<span class="lineno"> 95 </span>--
|
||||
<span class="lineno"> 96 </span>-- <<docs/gifs/doc_latexAlign.gif>>
|
||||
<span class="lineno"> 97 </span>latexAlign :: Text -> Tree
|
||||
<span class="lineno"> 98 </span><span class="decl"><span class="istickedoff">latexAlign tex = latex $ T.unlines ["\\begin{align*}", tex, "\\end{align*}"]</span></span>
|
||||
<span class="lineno"> 99 </span>
|
||||
<span class="lineno"> 100 </span>postprocess :: Tree -> Tree
|
||||
<span class="lineno"> 101 </span><span class="decl"><span class="nottickedoff">postprocess = simplify</span></span>
|
||||
<span class="lineno"> 102 </span>
|
||||
<span class="lineno"> 103 </span>-- executable, arguments, header, tex
|
||||
<span class="lineno"> 104 </span>latexToSVG :: String -> String -> [String] -> Text -> IO Tree
|
||||
<span class="lineno"> 105 </span><span class="decl"><span class="nottickedoff">latexToSVG dviExt latexExec latexArgs tex = do</span>
|
||||
<span class="lineno"> 106 </span><span class="spaces"> </span><span class="nottickedoff">latexBin <- requireExecutable latexExec</span>
|
||||
<span class="lineno"> 107 </span><span class="spaces"> </span><span class="nottickedoff">dvisvgm <- requireExecutable "dvisvgm"</span>
|
||||
<span class="lineno"> 108 </span><span class="spaces"> </span><span class="nottickedoff">withTempDir $ \tmp_dir -> withTempFile "tex" $ \tex_file -></span>
|
||||
<span class="lineno"> 109 </span><span class="spaces"> </span><span class="nottickedoff">withTempFile "svg" $ \svg_file -> do</span>
|
||||
<span class="lineno"> 110 </span><span class="spaces"> </span><span class="nottickedoff">let dvi_file =</span>
|
||||
<span class="lineno"> 111 </span><span class="spaces"> </span><span class="nottickedoff">tmp_dir </> replaceExtension (takeFileName tex_file) dviExt</span>
|
||||
<span class="lineno"> 112 </span><span class="spaces"> </span><span class="nottickedoff">B.writeFile tex_file (T.encodeUtf8 tex)</span>
|
||||
<span class="lineno"> 113 </span><span class="spaces"> </span><span class="nottickedoff">runCmd</span>
|
||||
<span class="lineno"> 114 </span><span class="spaces"> </span><span class="nottickedoff">latexBin</span>
|
||||
<span class="lineno"> 115 </span><span class="spaces"> </span><span class="nottickedoff">( latexArgs</span>
|
||||
<span class="lineno"> 116 </span><span class="spaces"> </span><span class="nottickedoff">++ [ "-interaction=nonstopmode"</span>
|
||||
<span class="lineno"> 117 </span><span class="spaces"> </span><span class="nottickedoff">, "-halt-on-error"</span>
|
||||
<span class="lineno"> 118 </span><span class="spaces"> </span><span class="nottickedoff">, "-output-directory=" ++ tmp_dir</span>
|
||||
<span class="lineno"> 119 </span><span class="spaces"> </span><span class="nottickedoff">, tex_file</span>
|
||||
<span class="lineno"> 120 </span><span class="spaces"> </span><span class="nottickedoff">]</span>
|
||||
<span class="lineno"> 121 </span><span class="spaces"> </span><span class="nottickedoff">)</span>
|
||||
<span class="lineno"> 122 </span><span class="spaces"> </span><span class="nottickedoff">runCmd</span>
|
||||
<span class="lineno"> 123 </span><span class="spaces"> </span><span class="nottickedoff">dvisvgm</span>
|
||||
<span class="lineno"> 124 </span><span class="spaces"> </span><span class="nottickedoff">[ dvi_file</span>
|
||||
<span class="lineno"> 125 </span><span class="spaces"> </span><span class="nottickedoff">, "--precision=5"</span>
|
||||
<span class="lineno"> 126 </span><span class="spaces"> </span><span class="nottickedoff">, "--exact" -- better bboxes.</span>
|
||||
<span class="lineno"> 127 </span><span class="spaces"> </span><span class="nottickedoff">, "--no-fonts" -- use glyphs instead of fonts.</span>
|
||||
<span class="lineno"> 128 </span><span class="spaces"> </span><span class="nottickedoff">, "--scale=0.1,-0.1"</span>
|
||||
<span class="lineno"> 129 </span><span class="spaces"> </span><span class="nottickedoff">, "--verbosity=0"</span>
|
||||
<span class="lineno"> 130 </span><span class="spaces"> </span><span class="nottickedoff">, "-o"</span>
|
||||
<span class="lineno"> 131 </span><span class="spaces"> </span><span class="nottickedoff">, svg_file</span>
|
||||
<span class="lineno"> 132 </span><span class="spaces"> </span><span class="nottickedoff">]</span>
|
||||
<span class="lineno"> 133 </span><span class="spaces"> </span><span class="nottickedoff">svg_data <- B.readFile svg_file</span>
|
||||
<span class="lineno"> 134 </span><span class="spaces"> </span><span class="nottickedoff">case parseSvgFile svg_file svg_data of</span>
|
||||
<span class="lineno"> 135 </span><span class="spaces"> </span><span class="nottickedoff">Nothing -> error "Malformed svg"</span>
|
||||
<span class="lineno"> 136 </span><span class="spaces"> </span><span class="nottickedoff">Just svg -> return $ postprocess $ unbox $ replaceUses svg</span></span>
|
||||
<span class="lineno"> 137 </span>
|
||||
<span class="lineno"> 138 </span>mkTexScript :: String -> [String] -> [Text] -> Text -> Text
|
||||
<span class="lineno"> 139 </span><span class="decl"><span class="nottickedoff">mkTexScript latexExec latexArgs texHeaders tex =</span>
|
||||
<span class="lineno"> 140 </span><span class="spaces"> </span><span class="nottickedoff">T.unlines</span>
|
||||
<span class="lineno"> 141 </span><span class="spaces"> </span><span class="nottickedoff">$ [ "% " <> T.pack (unwords (latexExec : latexArgs))</span>
|
||||
<span class="lineno"> 142 </span><span class="spaces"> </span><span class="nottickedoff">, "\\documentclass[preview]{standalone}"</span>
|
||||
<span class="lineno"> 143 </span><span class="spaces"> </span><span class="nottickedoff">, "\\usepackage{amsmath}"</span>
|
||||
<span class="lineno"> 144 </span><span class="spaces"> </span><span class="nottickedoff">, "\\usepackage{gensymb}"</span>
|
||||
<span class="lineno"> 145 </span><span class="spaces"> </span><span class="nottickedoff">]</span>
|
||||
<span class="lineno"> 146 </span><span class="spaces"> </span><span class="nottickedoff">++ texHeaders</span>
|
||||
<span class="lineno"> 147 </span><span class="spaces"> </span><span class="nottickedoff">++ [ "\\usepackage[english]{babel}"</span>
|
||||
<span class="lineno"> 148 </span><span class="spaces"> </span><span class="nottickedoff">, "\\linespread{1}"</span>
|
||||
<span class="lineno"> 149 </span><span class="spaces"> </span><span class="nottickedoff">, "\\begin{document}"</span>
|
||||
<span class="lineno"> 150 </span><span class="spaces"> </span><span class="nottickedoff">, tex</span>
|
||||
<span class="lineno"> 151 </span><span class="spaces"> </span><span class="nottickedoff">, "\\end{document}"</span>
|
||||
<span class="lineno"> 152 </span><span class="spaces"> </span><span class="nottickedoff">]</span></span>
|
||||
<span class="lineno"> 153 </span>
|
||||
<span class="lineno"> 154 </span>{- Packages used by manim.
|
||||
<span class="lineno"> 155 </span>
|
||||
<span class="lineno"> 156 </span>\\\usepackage{amsmath}\n\
|
||||
<span class="lineno"> 157 </span>\\\usepackage{amssymb}\n\
|
||||
<span class="lineno"> 158 </span>\\\usepackage{dsfont}\n\
|
||||
<span class="lineno"> 159 </span>\\\usepackage{setspace}\n\
|
||||
<span class="lineno"> 160 </span>\\\usepackage{relsize}\n\
|
||||
<span class="lineno"> 161 </span>\\\usepackage{textcomp}\n\
|
||||
<span class="lineno"> 162 </span>\\\usepackage{mathrsfs}\n\
|
||||
<span class="lineno"> 163 </span>\\\usepackage{calligra}\n\
|
||||
<span class="lineno"> 164 </span>\\\usepackage{wasysym}\n\
|
||||
<span class="lineno"> 165 </span>\\\usepackage{ragged2e}\n\
|
||||
<span class="lineno"> 166 </span>\\\usepackage{physics}\n\
|
||||
<span class="lineno"> 167 </span>\\\usepackage{xcolor}\n\
|
||||
<span class="lineno"> 3 </span>{-|
|
||||
<span class="lineno"> 4 </span>Copyright : Written by David Himmelstrup
|
||||
<span class="lineno"> 5 </span>License : Unlicense
|
||||
<span class="lineno"> 6 </span>Maintainer : lemmih@gmail.com
|
||||
<span class="lineno"> 7 </span>Stability : experimental
|
||||
<span class="lineno"> 8 </span>Portability : POSIX
|
||||
<span class="lineno"> 9 </span>-}
|
||||
<span class="lineno"> 10 </span>module Reanimate.LaTeX
|
||||
<span class="lineno"> 11 </span> ( latex
|
||||
<span class="lineno"> 12 </span> , latexWithHeaders
|
||||
<span class="lineno"> 13 </span> , latexChunks
|
||||
<span class="lineno"> 14 </span> , xelatex
|
||||
<span class="lineno"> 15 </span> , xelatexWithHeaders
|
||||
<span class="lineno"> 16 </span> , ctex
|
||||
<span class="lineno"> 17 </span> , ctexWithHeaders
|
||||
<span class="lineno"> 18 </span> , latexAlign
|
||||
<span class="lineno"> 19 </span> )
|
||||
<span class="lineno"> 20 </span>where
|
||||
<span class="lineno"> 21 </span>
|
||||
<span class="lineno"> 22 </span>import qualified Data.ByteString as B
|
||||
<span class="lineno"> 23 </span>import Data.Text ( Text )
|
||||
<span class="lineno"> 24 </span>import qualified Data.Text as T
|
||||
<span class="lineno"> 25 </span>import qualified Data.Text.Encoding as T
|
||||
<span class="lineno"> 26 </span>import Graphics.SvgTree ( Tree(..)
|
||||
<span class="lineno"> 27 </span> , parseSvgFile
|
||||
<span class="lineno"> 28 </span> )
|
||||
<span class="lineno"> 29 </span>import Reanimate.Cache
|
||||
<span class="lineno"> 30 </span>import Reanimate.Misc
|
||||
<span class="lineno"> 31 </span>import Reanimate.Svg
|
||||
<span class="lineno"> 32 </span>import Reanimate.Parameters
|
||||
<span class="lineno"> 33 </span>import System.FilePath ( replaceExtension
|
||||
<span class="lineno"> 34 </span> , takeFileName
|
||||
<span class="lineno"> 35 </span> , (</>)
|
||||
<span class="lineno"> 36 </span> )
|
||||
<span class="lineno"> 37 </span>import System.IO.Unsafe ( unsafePerformIO )
|
||||
<span class="lineno"> 38 </span>
|
||||
<span class="lineno"> 39 </span>-- | Invoke latex and import the result as an SVG object. SVG objects are
|
||||
<span class="lineno"> 40 </span>-- cached to improve performance.
|
||||
<span class="lineno"> 41 </span>--
|
||||
<span class="lineno"> 42 </span>-- Example:
|
||||
<span class="lineno"> 43 </span>--
|
||||
<span class="lineno"> 44 </span>-- > latex "$e^{i\\pi}+1=0$"
|
||||
<span class="lineno"> 45 </span>--
|
||||
<span class="lineno"> 46 </span>-- <<docs/gifs/doc_latex.gif>>
|
||||
<span class="lineno"> 47 </span>latex :: T.Text -> Tree
|
||||
<span class="lineno"> 48 </span><span class="decl"><span class="istickedoff">latex = latexWithHeaders <span class="nottickedoff">[]</span></span></span>
|
||||
<span class="lineno"> 49 </span>
|
||||
<span class="lineno"> 50 </span>latexWithHeaders :: [T.Text] -> T.Text -> Tree
|
||||
<span class="lineno"> 51 </span><span class="decl"><span class="istickedoff">latexWithHeaders = someTexWithHeaders <span class="nottickedoff">"latex"</span> <span class="nottickedoff">"dvi"</span> <span class="nottickedoff">[]</span></span></span>
|
||||
<span class="lineno"> 52 </span>
|
||||
<span class="lineno"> 53 </span>someTexWithHeaders :: String -> String -> [String] -> [T.Text] -> T.Text -> Tree
|
||||
<span class="lineno"> 54 </span><span class="decl"><span class="istickedoff">someTexWithHeaders _exec _dvi _args _headers tex | <span class="tickonlytrue">pNoExternals</span> = mkText tex</span>
|
||||
<span class="lineno"> 55 </span><span class="spaces"></span><span class="istickedoff">someTexWithHeaders exec dvi args headers tex =</span>
|
||||
<span class="lineno"> 56 </span><span class="spaces"> </span><span class="istickedoff"><span class="nottickedoff">(unsafePerformIO . (cacheMem . cacheDiskSvg) (latexToSVG dvi exec args))</span></span>
|
||||
<span class="lineno"> 57 </span><span class="spaces"> </span><span class="istickedoff"><span class="nottickedoff">script</span></span>
|
||||
<span class="lineno"> 58 </span><span class="spaces"> </span><span class="istickedoff">where</span>
|
||||
<span class="lineno"> 59 </span><span class="spaces"> </span><span class="istickedoff"><span class="nottickedoff">script = mkTexScript exec args headers tex</span></span></span>
|
||||
<span class="lineno"> 60 </span>
|
||||
<span class="lineno"> 61 </span>latexChunks :: [T.Text] -> [Tree]
|
||||
<span class="lineno"> 62 </span><span class="decl"><span class="nottickedoff">latexChunks chunks | pNoExternals = map mkText chunks</span>
|
||||
<span class="lineno"> 63 </span><span class="spaces"></span><span class="nottickedoff">latexChunks chunks = worker (svgGlyphs $ latex $ T.concat chunks) chunks</span>
|
||||
<span class="lineno"> 64 </span><span class="spaces"> </span><span class="nottickedoff">where</span>
|
||||
<span class="lineno"> 65 </span><span class="spaces"> </span><span class="nottickedoff">merge lst = mkGroup [ fmt svg | (fmt, _, svg) <- lst ]</span>
|
||||
<span class="lineno"> 66 </span><span class="spaces"> </span><span class="nottickedoff">worker [] [] = []</span>
|
||||
<span class="lineno"> 67 </span><span class="spaces"> </span><span class="nottickedoff">worker _ [] = error "latex chunk mismatch"</span>
|
||||
<span class="lineno"> 68 </span><span class="spaces"> </span><span class="nottickedoff">worker everything (x : xs) =</span>
|
||||
<span class="lineno"> 69 </span><span class="spaces"> </span><span class="nottickedoff">let width = length $ svgGlyphs (latex x)</span>
|
||||
<span class="lineno"> 70 </span><span class="spaces"> </span><span class="nottickedoff">in merge (take width everything) : worker (drop width everything) xs</span></span>
|
||||
<span class="lineno"> 71 </span>
|
||||
<span class="lineno"> 72 </span>-- | Invoke xelatex and import the result as an SVG object. SVG objects are
|
||||
<span class="lineno"> 73 </span>-- cached to improve performance. Xelatex has support for non-western scripts.
|
||||
<span class="lineno"> 74 </span>xelatex :: Text -> Tree
|
||||
<span class="lineno"> 75 </span><span class="decl"><span class="nottickedoff">xelatex = xelatexWithHeaders []</span></span>
|
||||
<span class="lineno"> 76 </span>
|
||||
<span class="lineno"> 77 </span>xelatexWithHeaders :: [T.Text] -> T.Text -> Tree
|
||||
<span class="lineno"> 78 </span><span class="decl"><span class="nottickedoff">xelatexWithHeaders = someTexWithHeaders "xelatex" "xdv" ["-no-pdf"]</span></span>
|
||||
<span class="lineno"> 79 </span>
|
||||
<span class="lineno"> 80 </span>-- | Invoke xelatex with "\usepackage[UTF8]{ctex}" and import the result as an
|
||||
<span class="lineno"> 81 </span>-- SVG object. SVG objects are cached to improve performance. Xelatex has
|
||||
<span class="lineno"> 82 </span>-- support for non-western scripts.
|
||||
<span class="lineno"> 83 </span>--
|
||||
<span class="lineno"> 84 </span>-- Example:
|
||||
<span class="lineno"> 85 </span>--
|
||||
<span class="lineno"> 86 </span>-- > ctex "中文"
|
||||
<span class="lineno"> 87 </span>--
|
||||
<span class="lineno"> 88 </span>-- <<docs/gifs/doc_ctex.gif>>
|
||||
<span class="lineno"> 89 </span>ctex :: T.Text -> Tree
|
||||
<span class="lineno"> 90 </span><span class="decl"><span class="nottickedoff">ctex = ctexWithHeaders []</span></span>
|
||||
<span class="lineno"> 91 </span>
|
||||
<span class="lineno"> 92 </span>ctexWithHeaders :: [T.Text] -> T.Text -> Tree
|
||||
<span class="lineno"> 93 </span><span class="decl"><span class="nottickedoff">ctexWithHeaders headers = xelatexWithHeaders ("\\usepackage[UTF8]{ctex}" : headers)</span></span>
|
||||
<span class="lineno"> 94 </span>
|
||||
<span class="lineno"> 95 </span>-- | Invoke latex and import the result as an SVG object. SVG objects are
|
||||
<span class="lineno"> 96 </span>-- cached to improve performance. This wraps the TeX code in an 'align*'
|
||||
<span class="lineno"> 97 </span>-- context.
|
||||
<span class="lineno"> 98 </span>--
|
||||
<span class="lineno"> 99 </span>-- Example:
|
||||
<span class="lineno"> 100 </span>--
|
||||
<span class="lineno"> 101 </span>-- > latexAlign "R = \\frac{{\\Delta x}}{{kA}}"
|
||||
<span class="lineno"> 102 </span>--
|
||||
<span class="lineno"> 103 </span>-- <<docs/gifs/doc_latexAlign.gif>>
|
||||
<span class="lineno"> 104 </span>latexAlign :: Text -> Tree
|
||||
<span class="lineno"> 105 </span><span class="decl"><span class="istickedoff">latexAlign tex = latex $ T.unlines ["\\begin{align*}", tex, "\\end{align*}"]</span></span>
|
||||
<span class="lineno"> 106 </span>
|
||||
<span class="lineno"> 107 </span>postprocess :: Tree -> Tree
|
||||
<span class="lineno"> 108 </span><span class="decl"><span class="nottickedoff">postprocess = simplify</span></span>
|
||||
<span class="lineno"> 109 </span>
|
||||
<span class="lineno"> 110 </span>-- executable, arguments, header, tex
|
||||
<span class="lineno"> 111 </span>latexToSVG :: String -> String -> [String] -> Text -> IO Tree
|
||||
<span class="lineno"> 112 </span><span class="decl"><span class="nottickedoff">latexToSVG dviExt latexExec latexArgs tex = do</span>
|
||||
<span class="lineno"> 113 </span><span class="spaces"> </span><span class="nottickedoff">latexBin <- requireExecutable latexExec</span>
|
||||
<span class="lineno"> 114 </span><span class="spaces"> </span><span class="nottickedoff">dvisvgm <- requireExecutable "dvisvgm"</span>
|
||||
<span class="lineno"> 115 </span><span class="spaces"> </span><span class="nottickedoff">withTempDir $ \tmp_dir -> withTempFile "tex" $ \tex_file -></span>
|
||||
<span class="lineno"> 116 </span><span class="spaces"> </span><span class="nottickedoff">withTempFile "svg" $ \svg_file -> do</span>
|
||||
<span class="lineno"> 117 </span><span class="spaces"> </span><span class="nottickedoff">let dvi_file =</span>
|
||||
<span class="lineno"> 118 </span><span class="spaces"> </span><span class="nottickedoff">tmp_dir </> replaceExtension (takeFileName tex_file) dviExt</span>
|
||||
<span class="lineno"> 119 </span><span class="spaces"> </span><span class="nottickedoff">B.writeFile tex_file (T.encodeUtf8 tex)</span>
|
||||
<span class="lineno"> 120 </span><span class="spaces"> </span><span class="nottickedoff">runCmd</span>
|
||||
<span class="lineno"> 121 </span><span class="spaces"> </span><span class="nottickedoff">latexBin</span>
|
||||
<span class="lineno"> 122 </span><span class="spaces"> </span><span class="nottickedoff">( latexArgs</span>
|
||||
<span class="lineno"> 123 </span><span class="spaces"> </span><span class="nottickedoff">++ [ "-interaction=nonstopmode"</span>
|
||||
<span class="lineno"> 124 </span><span class="spaces"> </span><span class="nottickedoff">, "-halt-on-error"</span>
|
||||
<span class="lineno"> 125 </span><span class="spaces"> </span><span class="nottickedoff">, "-output-directory=" ++ tmp_dir</span>
|
||||
<span class="lineno"> 126 </span><span class="spaces"> </span><span class="nottickedoff">, tex_file</span>
|
||||
<span class="lineno"> 127 </span><span class="spaces"> </span><span class="nottickedoff">]</span>
|
||||
<span class="lineno"> 128 </span><span class="spaces"> </span><span class="nottickedoff">)</span>
|
||||
<span class="lineno"> 129 </span><span class="spaces"> </span><span class="nottickedoff">runCmd</span>
|
||||
<span class="lineno"> 130 </span><span class="spaces"> </span><span class="nottickedoff">dvisvgm</span>
|
||||
<span class="lineno"> 131 </span><span class="spaces"> </span><span class="nottickedoff">[ dvi_file</span>
|
||||
<span class="lineno"> 132 </span><span class="spaces"> </span><span class="nottickedoff">, "--precision=5"</span>
|
||||
<span class="lineno"> 133 </span><span class="spaces"> </span><span class="nottickedoff">, "--exact" -- better bboxes.</span>
|
||||
<span class="lineno"> 134 </span><span class="spaces"> </span><span class="nottickedoff">, "--no-fonts" -- use glyphs instead of fonts.</span>
|
||||
<span class="lineno"> 135 </span><span class="spaces"> </span><span class="nottickedoff">, "--scale=0.1,-0.1"</span>
|
||||
<span class="lineno"> 136 </span><span class="spaces"> </span><span class="nottickedoff">, "--verbosity=0"</span>
|
||||
<span class="lineno"> 137 </span><span class="spaces"> </span><span class="nottickedoff">, "-o"</span>
|
||||
<span class="lineno"> 138 </span><span class="spaces"> </span><span class="nottickedoff">, svg_file</span>
|
||||
<span class="lineno"> 139 </span><span class="spaces"> </span><span class="nottickedoff">]</span>
|
||||
<span class="lineno"> 140 </span><span class="spaces"> </span><span class="nottickedoff">svg_data <- B.readFile svg_file</span>
|
||||
<span class="lineno"> 141 </span><span class="spaces"> </span><span class="nottickedoff">case parseSvgFile svg_file svg_data of</span>
|
||||
<span class="lineno"> 142 </span><span class="spaces"> </span><span class="nottickedoff">Nothing -> error "Malformed svg"</span>
|
||||
<span class="lineno"> 143 </span><span class="spaces"> </span><span class="nottickedoff">Just svg -> return $ postprocess $ unbox $ replaceUses svg</span></span>
|
||||
<span class="lineno"> 144 </span>
|
||||
<span class="lineno"> 145 </span>mkTexScript :: String -> [String] -> [Text] -> Text -> Text
|
||||
<span class="lineno"> 146 </span><span class="decl"><span class="nottickedoff">mkTexScript latexExec latexArgs texHeaders tex =</span>
|
||||
<span class="lineno"> 147 </span><span class="spaces"> </span><span class="nottickedoff">T.unlines</span>
|
||||
<span class="lineno"> 148 </span><span class="spaces"> </span><span class="nottickedoff">$ [ "% " <> T.pack (unwords (latexExec : latexArgs))</span>
|
||||
<span class="lineno"> 149 </span><span class="spaces"> </span><span class="nottickedoff">, "\\documentclass[preview]{standalone}"</span>
|
||||
<span class="lineno"> 150 </span><span class="spaces"> </span><span class="nottickedoff">, "\\usepackage{amsmath}"</span>
|
||||
<span class="lineno"> 151 </span><span class="spaces"> </span><span class="nottickedoff">, "\\usepackage{gensymb}"</span>
|
||||
<span class="lineno"> 152 </span><span class="spaces"> </span><span class="nottickedoff">]</span>
|
||||
<span class="lineno"> 153 </span><span class="spaces"> </span><span class="nottickedoff">++ texHeaders</span>
|
||||
<span class="lineno"> 154 </span><span class="spaces"> </span><span class="nottickedoff">++ [ "\\usepackage[english]{babel}"</span>
|
||||
<span class="lineno"> 155 </span><span class="spaces"> </span><span class="nottickedoff">, "\\linespread{1}"</span>
|
||||
<span class="lineno"> 156 </span><span class="spaces"> </span><span class="nottickedoff">, "\\begin{document}"</span>
|
||||
<span class="lineno"> 157 </span><span class="spaces"> </span><span class="nottickedoff">, tex</span>
|
||||
<span class="lineno"> 158 </span><span class="spaces"> </span><span class="nottickedoff">, "\\end{document}"</span>
|
||||
<span class="lineno"> 159 </span><span class="spaces"> </span><span class="nottickedoff">]</span></span>
|
||||
<span class="lineno"> 160 </span>
|
||||
<span class="lineno"> 161 </span>{- Packages used by manim.
|
||||
<span class="lineno"> 162 </span>
|
||||
<span class="lineno"> 163 </span>\\\usepackage{amsmath}\n\
|
||||
<span class="lineno"> 164 </span>\\\usepackage{amssymb}\n\
|
||||
<span class="lineno"> 165 </span>\\\usepackage{dsfont}\n\
|
||||
<span class="lineno"> 166 </span>\\\usepackage{setspace}\n\
|
||||
<span class="lineno"> 167 </span>\\\usepackage{relsize}\n\
|
||||
<span class="lineno"> 168 </span>\\\usepackage{textcomp}\n\
|
||||
<span class="lineno"> 169 </span>\\\usepackage{xfrac}\n\
|
||||
<span class="lineno"> 170 </span>\\\usepackage{microtype}\n\
|
||||
<span class="lineno"> 171 </span>-}
|
||||
<span class="lineno"> 169 </span>\\\usepackage{mathrsfs}\n\
|
||||
<span class="lineno"> 170 </span>\\\usepackage{calligra}\n\
|
||||
<span class="lineno"> 171 </span>\\\usepackage{wasysym}\n\
|
||||
<span class="lineno"> 172 </span>\\\usepackage{ragged2e}\n\
|
||||
<span class="lineno"> 173 </span>\\\usepackage{physics}\n\
|
||||
<span class="lineno"> 174 </span>\\\usepackage{xcolor}\n\
|
||||
<span class="lineno"> 175 </span>\\\usepackage{textcomp}\n\
|
||||
<span class="lineno"> 176 </span>\\\usepackage{xfrac}\n\
|
||||
<span class="lineno"> 177 </span>\\\usepackage{microtype}\n\
|
||||
<span class="lineno"> 178 </span>-}
|
||||
|
||||
</pre>
|
||||
</body>
|
||||
|
|
|
|||
File diff suppressed because it is too large
Load diff
|
|
@ -20,345 +20,346 @@ span.spaces { background: white }
|
|||
<span class="lineno"> 1 </span>{-# LANGUAGE FlexibleInstances #-}
|
||||
<span class="lineno"> 2 </span>{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
<span class="lineno"> 3 </span>{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
<span class="lineno"> 4 </span>module Reanimate.Math.SSSP
|
||||
<span class="lineno"> 5 </span> ( -- * Single-Source-Shortest-Path
|
||||
<span class="lineno"> 6 </span> SSSP
|
||||
<span class="lineno"> 7 </span> , sssp -- :: (Fractional a, Ord a) => Ring a -> Dual -> SSSP
|
||||
<span class="lineno"> 8 </span> , dual -- :: Int -> Triangulation -> Dual
|
||||
<span class="lineno"> 9 </span> , Dual(..)
|
||||
<span class="lineno"> 10 </span> , DualTree(..)
|
||||
<span class="lineno"> 11 </span> , PDual
|
||||
<span class="lineno"> 12 </span> , toPDual -- :: Ring Rational -> Dual -> PDual
|
||||
<span class="lineno"> 13 </span> , pdualRings -- :: Ring Rational -> PDual -> [Ring Rational]
|
||||
<span class="lineno"> 14 </span> -- * Misc
|
||||
<span class="lineno"> 15 </span> , dualToTriangulation -- :: Ring Rational -> Dual -> Triangulation
|
||||
<span class="lineno"> 16 </span> , pdualReduce -- :: Ring Rational -> PDual -> Int -> PDual
|
||||
<span class="lineno"> 17 </span> , visibilityArray -- :: Ring Rational -> V.Vector [Int]
|
||||
<span class="lineno"> 18 </span> , naive -- :: Ring Rational -> SSSP
|
||||
<span class="lineno"> 19 </span> , naive2 -- :: Ring Rational -> SSSP
|
||||
<span class="lineno"> 20 </span> , drawDual -- :: Dual -> String
|
||||
<span class="lineno"> 21 </span> ) where
|
||||
<span class="lineno"> 22 </span>
|
||||
<span class="lineno"> 23 </span>import Control.Monad
|
||||
<span class="lineno"> 24 </span>-- import Control.Exception
|
||||
<span class="lineno"> 25 </span>import Control.Monad.ST
|
||||
<span class="lineno"> 26 </span>-- import Data.FingerTree (SearchResult (..), (|>))
|
||||
<span class="lineno"> 27 </span>-- import qualified Data.FingerTree as F
|
||||
<span class="lineno"> 28 </span>import Data.Foldable
|
||||
<span class="lineno"> 29 </span>import Data.List
|
||||
<span class="lineno"> 30 </span>import qualified Data.Map as Map
|
||||
<span class="lineno"> 31 </span>import Data.Maybe
|
||||
<span class="lineno"> 32 </span>import Data.Ord
|
||||
<span class="lineno"> 33 </span>import Data.STRef
|
||||
<span class="lineno"> 34 </span>import Data.Tree
|
||||
<span class="lineno"> 35 </span>import qualified Data.Vector as V
|
||||
<span class="lineno"> 36 </span>import qualified Data.Vector.Mutable as MV
|
||||
<span class="lineno"> 37 </span>import Reanimate.Math.Common
|
||||
<span class="lineno"> 38 </span>import Reanimate.Math.Triangulate
|
||||
<span class="lineno"> 39 </span>
|
||||
<span class="lineno"> 40 </span>-- import Debug.Trace
|
||||
<span class="lineno"> 41 </span>
|
||||
<span class="lineno"> 42 </span>type SSSP = V.Vector Int
|
||||
<span class="lineno"> 43 </span>
|
||||
<span class="lineno"> 4 </span>{-# OPTIONS_HADDOCK hide #-}
|
||||
<span class="lineno"> 5 </span>module Reanimate.Math.SSSP
|
||||
<span class="lineno"> 6 </span> ( -- * Single-Source-Shortest-Path
|
||||
<span class="lineno"> 7 </span> SSSP
|
||||
<span class="lineno"> 8 </span> , sssp -- :: (Fractional a, Ord a) => Ring a -> Dual -> SSSP
|
||||
<span class="lineno"> 9 </span> , dual -- :: Int -> Triangulation -> Dual
|
||||
<span class="lineno"> 10 </span> , Dual(..)
|
||||
<span class="lineno"> 11 </span> , DualTree(..)
|
||||
<span class="lineno"> 12 </span> , PDual
|
||||
<span class="lineno"> 13 </span> , toPDual -- :: Ring Rational -> Dual -> PDual
|
||||
<span class="lineno"> 14 </span> , pdualRings -- :: Ring Rational -> PDual -> [Ring Rational]
|
||||
<span class="lineno"> 15 </span> -- * Misc
|
||||
<span class="lineno"> 16 </span> , dualToTriangulation -- :: Ring Rational -> Dual -> Triangulation
|
||||
<span class="lineno"> 17 </span> , pdualReduce -- :: Ring Rational -> PDual -> Int -> PDual
|
||||
<span class="lineno"> 18 </span> , visibilityArray -- :: Ring Rational -> V.Vector [Int]
|
||||
<span class="lineno"> 19 </span> , naive -- :: Ring Rational -> SSSP
|
||||
<span class="lineno"> 20 </span> , naive2 -- :: Ring Rational -> SSSP
|
||||
<span class="lineno"> 21 </span> , drawDual -- :: Dual -> String
|
||||
<span class="lineno"> 22 </span> ) where
|
||||
<span class="lineno"> 23 </span>
|
||||
<span class="lineno"> 24 </span>import Control.Monad
|
||||
<span class="lineno"> 25 </span>-- import Control.Exception
|
||||
<span class="lineno"> 26 </span>import Control.Monad.ST
|
||||
<span class="lineno"> 27 </span>-- import Data.FingerTree (SearchResult (..), (|>))
|
||||
<span class="lineno"> 28 </span>-- import qualified Data.FingerTree as F
|
||||
<span class="lineno"> 29 </span>import Data.Foldable
|
||||
<span class="lineno"> 30 </span>import Data.List
|
||||
<span class="lineno"> 31 </span>import qualified Data.Map as Map
|
||||
<span class="lineno"> 32 </span>import Data.Maybe
|
||||
<span class="lineno"> 33 </span>import Data.Ord
|
||||
<span class="lineno"> 34 </span>import Data.STRef
|
||||
<span class="lineno"> 35 </span>import Data.Tree
|
||||
<span class="lineno"> 36 </span>import qualified Data.Vector as V
|
||||
<span class="lineno"> 37 </span>import qualified Data.Vector.Mutable as MV
|
||||
<span class="lineno"> 38 </span>import Reanimate.Math.Common
|
||||
<span class="lineno"> 39 </span>import Reanimate.Math.Triangulate
|
||||
<span class="lineno"> 40 </span>
|
||||
<span class="lineno"> 41 </span>-- import Debug.Trace
|
||||
<span class="lineno"> 42 </span>
|
||||
<span class="lineno"> 43 </span>type SSSP = V.Vector Int
|
||||
<span class="lineno"> 44 </span>
|
||||
<span class="lineno"> 45 </span>-- ssspParent :: Polygon -> SSSP -> Int -> Int
|
||||
<span class="lineno"> 46 </span>-- ssspParent p sTree x =
|
||||
<span class="lineno"> 47 </span>-- (sTree V.! ((x - polygonOffset p) `mod` n) + polygonOffset p) `mod` n
|
||||
<span class="lineno"> 48 </span>-- where
|
||||
<span class="lineno"> 49 </span>-- n = polygonSize p
|
||||
<span class="lineno"> 50 </span>
|
||||
<span class="lineno"> 51 </span>visibilityArray :: Ring Rational -> V.Vector [Int]
|
||||
<span class="lineno"> 52 </span><span class="decl"><span class="nottickedoff">visibilityArray p = arr</span>
|
||||
<span class="lineno"> 53 </span><span class="spaces"> </span><span class="nottickedoff">where</span>
|
||||
<span class="lineno"> 54 </span><span class="spaces"> </span><span class="nottickedoff">n = ringSize p</span>
|
||||
<span class="lineno"> 55 </span><span class="spaces"> </span><span class="nottickedoff">arr = V.fromList</span>
|
||||
<span class="lineno"> 56 </span><span class="spaces"> </span><span class="nottickedoff">[ visibility y</span>
|
||||
<span class="lineno"> 57 </span><span class="spaces"> </span><span class="nottickedoff">| y <- [0..n-1]</span>
|
||||
<span class="lineno"> 58 </span><span class="spaces"> </span><span class="nottickedoff">]</span>
|
||||
<span class="lineno"> 59 </span><span class="spaces"> </span><span class="nottickedoff">visibility y =</span>
|
||||
<span class="lineno"> 60 </span><span class="spaces"> </span><span class="nottickedoff">[ i</span>
|
||||
<span class="lineno"> 61 </span><span class="spaces"> </span><span class="nottickedoff">| i <- [0..y-1]</span>
|
||||
<span class="lineno"> 62 </span><span class="spaces"> </span><span class="nottickedoff">, y `elem` arr V.! i ] ++</span>
|
||||
<span class="lineno"> 63 </span><span class="spaces"> </span><span class="nottickedoff">[ i</span>
|
||||
<span class="lineno"> 64 </span><span class="spaces"> </span><span class="nottickedoff">| i <- [y+1 .. n-1]</span>
|
||||
<span class="lineno"> 65 </span><span class="spaces"> </span><span class="nottickedoff">, let pI = ringAccess p i</span>
|
||||
<span class="lineno"> 66 </span><span class="spaces"> </span><span class="nottickedoff">isOpen = isRightTurn pYp pY pYn</span>
|
||||
<span class="lineno"> 67 </span><span class="spaces"> </span><span class="nottickedoff">, ringClamp p (y+1) == i || ringClamp p (y-1) == i || if isOpen</span>
|
||||
<span class="lineno"> 68 </span><span class="spaces"> </span><span class="nottickedoff">then isLeftTurnOrLinear pY pYn pI ||</span>
|
||||
<span class="lineno"> 69 </span><span class="spaces"> </span><span class="nottickedoff">isLeftTurnOrLinear pYp pY pI</span>
|
||||
<span class="lineno"> 70 </span><span class="spaces"> </span><span class="nottickedoff">else not $ isRightTurn pY pYn pI ||</span>
|
||||
<span class="lineno"> 71 </span><span class="spaces"> </span><span class="nottickedoff">isRightTurn pYp pY pI</span>
|
||||
<span class="lineno"> 72 </span><span class="spaces"> </span><span class="nottickedoff">, let myEdges = [(e1,e2) | (e1,e2) <- edges, e1/=y, e1/=i, e2/=y,e2/=i]</span>
|
||||
<span class="lineno"> 73 </span><span class="spaces"> </span><span class="nottickedoff">, all (isNothing . lineIntersect (pY,pI))</span>
|
||||
<span class="lineno"> 74 </span><span class="spaces"> </span><span class="nottickedoff">[ (ringAccess p e1, ringAccess p e2) | (e1,e2) <- myEdges ]]</span>
|
||||
<span class="lineno"> 75 </span><span class="spaces"> </span><span class="nottickedoff">where</span>
|
||||
<span class="lineno"> 76 </span><span class="spaces"> </span><span class="nottickedoff">pY = ringAccess p y</span>
|
||||
<span class="lineno"> 77 </span><span class="spaces"> </span><span class="nottickedoff">pYn = ringAccess p $ y+1</span>
|
||||
<span class="lineno"> 78 </span><span class="spaces"> </span><span class="nottickedoff">pYp = ringAccess p $ y-1</span>
|
||||
<span class="lineno"> 79 </span><span class="spaces"> </span><span class="nottickedoff">edges = zip [0..n-1] (tail [0..n-1] ++ [0])</span></span>
|
||||
<span class="lineno"> 80 </span>
|
||||
<span class="lineno"> 45 </span>
|
||||
<span class="lineno"> 46 </span>-- ssspParent :: Polygon -> SSSP -> Int -> Int
|
||||
<span class="lineno"> 47 </span>-- ssspParent p sTree x =
|
||||
<span class="lineno"> 48 </span>-- (sTree V.! ((x - polygonOffset p) `mod` n) + polygonOffset p) `mod` n
|
||||
<span class="lineno"> 49 </span>-- where
|
||||
<span class="lineno"> 50 </span>-- n = polygonSize p
|
||||
<span class="lineno"> 51 </span>
|
||||
<span class="lineno"> 52 </span>visibilityArray :: Ring Rational -> V.Vector [Int]
|
||||
<span class="lineno"> 53 </span><span class="decl"><span class="nottickedoff">visibilityArray p = arr</span>
|
||||
<span class="lineno"> 54 </span><span class="spaces"> </span><span class="nottickedoff">where</span>
|
||||
<span class="lineno"> 55 </span><span class="spaces"> </span><span class="nottickedoff">n = ringSize p</span>
|
||||
<span class="lineno"> 56 </span><span class="spaces"> </span><span class="nottickedoff">arr = V.fromList</span>
|
||||
<span class="lineno"> 57 </span><span class="spaces"> </span><span class="nottickedoff">[ visibility y</span>
|
||||
<span class="lineno"> 58 </span><span class="spaces"> </span><span class="nottickedoff">| y <- [0..n-1]</span>
|
||||
<span class="lineno"> 59 </span><span class="spaces"> </span><span class="nottickedoff">]</span>
|
||||
<span class="lineno"> 60 </span><span class="spaces"> </span><span class="nottickedoff">visibility y =</span>
|
||||
<span class="lineno"> 61 </span><span class="spaces"> </span><span class="nottickedoff">[ i</span>
|
||||
<span class="lineno"> 62 </span><span class="spaces"> </span><span class="nottickedoff">| i <- [0..y-1]</span>
|
||||
<span class="lineno"> 63 </span><span class="spaces"> </span><span class="nottickedoff">, y `elem` arr V.! i ] ++</span>
|
||||
<span class="lineno"> 64 </span><span class="spaces"> </span><span class="nottickedoff">[ i</span>
|
||||
<span class="lineno"> 65 </span><span class="spaces"> </span><span class="nottickedoff">| i <- [y+1 .. n-1]</span>
|
||||
<span class="lineno"> 66 </span><span class="spaces"> </span><span class="nottickedoff">, let pI = ringAccess p i</span>
|
||||
<span class="lineno"> 67 </span><span class="spaces"> </span><span class="nottickedoff">isOpen = isRightTurn pYp pY pYn</span>
|
||||
<span class="lineno"> 68 </span><span class="spaces"> </span><span class="nottickedoff">, ringClamp p (y+1) == i || ringClamp p (y-1) == i || if isOpen</span>
|
||||
<span class="lineno"> 69 </span><span class="spaces"> </span><span class="nottickedoff">then isLeftTurnOrLinear pY pYn pI ||</span>
|
||||
<span class="lineno"> 70 </span><span class="spaces"> </span><span class="nottickedoff">isLeftTurnOrLinear pYp pY pI</span>
|
||||
<span class="lineno"> 71 </span><span class="spaces"> </span><span class="nottickedoff">else not $ isRightTurn pY pYn pI ||</span>
|
||||
<span class="lineno"> 72 </span><span class="spaces"> </span><span class="nottickedoff">isRightTurn pYp pY pI</span>
|
||||
<span class="lineno"> 73 </span><span class="spaces"> </span><span class="nottickedoff">, let myEdges = [(e1,e2) | (e1,e2) <- edges, e1/=y, e1/=i, e2/=y,e2/=i]</span>
|
||||
<span class="lineno"> 74 </span><span class="spaces"> </span><span class="nottickedoff">, all (isNothing . lineIntersect (pY,pI))</span>
|
||||
<span class="lineno"> 75 </span><span class="spaces"> </span><span class="nottickedoff">[ (ringAccess p e1, ringAccess p e2) | (e1,e2) <- myEdges ]]</span>
|
||||
<span class="lineno"> 76 </span><span class="spaces"> </span><span class="nottickedoff">where</span>
|
||||
<span class="lineno"> 77 </span><span class="spaces"> </span><span class="nottickedoff">pY = ringAccess p y</span>
|
||||
<span class="lineno"> 78 </span><span class="spaces"> </span><span class="nottickedoff">pYn = ringAccess p $ y+1</span>
|
||||
<span class="lineno"> 79 </span><span class="spaces"> </span><span class="nottickedoff">pYp = ringAccess p $ y-1</span>
|
||||
<span class="lineno"> 80 </span><span class="spaces"> </span><span class="nottickedoff">edges = zip [0..n-1] (tail [0..n-1] ++ [0])</span></span>
|
||||
<span class="lineno"> 81 </span>
|
||||
<span class="lineno"> 82 </span>
|
||||
<span class="lineno"> 83 </span>-- Iterative Single Source Shortest Path solver. Quite slow.
|
||||
<span class="lineno"> 84 </span>naive :: Ring Rational -> SSSP
|
||||
<span class="lineno"> 85 </span><span class="decl"><span class="nottickedoff">naive p =</span>
|
||||
<span class="lineno"> 86 </span><span class="spaces"> </span><span class="nottickedoff">V.fromList $ Map.elems $</span>
|
||||
<span class="lineno"> 87 </span><span class="spaces"> </span><span class="nottickedoff">Map.map snd $</span>
|
||||
<span class="lineno"> 88 </span><span class="spaces"> </span><span class="nottickedoff">worker initial</span>
|
||||
<span class="lineno"> 89 </span><span class="spaces"> </span><span class="nottickedoff">where</span>
|
||||
<span class="lineno"> 90 </span><span class="spaces"> </span><span class="nottickedoff">initial = Map.singleton 0 (0,0)</span>
|
||||
<span class="lineno"> 91 </span><span class="spaces"> </span><span class="nottickedoff">visibility = visibilityArray p</span>
|
||||
<span class="lineno"> 92 </span><span class="spaces"> </span><span class="nottickedoff">worker :: Map.Map Int (Rational, Int) -> Map.Map Int (Rational, Int)</span>
|
||||
<span class="lineno"> 93 </span><span class="spaces"> </span><span class="nottickedoff">worker m</span>
|
||||
<span class="lineno"> 94 </span><span class="spaces"> </span><span class="nottickedoff">| m==newM = newM</span>
|
||||
<span class="lineno"> 95 </span><span class="spaces"> </span><span class="nottickedoff">| otherwise = worker newM</span>
|
||||
<span class="lineno"> 96 </span><span class="spaces"> </span><span class="nottickedoff">where</span>
|
||||
<span class="lineno"> 97 </span><span class="spaces"> </span><span class="nottickedoff">ms' = [ Map.fromList</span>
|
||||
<span class="lineno"> 98 </span><span class="spaces"> </span><span class="nottickedoff">[ case Map.lookup v m of</span>
|
||||
<span class="lineno"> 99 </span><span class="spaces"> </span><span class="nottickedoff">Nothing -> (v, (distThroughI, i))</span>
|
||||
<span class="lineno"> 100 </span><span class="spaces"> </span><span class="nottickedoff">Just (otherDist,parent)</span>
|
||||
<span class="lineno"> 101 </span><span class="spaces"> </span><span class="nottickedoff">| otherDist > distThroughI -> (v, (distThroughI, i))</span>
|
||||
<span class="lineno"> 102 </span><span class="spaces"> </span><span class="nottickedoff">| otherwise -> (v, (otherDist, parent))</span>
|
||||
<span class="lineno"> 103 </span><span class="spaces"> </span><span class="nottickedoff">| v <- visibility V.! i</span>
|
||||
<span class="lineno"> 104 </span><span class="spaces"> </span><span class="nottickedoff">, let distThroughI = dist + approxDist (ringAccess p i) (ringAccess p v) ]</span>
|
||||
<span class="lineno"> 105 </span><span class="spaces"> </span><span class="nottickedoff">| (i,(dist,_)) <- Map.toList m</span>
|
||||
<span class="lineno"> 106 </span><span class="spaces"> </span><span class="nottickedoff">]</span>
|
||||
<span class="lineno"> 107 </span><span class="spaces"> </span><span class="nottickedoff">newM = Map.unionsWith g (m:ms') :: Map.Map Int (Rational,Int)</span>
|
||||
<span class="lineno"> 108 </span><span class="spaces"> </span><span class="nottickedoff">g a b = if fst a < fst b then a else b</span></span>
|
||||
<span class="lineno"> 109 </span>
|
||||
<span class="lineno"> 110 </span>naive2 :: Ring Rational -> SSSP
|
||||
<span class="lineno"> 111 </span><span class="decl"><span class="nottickedoff">naive2 p = runST $ do</span>
|
||||
<span class="lineno"> 112 </span><span class="spaces"> </span><span class="nottickedoff">parents <- MV.replicate (ringSize p) (-1)</span>
|
||||
<span class="lineno"> 113 </span><span class="spaces"> </span><span class="nottickedoff">costs <- MV.replicate (ringSize p) (-1)</span>
|
||||
<span class="lineno"> 114 </span><span class="spaces"> </span><span class="nottickedoff">MV.write parents 0 0</span>
|
||||
<span class="lineno"> 115 </span><span class="spaces"> </span><span class="nottickedoff">MV.write costs 0 0</span>
|
||||
<span class="lineno"> 116 </span><span class="spaces"> </span><span class="nottickedoff">changedRef <- newSTRef False</span>
|
||||
<span class="lineno"> 117 </span><span class="spaces"> </span><span class="nottickedoff">let loop i</span>
|
||||
<span class="lineno"> 118 </span><span class="spaces"> </span><span class="nottickedoff">| i == ringSize p = do</span>
|
||||
<span class="lineno"> 119 </span><span class="spaces"> </span><span class="nottickedoff">changed <- readSTRef changedRef</span>
|
||||
<span class="lineno"> 120 </span><span class="spaces"> </span><span class="nottickedoff">when changed $ do</span>
|
||||
<span class="lineno"> 121 </span><span class="spaces"> </span><span class="nottickedoff">writeSTRef changedRef False</span>
|
||||
<span class="lineno"> 122 </span><span class="spaces"> </span><span class="nottickedoff">loop 0</span>
|
||||
<span class="lineno"> 123 </span><span class="spaces"> </span><span class="nottickedoff">| otherwise = do</span>
|
||||
<span class="lineno"> 124 </span><span class="spaces"> </span><span class="nottickedoff">myCost <- MV.read costs i</span>
|
||||
<span class="lineno"> 125 </span><span class="spaces"> </span><span class="nottickedoff">unless (myCost < 0) $</span>
|
||||
<span class="lineno"> 126 </span><span class="spaces"> </span><span class="nottickedoff">forM_ (visibility V.! i) $ \n -> do</span>
|
||||
<span class="lineno"> 127 </span><span class="spaces"> </span><span class="nottickedoff">-- n is visible from i.</span>
|
||||
<span class="lineno"> 128 </span><span class="spaces"> </span><span class="nottickedoff">theirCost <- MV.read costs n</span>
|
||||
<span class="lineno"> 129 </span><span class="spaces"> </span><span class="nottickedoff">let throughCost = myCost + approxDist (ringAccess p i) (ringAccess p n)</span>
|
||||
<span class="lineno"> 130 </span><span class="spaces"> </span><span class="nottickedoff">when (throughCost < theirCost || theirCost < 0) $ do</span>
|
||||
<span class="lineno"> 131 </span><span class="spaces"> </span><span class="nottickedoff">MV.write parents n i</span>
|
||||
<span class="lineno"> 132 </span><span class="spaces"> </span><span class="nottickedoff">MV.write costs n throughCost</span>
|
||||
<span class="lineno"> 133 </span><span class="spaces"> </span><span class="nottickedoff">writeSTRef changedRef True</span>
|
||||
<span class="lineno"> 134 </span><span class="spaces"> </span><span class="nottickedoff">loop (i+1)</span>
|
||||
<span class="lineno"> 135 </span><span class="spaces"> </span><span class="nottickedoff">loop 0</span>
|
||||
<span class="lineno"> 136 </span><span class="spaces"> </span><span class="nottickedoff">V.unsafeFreeze parents</span>
|
||||
<span class="lineno"> 137 </span><span class="spaces"> </span><span class="nottickedoff">where</span>
|
||||
<span class="lineno"> 138 </span><span class="spaces"> </span><span class="nottickedoff">visibility = visibilityArray p</span></span>
|
||||
<span class="lineno"> 139 </span>
|
||||
<span class="lineno"> 140 </span>data PDual = PDual (V.Vector Int) Rational [PDual]
|
||||
<span class="lineno"> 141 </span> deriving (<span class="decl"><span class="nottickedoff">Show</span></span>)
|
||||
<span class="lineno"> 142 </span>
|
||||
<span class="lineno"> 143 </span>toPDual :: Ring Rational -> Dual -> PDual
|
||||
<span class="lineno"> 144 </span><span class="decl"><span class="nottickedoff">toPDual p d =</span>
|
||||
<span class="lineno"> 145 </span><span class="spaces"> </span><span class="nottickedoff">case d of</span>
|
||||
<span class="lineno"> 146 </span><span class="spaces"> </span><span class="nottickedoff">Dual (a,b,c) l r -></span>
|
||||
<span class="lineno"> 147 </span><span class="spaces"> </span><span class="nottickedoff">PDual (V.fromList [a,b,c])</span>
|
||||
<span class="lineno"> 148 </span><span class="spaces"> </span><span class="nottickedoff">(area2X (ringAccess p a) (ringAccess p b) (ringAccess p c))</span>
|
||||
<span class="lineno"> 149 </span><span class="spaces"> </span><span class="nottickedoff">(catMaybes [ worker c a l, worker b c r])</span>
|
||||
<span class="lineno"> 150 </span><span class="spaces"> </span><span class="nottickedoff">where</span>
|
||||
<span class="lineno"> 151 </span><span class="spaces"> </span><span class="nottickedoff">worker _ _ EmptyDual = Nothing</span>
|
||||
<span class="lineno"> 152 </span><span class="spaces"> </span><span class="nottickedoff">worker a b (NodeDual x l r) = Just $</span>
|
||||
<span class="lineno"> 153 </span><span class="spaces"> </span><span class="nottickedoff">PDual (V.fromList [a,x,b])</span>
|
||||
<span class="lineno"> 154 </span><span class="spaces"> </span><span class="nottickedoff">(area2X (ringAccess p a) (ringAccess p x) (ringAccess p b))</span>
|
||||
<span class="lineno"> 155 </span><span class="spaces"> </span><span class="nottickedoff">(catMaybes [ worker x b l, worker a x r])</span></span>
|
||||
<span class="lineno"> 156 </span>
|
||||
<span class="lineno"> 157 </span>pdualSize :: PDual -> Int
|
||||
<span class="lineno"> 158 </span><span class="decl"><span class="nottickedoff">pdualSize (PDual _ _ children) = 1 + sum (map pdualSize children)</span></span>
|
||||
<span class="lineno"> 159 </span>
|
||||
<span class="lineno"> 160 </span>pdualArea :: PDual -> Rational
|
||||
<span class="lineno"> 161 </span><span class="decl"><span class="nottickedoff">pdualArea (PDual _ faceArea _) = faceArea</span></span>
|
||||
<span class="lineno"> 162 </span>
|
||||
<span class="lineno"> 163 </span>-- FIXME: 'origin' isn't used. Remove.
|
||||
<span class="lineno"> 164 </span>pdualReduce :: Ring Rational -> PDual -> Int -> PDual
|
||||
<span class="lineno"> 165 </span><span class="decl"><span class="nottickedoff">pdualReduce origin pdual n</span>
|
||||
<span class="lineno"> 166 </span><span class="spaces"> </span><span class="nottickedoff">| pdualSize pdual <= n = pdual</span>
|
||||
<span class="lineno"> 167 </span><span class="spaces"> </span><span class="nottickedoff">| otherwise =</span>
|
||||
<span class="lineno"> 168 </span><span class="spaces"> </span><span class="nottickedoff">let smallest = minimum $ pAreas pdual</span>
|
||||
<span class="lineno"> 169 </span><span class="spaces"> </span><span class="nottickedoff">in pdualReduce origin (merge smallest pdual) n</span>
|
||||
<span class="lineno"> 170 </span><span class="spaces"> </span><span class="nottickedoff">where</span>
|
||||
<span class="lineno"> 171 </span><span class="spaces"> </span><span class="nottickedoff">merge _s (PDual p faceArea []) = PDual p faceArea []</span>
|
||||
<span class="lineno"> 172 </span><span class="spaces"> </span><span class="nottickedoff">merge s (PDual p faceArea children)</span>
|
||||
<span class="lineno"> 173 </span><span class="spaces"> </span><span class="nottickedoff">| faceArea == s =</span>
|
||||
<span class="lineno"> 174 </span><span class="spaces"> </span><span class="nottickedoff">let (PDual p2 area2 children2:xs) = sortBy (comparing pdualArea) children</span>
|
||||
<span class="lineno"> 175 </span><span class="spaces"> </span><span class="nottickedoff">in PDual (joinP p p2) (faceArea+area2) (children2++xs)</span>
|
||||
<span class="lineno"> 176 </span><span class="spaces"> </span><span class="nottickedoff">| otherwise =</span>
|
||||
<span class="lineno"> 177 </span><span class="spaces"> </span><span class="nottickedoff">let (PDual p2 area2 children2:xs) = sortBy (comparing pdualArea) children</span>
|
||||
<span class="lineno"> 178 </span><span class="spaces"> </span><span class="nottickedoff">in if area2 == s</span>
|
||||
<span class="lineno"> 179 </span><span class="spaces"> </span><span class="nottickedoff">then PDual (joinP p p2) (faceArea+area2) (children2++xs)</span>
|
||||
<span class="lineno"> 180 </span><span class="spaces"> </span><span class="nottickedoff">else PDual p faceArea (map (merge s) children)</span>
|
||||
<span class="lineno"> 181 </span><span class="spaces"> </span><span class="nottickedoff">pAreas (PDual _ faceArea children) = faceArea : concatMap pAreas children</span>
|
||||
<span class="lineno"> 182 </span><span class="spaces"> </span><span class="nottickedoff">joinP a b = V.fromList (sort (V.toList a ++ V.toList b))</span></span>
|
||||
<span class="lineno"> 183 </span>
|
||||
<span class="lineno"> 184 </span>pdualRings :: Ring Rational -> PDual -> [Ring Rational]
|
||||
<span class="lineno"> 185 </span><span class="decl"><span class="nottickedoff">pdualRings p (PDual pts _area children) =</span>
|
||||
<span class="lineno"> 186 </span><span class="spaces"> </span><span class="nottickedoff">ringPack (V.map (ringAccess p) pts) : concatMap (pdualRings p) children</span></span>
|
||||
<span class="lineno"> 187 </span>
|
||||
<span class="lineno"> 188 </span>-- Dual of triangulated polygon
|
||||
<span class="lineno"> 189 </span>data Dual = Dual (Int,Int,Int) -- (a,b,c)
|
||||
<span class="lineno"> 190 </span> DualTree -- borders ca
|
||||
<span class="lineno"> 191 </span> DualTree -- borders bc
|
||||
<span class="lineno"> 192 </span> deriving (<span class="decl"><span class="nottickedoff">Show</span></span>)
|
||||
<span class="lineno"> 193 </span>
|
||||
<span class="lineno"> 194 </span>data DualTree
|
||||
<span class="lineno"> 195 </span> = EmptyDual
|
||||
<span class="lineno"> 196 </span> | NodeDual Int -- axb triangle, a and b are from parent.
|
||||
<span class="lineno"> 197 </span> DualTree -- borders xb
|
||||
<span class="lineno"> 198 </span> DualTree -- borders ax
|
||||
<span class="lineno"> 199 </span> deriving (<span class="decl"><span class="nottickedoff">Show</span></span>)
|
||||
<span class="lineno"> 200 </span>
|
||||
<span class="lineno"> 201 </span>drawDual :: Dual -> String
|
||||
<span class="lineno"> 202 </span><span class="decl"><span class="nottickedoff">drawDual d = drawTree $</span>
|
||||
<span class="lineno"> 203 </span><span class="spaces"> </span><span class="nottickedoff">case d of</span>
|
||||
<span class="lineno"> 204 </span><span class="spaces"> </span><span class="nottickedoff">Dual (a,b,c) l r -> Node (show (a,b,c)) [worker c a l, worker b c r]</span>
|
||||
<span class="lineno"> 205 </span><span class="spaces"> </span><span class="nottickedoff">where</span>
|
||||
<span class="lineno"> 206 </span><span class="spaces"> </span><span class="nottickedoff">worker _a _b EmptyDual = Node "Leaf" []</span>
|
||||
<span class="lineno"> 207 </span><span class="spaces"> </span><span class="nottickedoff">worker a b (NodeDual x l r) =</span>
|
||||
<span class="lineno"> 208 </span><span class="spaces"> </span><span class="nottickedoff">Node (show (b,a,x)) [worker x b l, worker a x r]</span></span>
|
||||
<span class="lineno"> 209 </span>
|
||||
<span class="lineno"> 210 </span>dualToTriangulation :: Ring Rational -> Dual -> Triangulation
|
||||
<span class="lineno"> 211 </span><span class="decl"><span class="nottickedoff">dualToTriangulation p d = edgesToTriangulation (ringSize p) $ filter goodEdge $</span>
|
||||
<span class="lineno"> 212 </span><span class="spaces"> </span><span class="nottickedoff">case d of</span>
|
||||
<span class="lineno"> 213 </span><span class="spaces"> </span><span class="nottickedoff">Dual (a,b,c) l r -></span>
|
||||
<span class="lineno"> 214 </span><span class="spaces"> </span><span class="nottickedoff">(a,b):(a,c):(b,c):worker c a l ++ worker b c r</span>
|
||||
<span class="lineno"> 215 </span><span class="spaces"> </span><span class="nottickedoff">where</span>
|
||||
<span class="lineno"> 216 </span><span class="spaces"> </span><span class="nottickedoff">goodEdge (a,b)</span>
|
||||
<span class="lineno"> 217 </span><span class="spaces"> </span><span class="nottickedoff">= a /= ringClamp p (b+1) && a /= ringClamp p (b-1)</span>
|
||||
<span class="lineno"> 218 </span><span class="spaces"> </span><span class="nottickedoff">worker _a _b EmptyDual = []</span>
|
||||
<span class="lineno"> 219 </span><span class="spaces"> </span><span class="nottickedoff">worker a b (NodeDual x l r) =</span>
|
||||
<span class="lineno"> 220 </span><span class="spaces"> </span><span class="nottickedoff">(a,x) : (x, b) : worker x b l ++ worker a x r</span></span>
|
||||
<span class="lineno"> 221 </span>
|
||||
<span class="lineno"> 222 </span>-- Dual path:
|
||||
<span class="lineno"> 223 </span>-- (Int,Int,Int) + V.Vector Int + V.Vector LeftOrRight
|
||||
<span class="lineno"> 224 </span>
|
||||
<span class="lineno"> 225 </span>-- simplifyDual :: DualTree -> DualTree
|
||||
<span class="lineno"> 226 </span>-- -- simplifyDual (NodeDual x EmptyDual EmptyDual) = NodeLeaf x
|
||||
<span class="lineno"> 227 </span>-- -- simplifyDual (NodeDual x l EmptyDual) = NodeDualL x l
|
||||
<span class="lineno"> 228 </span>-- -- simplifyDual (NodeDual x EmptyDual r) = NodeDualR x r
|
||||
<span class="lineno"> 229 </span>-- simplifyDual d = d
|
||||
<span class="lineno"> 230 </span>
|
||||
<span class="lineno"> 231 </span>dual :: Int -> Triangulation -> Dual
|
||||
<span class="lineno"> 232 </span><span class="decl"><span class="nottickedoff">dual root t =</span>
|
||||
<span class="lineno"> 233 </span><span class="spaces"> </span><span class="nottickedoff">case hasTriangle of</span>
|
||||
<span class="lineno"> 234 </span><span class="spaces"> </span><span class="nottickedoff">[] -> error "weird triangulation"</span>
|
||||
<span class="lineno"> 235 </span><span class="spaces"> </span><span class="nottickedoff">-- [] -> Dual (0,1,V.length t-1) EmptyDual (dualTree t (1, (V.length t-1)) 0)</span>
|
||||
<span class="lineno"> 236 </span><span class="spaces"> </span><span class="nottickedoff">(x:_) -> Dual (root,rootNext,x) (dualTree t (x,root) rootNext) (dualTree t (rootNext,x) root)</span>
|
||||
<span class="lineno"> 237 </span><span class="spaces"> </span><span class="nottickedoff">where</span>
|
||||
<span class="lineno"> 238 </span><span class="spaces"> </span><span class="nottickedoff">rootNext = idx (root+1)</span>
|
||||
<span class="lineno"> 239 </span><span class="spaces"> </span><span class="nottickedoff">rootPrev = idx (root-1)</span>
|
||||
<span class="lineno"> 240 </span><span class="spaces"> </span><span class="nottickedoff">rootNNext = idx (root+2)</span>
|
||||
<span class="lineno"> 241 </span><span class="spaces"> </span><span class="nottickedoff">idx i = i `mod` n</span>
|
||||
<span class="lineno"> 242 </span><span class="spaces"> </span><span class="nottickedoff">hasTriangle = (rootPrev : t V.! root) `intersect` (rootNNext : t V.! rootNext)</span>
|
||||
<span class="lineno"> 243 </span><span class="spaces"> </span><span class="nottickedoff">n = V.length t</span></span>
|
||||
<span class="lineno"> 244 </span>
|
||||
<span class="lineno"> 245 </span>-- a=6, b=0, e=1
|
||||
<span class="lineno"> 246 </span>dualTree :: Triangulation -> (Int,Int) -> Int -> DualTree
|
||||
<span class="lineno"> 247 </span><span class="decl"><span class="nottickedoff">dualTree t (a,b) e = -- simplifyDual $</span>
|
||||
<span class="lineno"> 248 </span><span class="spaces"> </span><span class="nottickedoff">case hasTriangle of</span>
|
||||
<span class="lineno"> 249 </span><span class="spaces"> </span><span class="nottickedoff">[] -> EmptyDual</span>
|
||||
<span class="lineno"> 250 </span><span class="spaces"> </span><span class="nottickedoff">[(ab)] -></span>
|
||||
<span class="lineno"> 251 </span><span class="spaces"> </span><span class="nottickedoff">NodeDual ab</span>
|
||||
<span class="lineno"> 252 </span><span class="spaces"> </span><span class="nottickedoff">(dualTree t (ab,b) a)</span>
|
||||
<span class="lineno"> 253 </span><span class="spaces"> </span><span class="nottickedoff">(dualTree t (a,ab) b)</span>
|
||||
<span class="lineno"> 254 </span><span class="spaces"> </span><span class="nottickedoff">_ -> error $ "Invalid triangulation: " ++ show (a,b,e,hasTriangle)</span>
|
||||
<span class="lineno"> 255 </span><span class="spaces"> </span><span class="nottickedoff">where</span>
|
||||
<span class="lineno"> 256 </span><span class="spaces"> </span><span class="nottickedoff">hasTriangle = (prev a : next a : t V.! a) `intersect` (prev b : next b : t V.! b)</span>
|
||||
<span class="lineno"> 257 </span><span class="spaces"> </span><span class="nottickedoff">\\ [e]</span>
|
||||
<span class="lineno"> 258 </span><span class="spaces"> </span><span class="nottickedoff">n = V.length t</span>
|
||||
<span class="lineno"> 259 </span><span class="spaces"> </span><span class="nottickedoff">next x = (x+1) `mod` n</span>
|
||||
<span class="lineno"> 260 </span><span class="spaces"> </span><span class="nottickedoff">prev x = (x-1) `mod` n</span></span>
|
||||
<span class="lineno"> 261 </span>
|
||||
<span class="lineno"> 262 </span>-- data MinMax = MinMax Int Int | MinMaxEmpty deriving (Show)
|
||||
<span class="lineno"> 263 </span>-- instance Semigroup MinMax where
|
||||
<span class="lineno"> 264 </span>-- MinMaxEmpty <> b = b
|
||||
<span class="lineno"> 265 </span>-- a <> MinMaxEmpty = a
|
||||
<span class="lineno"> 266 </span>-- MinMax a b <> MinMax c d
|
||||
<span class="lineno"> 267 </span>-- = MinMax (min a c) (max b d)
|
||||
<span class="lineno"> 268 </span>-- -- = MinMax c b
|
||||
<span class="lineno"> 269 </span>-- instance Monoid MinMax where
|
||||
<span class="lineno"> 270 </span>-- mempty = MinMaxEmpty
|
||||
<span class="lineno"> 271 </span>--
|
||||
<span class="lineno"> 272 </span>-- instance F.Measured MinMax Int where
|
||||
<span class="lineno"> 273 </span>-- measure i = MinMax i i
|
||||
<span class="lineno"> 274 </span>
|
||||
<span class="lineno"> 275 </span>-- dualRoot :: Dual -> Int
|
||||
<span class="lineno"> 276 </span>-- dualRoot (Dual (a,_,_) _ _) = a
|
||||
<span class="lineno"> 277 </span>
|
||||
<span class="lineno"> 278 </span>-- O(n*ln n), could be O(n) if I could figure out how to use fingertrees...
|
||||
<span class="lineno"> 279 </span>sssp :: (Fractional a, Ord a, Epsilon a) => Ring a -> Dual -> SSSP
|
||||
<span class="lineno"> 280 </span><span class="decl"><span class="nottickedoff">sssp p d = toSSSP $</span>
|
||||
<span class="lineno"> 281 </span><span class="spaces"> </span><span class="nottickedoff">case d of</span>
|
||||
<span class="lineno"> 282 </span><span class="spaces"> </span><span class="nottickedoff">Dual (a,b,c) l r -></span>
|
||||
<span class="lineno"> 283 </span><span class="spaces"> </span><span class="nottickedoff">(a, a) :</span>
|
||||
<span class="lineno"> 284 </span><span class="spaces"> </span><span class="nottickedoff">(b, a) :</span>
|
||||
<span class="lineno"> 285 </span><span class="spaces"> </span><span class="nottickedoff">(c, a) :</span>
|
||||
<span class="lineno"> 286 </span><span class="spaces"> </span><span class="nottickedoff">worker [c] [b] a r ++</span>
|
||||
<span class="lineno"> 287 </span><span class="spaces"> </span><span class="nottickedoff">loopLeft a c l</span>
|
||||
<span class="lineno"> 288 </span><span class="spaces"> </span><span class="nottickedoff">where</span>
|
||||
<span class="lineno"> 289 </span><span class="spaces"> </span><span class="nottickedoff">toSSSP edges =</span>
|
||||
<span class="lineno"> 290 </span><span class="spaces"> </span><span class="nottickedoff">(V.fromList . map snd . sortOn fst) edges</span>
|
||||
<span class="lineno"> 291 </span><span class="spaces"> </span><span class="nottickedoff">loopLeft a outer l =</span>
|
||||
<span class="lineno"> 292 </span><span class="spaces"> </span><span class="nottickedoff">case l of</span>
|
||||
<span class="lineno"> 293 </span><span class="spaces"> </span><span class="nottickedoff">EmptyDual -> []</span>
|
||||
<span class="lineno"> 294 </span><span class="spaces"> </span><span class="nottickedoff">NodeDual x l' r' -></span>
|
||||
<span class="lineno"> 295 </span><span class="spaces"> </span><span class="nottickedoff">(x,a) :</span>
|
||||
<span class="lineno"> 296 </span><span class="spaces"> </span><span class="nottickedoff">worker [x] [outer] a r' ++</span>
|
||||
<span class="lineno"> 297 </span><span class="spaces"> </span><span class="nottickedoff">loopLeft a x l'</span>
|
||||
<span class="lineno"> 298 </span><span class="spaces"> </span><span class="nottickedoff">searchFn _checkStep _cusp _x [] = Nothing</span>
|
||||
<span class="lineno"> 299 </span><span class="spaces"> </span><span class="nottickedoff">searchFn checkStep cusp x (y:ys)</span>
|
||||
<span class="lineno"> 300 </span><span class="spaces"> </span><span class="nottickedoff">| not (checkStep (ringAccess p cusp) (ringAccess p y) (ringAccess p x))</span>
|
||||
<span class="lineno"> 301 </span><span class="spaces"> </span><span class="nottickedoff">= Just $ helper [] y ys</span>
|
||||
<span class="lineno"> 302 </span><span class="spaces"> </span><span class="nottickedoff">| otherwise = Nothing</span>
|
||||
<span class="lineno"> 303 </span><span class="spaces"> </span><span class="nottickedoff">where</span>
|
||||
<span class="lineno"> 304 </span><span class="spaces"> </span><span class="nottickedoff">helper acc v [] = (v, [], reverse acc)</span>
|
||||
<span class="lineno"> 305 </span><span class="spaces"> </span><span class="nottickedoff">helper acc v1 (v2:vs)</span>
|
||||
<span class="lineno"> 306 </span><span class="spaces"> </span><span class="nottickedoff">| checkStep (ringAccess p v1) (ringAccess p v2) (ringAccess p x) =</span>
|
||||
<span class="lineno"> 307 </span><span class="spaces"> </span><span class="nottickedoff">(v1, v2:vs, reverse acc)</span>
|
||||
<span class="lineno"> 308 </span><span class="spaces"> </span><span class="nottickedoff">| otherwise = helper (v1:acc) v2 vs</span>
|
||||
<span class="lineno"> 309 </span><span class="spaces"> </span><span class="nottickedoff">searchRight = searchFn isLeftTurn</span>
|
||||
<span class="lineno"> 310 </span><span class="spaces"> </span><span class="nottickedoff">searchLeft = searchFn isRightTurn</span>
|
||||
<span class="lineno"> 311 </span><span class="spaces"> </span><span class="nottickedoff">-- adj x = x -- ringClamp p (x-dualRoot d)</span>
|
||||
<span class="lineno"> 312 </span><span class="spaces"> </span><span class="nottickedoff">-- optTrace msg =</span>
|
||||
<span class="lineno"> 313 </span><span class="spaces"> </span><span class="nottickedoff">-- if False -- dualRoot d == 1 || dualRoot d == 0</span>
|
||||
<span class="lineno"> 314 </span><span class="spaces"> </span><span class="nottickedoff">-- then trace msg</span>
|
||||
<span class="lineno"> 315 </span><span class="spaces"> </span><span class="nottickedoff">-- else id</span>
|
||||
<span class="lineno"> 316 </span><span class="spaces"> </span><span class="nottickedoff">worker _ _ _ EmptyDual = []</span>
|
||||
<span class="lineno"> 317 </span><span class="spaces"> </span><span class="nottickedoff">worker f1 f2 cusp (NodeDual x l r) =</span>
|
||||
<span class="lineno"> 318 </span><span class="spaces"> </span><span class="nottickedoff">-- (optTrace ("Funnel: " ++ show</span>
|
||||
<span class="lineno"> 319 </span><span class="spaces"> </span><span class="nottickedoff">-- (map adj $ toList f1</span>
|
||||
<span class="lineno"> 320 </span><span class="spaces"> </span><span class="nottickedoff">-- ,adj cusp</span>
|
||||
<span class="lineno"> 321 </span><span class="spaces"> </span><span class="nottickedoff">-- ,map adj $ toList f2</span>
|
||||
<span class="lineno"> 322 </span><span class="spaces"> </span><span class="nottickedoff">-- ,adj x</span>
|
||||
<span class="lineno"> 323 </span><span class="spaces"> </span><span class="nottickedoff">-- , dualRoot d))</span>
|
||||
<span class="lineno"> 324 </span><span class="spaces"> </span><span class="nottickedoff">-- ) $</span>
|
||||
<span class="lineno"> 325 </span><span class="spaces"> </span><span class="nottickedoff">case searchLeft cusp x (toList f1) of</span>
|
||||
<span class="lineno"> 326 </span><span class="spaces"> </span><span class="nottickedoff">Just (v, f1Hi, f1Lo) -></span>
|
||||
<span class="lineno"> 327 </span><span class="spaces"> </span><span class="nottickedoff">-- optTrace (" Visble from left: " ++ show (adj x,adj v)) $</span>
|
||||
<span class="lineno"> 328 </span><span class="spaces"> </span><span class="nottickedoff">(x, v::Int) :</span>
|
||||
<span class="lineno"> 329 </span><span class="spaces"> </span><span class="nottickedoff">worker f1Hi [x] v l ++</span>
|
||||
<span class="lineno"> 330 </span><span class="spaces"> </span><span class="nottickedoff">worker (f1Lo ++ [v, x]) f2 cusp r</span>
|
||||
<span class="lineno"> 331 </span><span class="spaces"> </span><span class="nottickedoff">Nothing -></span>
|
||||
<span class="lineno"> 332 </span><span class="spaces"> </span><span class="nottickedoff">case searchRight cusp x (toList f2) of</span>
|
||||
<span class="lineno"> 333 </span><span class="spaces"> </span><span class="nottickedoff">Just (v, f2Hi, f2Lo) -></span>
|
||||
<span class="lineno"> 334 </span><span class="spaces"> </span><span class="nottickedoff">-- optTrace (" Visble from right: " ++ show (adj x,adj v)) $</span>
|
||||
<span class="lineno"> 335 </span><span class="spaces"> </span><span class="nottickedoff">(x, v::Int) :</span>
|
||||
<span class="lineno"> 336 </span><span class="spaces"> </span><span class="nottickedoff">worker f1 (f2Lo ++ [v, x]) cusp l ++</span>
|
||||
<span class="lineno"> 337 </span><span class="spaces"> </span><span class="nottickedoff">worker [x] f2Hi v r</span>
|
||||
<span class="lineno"> 338 </span><span class="spaces"> </span><span class="nottickedoff">Nothing -></span>
|
||||
<span class="lineno"> 339 </span><span class="spaces"> </span><span class="nottickedoff">-- optTrace (" Visble from cusp: " ++ show (adj x,adj cusp)) $</span>
|
||||
<span class="lineno"> 340 </span><span class="spaces"> </span><span class="nottickedoff">(x, cusp::Int) :</span>
|
||||
<span class="lineno"> 341 </span><span class="spaces"> </span><span class="nottickedoff">worker f1 [x] cusp l ++</span>
|
||||
<span class="lineno"> 342 </span><span class="spaces"> </span><span class="nottickedoff">worker [x] f2 cusp r</span></span>
|
||||
<span class="lineno"> 83 </span>
|
||||
<span class="lineno"> 84 </span>-- Iterative Single Source Shortest Path solver. Quite slow.
|
||||
<span class="lineno"> 85 </span>naive :: Ring Rational -> SSSP
|
||||
<span class="lineno"> 86 </span><span class="decl"><span class="nottickedoff">naive p =</span>
|
||||
<span class="lineno"> 87 </span><span class="spaces"> </span><span class="nottickedoff">V.fromList $ Map.elems $</span>
|
||||
<span class="lineno"> 88 </span><span class="spaces"> </span><span class="nottickedoff">Map.map snd $</span>
|
||||
<span class="lineno"> 89 </span><span class="spaces"> </span><span class="nottickedoff">worker initial</span>
|
||||
<span class="lineno"> 90 </span><span class="spaces"> </span><span class="nottickedoff">where</span>
|
||||
<span class="lineno"> 91 </span><span class="spaces"> </span><span class="nottickedoff">initial = Map.singleton 0 (0,0)</span>
|
||||
<span class="lineno"> 92 </span><span class="spaces"> </span><span class="nottickedoff">visibility = visibilityArray p</span>
|
||||
<span class="lineno"> 93 </span><span class="spaces"> </span><span class="nottickedoff">worker :: Map.Map Int (Rational, Int) -> Map.Map Int (Rational, Int)</span>
|
||||
<span class="lineno"> 94 </span><span class="spaces"> </span><span class="nottickedoff">worker m</span>
|
||||
<span class="lineno"> 95 </span><span class="spaces"> </span><span class="nottickedoff">| m==newM = newM</span>
|
||||
<span class="lineno"> 96 </span><span class="spaces"> </span><span class="nottickedoff">| otherwise = worker newM</span>
|
||||
<span class="lineno"> 97 </span><span class="spaces"> </span><span class="nottickedoff">where</span>
|
||||
<span class="lineno"> 98 </span><span class="spaces"> </span><span class="nottickedoff">ms' = [ Map.fromList</span>
|
||||
<span class="lineno"> 99 </span><span class="spaces"> </span><span class="nottickedoff">[ case Map.lookup v m of</span>
|
||||
<span class="lineno"> 100 </span><span class="spaces"> </span><span class="nottickedoff">Nothing -> (v, (distThroughI, i))</span>
|
||||
<span class="lineno"> 101 </span><span class="spaces"> </span><span class="nottickedoff">Just (otherDist,parent)</span>
|
||||
<span class="lineno"> 102 </span><span class="spaces"> </span><span class="nottickedoff">| otherDist > distThroughI -> (v, (distThroughI, i))</span>
|
||||
<span class="lineno"> 103 </span><span class="spaces"> </span><span class="nottickedoff">| otherwise -> (v, (otherDist, parent))</span>
|
||||
<span class="lineno"> 104 </span><span class="spaces"> </span><span class="nottickedoff">| v <- visibility V.! i</span>
|
||||
<span class="lineno"> 105 </span><span class="spaces"> </span><span class="nottickedoff">, let distThroughI = dist + approxDist (ringAccess p i) (ringAccess p v) ]</span>
|
||||
<span class="lineno"> 106 </span><span class="spaces"> </span><span class="nottickedoff">| (i,(dist,_)) <- Map.toList m</span>
|
||||
<span class="lineno"> 107 </span><span class="spaces"> </span><span class="nottickedoff">]</span>
|
||||
<span class="lineno"> 108 </span><span class="spaces"> </span><span class="nottickedoff">newM = Map.unionsWith g (m:ms') :: Map.Map Int (Rational,Int)</span>
|
||||
<span class="lineno"> 109 </span><span class="spaces"> </span><span class="nottickedoff">g a b = if fst a < fst b then a else b</span></span>
|
||||
<span class="lineno"> 110 </span>
|
||||
<span class="lineno"> 111 </span>naive2 :: Ring Rational -> SSSP
|
||||
<span class="lineno"> 112 </span><span class="decl"><span class="nottickedoff">naive2 p = runST $ do</span>
|
||||
<span class="lineno"> 113 </span><span class="spaces"> </span><span class="nottickedoff">parents <- MV.replicate (ringSize p) (-1)</span>
|
||||
<span class="lineno"> 114 </span><span class="spaces"> </span><span class="nottickedoff">costs <- MV.replicate (ringSize p) (-1)</span>
|
||||
<span class="lineno"> 115 </span><span class="spaces"> </span><span class="nottickedoff">MV.write parents 0 0</span>
|
||||
<span class="lineno"> 116 </span><span class="spaces"> </span><span class="nottickedoff">MV.write costs 0 0</span>
|
||||
<span class="lineno"> 117 </span><span class="spaces"> </span><span class="nottickedoff">changedRef <- newSTRef False</span>
|
||||
<span class="lineno"> 118 </span><span class="spaces"> </span><span class="nottickedoff">let loop i</span>
|
||||
<span class="lineno"> 119 </span><span class="spaces"> </span><span class="nottickedoff">| i == ringSize p = do</span>
|
||||
<span class="lineno"> 120 </span><span class="spaces"> </span><span class="nottickedoff">changed <- readSTRef changedRef</span>
|
||||
<span class="lineno"> 121 </span><span class="spaces"> </span><span class="nottickedoff">when changed $ do</span>
|
||||
<span class="lineno"> 122 </span><span class="spaces"> </span><span class="nottickedoff">writeSTRef changedRef False</span>
|
||||
<span class="lineno"> 123 </span><span class="spaces"> </span><span class="nottickedoff">loop 0</span>
|
||||
<span class="lineno"> 124 </span><span class="spaces"> </span><span class="nottickedoff">| otherwise = do</span>
|
||||
<span class="lineno"> 125 </span><span class="spaces"> </span><span class="nottickedoff">myCost <- MV.read costs i</span>
|
||||
<span class="lineno"> 126 </span><span class="spaces"> </span><span class="nottickedoff">unless (myCost < 0) $</span>
|
||||
<span class="lineno"> 127 </span><span class="spaces"> </span><span class="nottickedoff">forM_ (visibility V.! i) $ \n -> do</span>
|
||||
<span class="lineno"> 128 </span><span class="spaces"> </span><span class="nottickedoff">-- n is visible from i.</span>
|
||||
<span class="lineno"> 129 </span><span class="spaces"> </span><span class="nottickedoff">theirCost <- MV.read costs n</span>
|
||||
<span class="lineno"> 130 </span><span class="spaces"> </span><span class="nottickedoff">let throughCost = myCost + approxDist (ringAccess p i) (ringAccess p n)</span>
|
||||
<span class="lineno"> 131 </span><span class="spaces"> </span><span class="nottickedoff">when (throughCost < theirCost || theirCost < 0) $ do</span>
|
||||
<span class="lineno"> 132 </span><span class="spaces"> </span><span class="nottickedoff">MV.write parents n i</span>
|
||||
<span class="lineno"> 133 </span><span class="spaces"> </span><span class="nottickedoff">MV.write costs n throughCost</span>
|
||||
<span class="lineno"> 134 </span><span class="spaces"> </span><span class="nottickedoff">writeSTRef changedRef True</span>
|
||||
<span class="lineno"> 135 </span><span class="spaces"> </span><span class="nottickedoff">loop (i+1)</span>
|
||||
<span class="lineno"> 136 </span><span class="spaces"> </span><span class="nottickedoff">loop 0</span>
|
||||
<span class="lineno"> 137 </span><span class="spaces"> </span><span class="nottickedoff">V.unsafeFreeze parents</span>
|
||||
<span class="lineno"> 138 </span><span class="spaces"> </span><span class="nottickedoff">where</span>
|
||||
<span class="lineno"> 139 </span><span class="spaces"> </span><span class="nottickedoff">visibility = visibilityArray p</span></span>
|
||||
<span class="lineno"> 140 </span>
|
||||
<span class="lineno"> 141 </span>data PDual = PDual (V.Vector Int) Rational [PDual]
|
||||
<span class="lineno"> 142 </span> deriving (<span class="decl"><span class="nottickedoff">Show</span></span>)
|
||||
<span class="lineno"> 143 </span>
|
||||
<span class="lineno"> 144 </span>toPDual :: Ring Rational -> Dual -> PDual
|
||||
<span class="lineno"> 145 </span><span class="decl"><span class="nottickedoff">toPDual p d =</span>
|
||||
<span class="lineno"> 146 </span><span class="spaces"> </span><span class="nottickedoff">case d of</span>
|
||||
<span class="lineno"> 147 </span><span class="spaces"> </span><span class="nottickedoff">Dual (a,b,c) l r -></span>
|
||||
<span class="lineno"> 148 </span><span class="spaces"> </span><span class="nottickedoff">PDual (V.fromList [a,b,c])</span>
|
||||
<span class="lineno"> 149 </span><span class="spaces"> </span><span class="nottickedoff">(area2X (ringAccess p a) (ringAccess p b) (ringAccess p c))</span>
|
||||
<span class="lineno"> 150 </span><span class="spaces"> </span><span class="nottickedoff">(catMaybes [ worker c a l, worker b c r])</span>
|
||||
<span class="lineno"> 151 </span><span class="spaces"> </span><span class="nottickedoff">where</span>
|
||||
<span class="lineno"> 152 </span><span class="spaces"> </span><span class="nottickedoff">worker _ _ EmptyDual = Nothing</span>
|
||||
<span class="lineno"> 153 </span><span class="spaces"> </span><span class="nottickedoff">worker a b (NodeDual x l r) = Just $</span>
|
||||
<span class="lineno"> 154 </span><span class="spaces"> </span><span class="nottickedoff">PDual (V.fromList [a,x,b])</span>
|
||||
<span class="lineno"> 155 </span><span class="spaces"> </span><span class="nottickedoff">(area2X (ringAccess p a) (ringAccess p x) (ringAccess p b))</span>
|
||||
<span class="lineno"> 156 </span><span class="spaces"> </span><span class="nottickedoff">(catMaybes [ worker x b l, worker a x r])</span></span>
|
||||
<span class="lineno"> 157 </span>
|
||||
<span class="lineno"> 158 </span>pdualSize :: PDual -> Int
|
||||
<span class="lineno"> 159 </span><span class="decl"><span class="nottickedoff">pdualSize (PDual _ _ children) = 1 + sum (map pdualSize children)</span></span>
|
||||
<span class="lineno"> 160 </span>
|
||||
<span class="lineno"> 161 </span>pdualArea :: PDual -> Rational
|
||||
<span class="lineno"> 162 </span><span class="decl"><span class="nottickedoff">pdualArea (PDual _ faceArea _) = faceArea</span></span>
|
||||
<span class="lineno"> 163 </span>
|
||||
<span class="lineno"> 164 </span>-- FIXME: 'origin' isn't used. Remove.
|
||||
<span class="lineno"> 165 </span>pdualReduce :: Ring Rational -> PDual -> Int -> PDual
|
||||
<span class="lineno"> 166 </span><span class="decl"><span class="nottickedoff">pdualReduce origin pdual n</span>
|
||||
<span class="lineno"> 167 </span><span class="spaces"> </span><span class="nottickedoff">| pdualSize pdual <= n = pdual</span>
|
||||
<span class="lineno"> 168 </span><span class="spaces"> </span><span class="nottickedoff">| otherwise =</span>
|
||||
<span class="lineno"> 169 </span><span class="spaces"> </span><span class="nottickedoff">let smallest = minimum $ pAreas pdual</span>
|
||||
<span class="lineno"> 170 </span><span class="spaces"> </span><span class="nottickedoff">in pdualReduce origin (merge smallest pdual) n</span>
|
||||
<span class="lineno"> 171 </span><span class="spaces"> </span><span class="nottickedoff">where</span>
|
||||
<span class="lineno"> 172 </span><span class="spaces"> </span><span class="nottickedoff">merge _s (PDual p faceArea []) = PDual p faceArea []</span>
|
||||
<span class="lineno"> 173 </span><span class="spaces"> </span><span class="nottickedoff">merge s (PDual p faceArea children)</span>
|
||||
<span class="lineno"> 174 </span><span class="spaces"> </span><span class="nottickedoff">| faceArea == s =</span>
|
||||
<span class="lineno"> 175 </span><span class="spaces"> </span><span class="nottickedoff">let (PDual p2 area2 children2:xs) = sortBy (comparing pdualArea) children</span>
|
||||
<span class="lineno"> 176 </span><span class="spaces"> </span><span class="nottickedoff">in PDual (joinP p p2) (faceArea+area2) (children2++xs)</span>
|
||||
<span class="lineno"> 177 </span><span class="spaces"> </span><span class="nottickedoff">| otherwise =</span>
|
||||
<span class="lineno"> 178 </span><span class="spaces"> </span><span class="nottickedoff">let (PDual p2 area2 children2:xs) = sortBy (comparing pdualArea) children</span>
|
||||
<span class="lineno"> 179 </span><span class="spaces"> </span><span class="nottickedoff">in if area2 == s</span>
|
||||
<span class="lineno"> 180 </span><span class="spaces"> </span><span class="nottickedoff">then PDual (joinP p p2) (faceArea+area2) (children2++xs)</span>
|
||||
<span class="lineno"> 181 </span><span class="spaces"> </span><span class="nottickedoff">else PDual p faceArea (map (merge s) children)</span>
|
||||
<span class="lineno"> 182 </span><span class="spaces"> </span><span class="nottickedoff">pAreas (PDual _ faceArea children) = faceArea : concatMap pAreas children</span>
|
||||
<span class="lineno"> 183 </span><span class="spaces"> </span><span class="nottickedoff">joinP a b = V.fromList (sort (V.toList a ++ V.toList b))</span></span>
|
||||
<span class="lineno"> 184 </span>
|
||||
<span class="lineno"> 185 </span>pdualRings :: Ring Rational -> PDual -> [Ring Rational]
|
||||
<span class="lineno"> 186 </span><span class="decl"><span class="nottickedoff">pdualRings p (PDual pts _area children) =</span>
|
||||
<span class="lineno"> 187 </span><span class="spaces"> </span><span class="nottickedoff">ringPack (V.map (ringAccess p) pts) : concatMap (pdualRings p) children</span></span>
|
||||
<span class="lineno"> 188 </span>
|
||||
<span class="lineno"> 189 </span>-- Dual of triangulated polygon
|
||||
<span class="lineno"> 190 </span>data Dual = Dual (Int,Int,Int) -- (a,b,c)
|
||||
<span class="lineno"> 191 </span> DualTree -- borders ca
|
||||
<span class="lineno"> 192 </span> DualTree -- borders bc
|
||||
<span class="lineno"> 193 </span> deriving (<span class="decl"><span class="nottickedoff">Show</span></span>)
|
||||
<span class="lineno"> 194 </span>
|
||||
<span class="lineno"> 195 </span>data DualTree
|
||||
<span class="lineno"> 196 </span> = EmptyDual
|
||||
<span class="lineno"> 197 </span> | NodeDual Int -- axb triangle, a and b are from parent.
|
||||
<span class="lineno"> 198 </span> DualTree -- borders xb
|
||||
<span class="lineno"> 199 </span> DualTree -- borders ax
|
||||
<span class="lineno"> 200 </span> deriving (<span class="decl"><span class="nottickedoff">Show</span></span>)
|
||||
<span class="lineno"> 201 </span>
|
||||
<span class="lineno"> 202 </span>drawDual :: Dual -> String
|
||||
<span class="lineno"> 203 </span><span class="decl"><span class="nottickedoff">drawDual d = drawTree $</span>
|
||||
<span class="lineno"> 204 </span><span class="spaces"> </span><span class="nottickedoff">case d of</span>
|
||||
<span class="lineno"> 205 </span><span class="spaces"> </span><span class="nottickedoff">Dual (a,b,c) l r -> Node (show (a,b,c)) [worker c a l, worker b c r]</span>
|
||||
<span class="lineno"> 206 </span><span class="spaces"> </span><span class="nottickedoff">where</span>
|
||||
<span class="lineno"> 207 </span><span class="spaces"> </span><span class="nottickedoff">worker _a _b EmptyDual = Node "Leaf" []</span>
|
||||
<span class="lineno"> 208 </span><span class="spaces"> </span><span class="nottickedoff">worker a b (NodeDual x l r) =</span>
|
||||
<span class="lineno"> 209 </span><span class="spaces"> </span><span class="nottickedoff">Node (show (b,a,x)) [worker x b l, worker a x r]</span></span>
|
||||
<span class="lineno"> 210 </span>
|
||||
<span class="lineno"> 211 </span>dualToTriangulation :: Ring Rational -> Dual -> Triangulation
|
||||
<span class="lineno"> 212 </span><span class="decl"><span class="nottickedoff">dualToTriangulation p d = edgesToTriangulation (ringSize p) $ filter goodEdge $</span>
|
||||
<span class="lineno"> 213 </span><span class="spaces"> </span><span class="nottickedoff">case d of</span>
|
||||
<span class="lineno"> 214 </span><span class="spaces"> </span><span class="nottickedoff">Dual (a,b,c) l r -></span>
|
||||
<span class="lineno"> 215 </span><span class="spaces"> </span><span class="nottickedoff">(a,b):(a,c):(b,c):worker c a l ++ worker b c r</span>
|
||||
<span class="lineno"> 216 </span><span class="spaces"> </span><span class="nottickedoff">where</span>
|
||||
<span class="lineno"> 217 </span><span class="spaces"> </span><span class="nottickedoff">goodEdge (a,b)</span>
|
||||
<span class="lineno"> 218 </span><span class="spaces"> </span><span class="nottickedoff">= a /= ringClamp p (b+1) && a /= ringClamp p (b-1)</span>
|
||||
<span class="lineno"> 219 </span><span class="spaces"> </span><span class="nottickedoff">worker _a _b EmptyDual = []</span>
|
||||
<span class="lineno"> 220 </span><span class="spaces"> </span><span class="nottickedoff">worker a b (NodeDual x l r) =</span>
|
||||
<span class="lineno"> 221 </span><span class="spaces"> </span><span class="nottickedoff">(a,x) : (x, b) : worker x b l ++ worker a x r</span></span>
|
||||
<span class="lineno"> 222 </span>
|
||||
<span class="lineno"> 223 </span>-- Dual path:
|
||||
<span class="lineno"> 224 </span>-- (Int,Int,Int) + V.Vector Int + V.Vector LeftOrRight
|
||||
<span class="lineno"> 225 </span>
|
||||
<span class="lineno"> 226 </span>-- simplifyDual :: DualTree -> DualTree
|
||||
<span class="lineno"> 227 </span>-- -- simplifyDual (NodeDual x EmptyDual EmptyDual) = NodeLeaf x
|
||||
<span class="lineno"> 228 </span>-- -- simplifyDual (NodeDual x l EmptyDual) = NodeDualL x l
|
||||
<span class="lineno"> 229 </span>-- -- simplifyDual (NodeDual x EmptyDual r) = NodeDualR x r
|
||||
<span class="lineno"> 230 </span>-- simplifyDual d = d
|
||||
<span class="lineno"> 231 </span>
|
||||
<span class="lineno"> 232 </span>dual :: Int -> Triangulation -> Dual
|
||||
<span class="lineno"> 233 </span><span class="decl"><span class="nottickedoff">dual root t =</span>
|
||||
<span class="lineno"> 234 </span><span class="spaces"> </span><span class="nottickedoff">case hasTriangle of</span>
|
||||
<span class="lineno"> 235 </span><span class="spaces"> </span><span class="nottickedoff">[] -> error "weird triangulation"</span>
|
||||
<span class="lineno"> 236 </span><span class="spaces"> </span><span class="nottickedoff">-- [] -> Dual (0,1,V.length t-1) EmptyDual (dualTree t (1, (V.length t-1)) 0)</span>
|
||||
<span class="lineno"> 237 </span><span class="spaces"> </span><span class="nottickedoff">(x:_) -> Dual (root,rootNext,x) (dualTree t (x,root) rootNext) (dualTree t (rootNext,x) root)</span>
|
||||
<span class="lineno"> 238 </span><span class="spaces"> </span><span class="nottickedoff">where</span>
|
||||
<span class="lineno"> 239 </span><span class="spaces"> </span><span class="nottickedoff">rootNext = idx (root+1)</span>
|
||||
<span class="lineno"> 240 </span><span class="spaces"> </span><span class="nottickedoff">rootPrev = idx (root-1)</span>
|
||||
<span class="lineno"> 241 </span><span class="spaces"> </span><span class="nottickedoff">rootNNext = idx (root+2)</span>
|
||||
<span class="lineno"> 242 </span><span class="spaces"> </span><span class="nottickedoff">idx i = i `mod` n</span>
|
||||
<span class="lineno"> 243 </span><span class="spaces"> </span><span class="nottickedoff">hasTriangle = (rootPrev : t V.! root) `intersect` (rootNNext : t V.! rootNext)</span>
|
||||
<span class="lineno"> 244 </span><span class="spaces"> </span><span class="nottickedoff">n = V.length t</span></span>
|
||||
<span class="lineno"> 245 </span>
|
||||
<span class="lineno"> 246 </span>-- a=6, b=0, e=1
|
||||
<span class="lineno"> 247 </span>dualTree :: Triangulation -> (Int,Int) -> Int -> DualTree
|
||||
<span class="lineno"> 248 </span><span class="decl"><span class="nottickedoff">dualTree t (a,b) e = -- simplifyDual $</span>
|
||||
<span class="lineno"> 249 </span><span class="spaces"> </span><span class="nottickedoff">case hasTriangle of</span>
|
||||
<span class="lineno"> 250 </span><span class="spaces"> </span><span class="nottickedoff">[] -> EmptyDual</span>
|
||||
<span class="lineno"> 251 </span><span class="spaces"> </span><span class="nottickedoff">[(ab)] -></span>
|
||||
<span class="lineno"> 252 </span><span class="spaces"> </span><span class="nottickedoff">NodeDual ab</span>
|
||||
<span class="lineno"> 253 </span><span class="spaces"> </span><span class="nottickedoff">(dualTree t (ab,b) a)</span>
|
||||
<span class="lineno"> 254 </span><span class="spaces"> </span><span class="nottickedoff">(dualTree t (a,ab) b)</span>
|
||||
<span class="lineno"> 255 </span><span class="spaces"> </span><span class="nottickedoff">_ -> error $ "Invalid triangulation: " ++ show (a,b,e,hasTriangle)</span>
|
||||
<span class="lineno"> 256 </span><span class="spaces"> </span><span class="nottickedoff">where</span>
|
||||
<span class="lineno"> 257 </span><span class="spaces"> </span><span class="nottickedoff">hasTriangle = (prev a : next a : t V.! a) `intersect` (prev b : next b : t V.! b)</span>
|
||||
<span class="lineno"> 258 </span><span class="spaces"> </span><span class="nottickedoff">\\ [e]</span>
|
||||
<span class="lineno"> 259 </span><span class="spaces"> </span><span class="nottickedoff">n = V.length t</span>
|
||||
<span class="lineno"> 260 </span><span class="spaces"> </span><span class="nottickedoff">next x = (x+1) `mod` n</span>
|
||||
<span class="lineno"> 261 </span><span class="spaces"> </span><span class="nottickedoff">prev x = (x-1) `mod` n</span></span>
|
||||
<span class="lineno"> 262 </span>
|
||||
<span class="lineno"> 263 </span>-- data MinMax = MinMax Int Int | MinMaxEmpty deriving (Show)
|
||||
<span class="lineno"> 264 </span>-- instance Semigroup MinMax where
|
||||
<span class="lineno"> 265 </span>-- MinMaxEmpty <> b = b
|
||||
<span class="lineno"> 266 </span>-- a <> MinMaxEmpty = a
|
||||
<span class="lineno"> 267 </span>-- MinMax a b <> MinMax c d
|
||||
<span class="lineno"> 268 </span>-- = MinMax (min a c) (max b d)
|
||||
<span class="lineno"> 269 </span>-- -- = MinMax c b
|
||||
<span class="lineno"> 270 </span>-- instance Monoid MinMax where
|
||||
<span class="lineno"> 271 </span>-- mempty = MinMaxEmpty
|
||||
<span class="lineno"> 272 </span>--
|
||||
<span class="lineno"> 273 </span>-- instance F.Measured MinMax Int where
|
||||
<span class="lineno"> 274 </span>-- measure i = MinMax i i
|
||||
<span class="lineno"> 275 </span>
|
||||
<span class="lineno"> 276 </span>-- dualRoot :: Dual -> Int
|
||||
<span class="lineno"> 277 </span>-- dualRoot (Dual (a,_,_) _ _) = a
|
||||
<span class="lineno"> 278 </span>
|
||||
<span class="lineno"> 279 </span>-- O(n*ln n), could be O(n) if I could figure out how to use fingertrees...
|
||||
<span class="lineno"> 280 </span>sssp :: (Fractional a, Ord a, Epsilon a) => Ring a -> Dual -> SSSP
|
||||
<span class="lineno"> 281 </span><span class="decl"><span class="nottickedoff">sssp p d = toSSSP $</span>
|
||||
<span class="lineno"> 282 </span><span class="spaces"> </span><span class="nottickedoff">case d of</span>
|
||||
<span class="lineno"> 283 </span><span class="spaces"> </span><span class="nottickedoff">Dual (a,b,c) l r -></span>
|
||||
<span class="lineno"> 284 </span><span class="spaces"> </span><span class="nottickedoff">(a, a) :</span>
|
||||
<span class="lineno"> 285 </span><span class="spaces"> </span><span class="nottickedoff">(b, a) :</span>
|
||||
<span class="lineno"> 286 </span><span class="spaces"> </span><span class="nottickedoff">(c, a) :</span>
|
||||
<span class="lineno"> 287 </span><span class="spaces"> </span><span class="nottickedoff">worker [c] [b] a r ++</span>
|
||||
<span class="lineno"> 288 </span><span class="spaces"> </span><span class="nottickedoff">loopLeft a c l</span>
|
||||
<span class="lineno"> 289 </span><span class="spaces"> </span><span class="nottickedoff">where</span>
|
||||
<span class="lineno"> 290 </span><span class="spaces"> </span><span class="nottickedoff">toSSSP edges =</span>
|
||||
<span class="lineno"> 291 </span><span class="spaces"> </span><span class="nottickedoff">(V.fromList . map snd . sortOn fst) edges</span>
|
||||
<span class="lineno"> 292 </span><span class="spaces"> </span><span class="nottickedoff">loopLeft a outer l =</span>
|
||||
<span class="lineno"> 293 </span><span class="spaces"> </span><span class="nottickedoff">case l of</span>
|
||||
<span class="lineno"> 294 </span><span class="spaces"> </span><span class="nottickedoff">EmptyDual -> []</span>
|
||||
<span class="lineno"> 295 </span><span class="spaces"> </span><span class="nottickedoff">NodeDual x l' r' -></span>
|
||||
<span class="lineno"> 296 </span><span class="spaces"> </span><span class="nottickedoff">(x,a) :</span>
|
||||
<span class="lineno"> 297 </span><span class="spaces"> </span><span class="nottickedoff">worker [x] [outer] a r' ++</span>
|
||||
<span class="lineno"> 298 </span><span class="spaces"> </span><span class="nottickedoff">loopLeft a x l'</span>
|
||||
<span class="lineno"> 299 </span><span class="spaces"> </span><span class="nottickedoff">searchFn _checkStep _cusp _x [] = Nothing</span>
|
||||
<span class="lineno"> 300 </span><span class="spaces"> </span><span class="nottickedoff">searchFn checkStep cusp x (y:ys)</span>
|
||||
<span class="lineno"> 301 </span><span class="spaces"> </span><span class="nottickedoff">| not (checkStep (ringAccess p cusp) (ringAccess p y) (ringAccess p x))</span>
|
||||
<span class="lineno"> 302 </span><span class="spaces"> </span><span class="nottickedoff">= Just $ helper [] y ys</span>
|
||||
<span class="lineno"> 303 </span><span class="spaces"> </span><span class="nottickedoff">| otherwise = Nothing</span>
|
||||
<span class="lineno"> 304 </span><span class="spaces"> </span><span class="nottickedoff">where</span>
|
||||
<span class="lineno"> 305 </span><span class="spaces"> </span><span class="nottickedoff">helper acc v [] = (v, [], reverse acc)</span>
|
||||
<span class="lineno"> 306 </span><span class="spaces"> </span><span class="nottickedoff">helper acc v1 (v2:vs)</span>
|
||||
<span class="lineno"> 307 </span><span class="spaces"> </span><span class="nottickedoff">| checkStep (ringAccess p v1) (ringAccess p v2) (ringAccess p x) =</span>
|
||||
<span class="lineno"> 308 </span><span class="spaces"> </span><span class="nottickedoff">(v1, v2:vs, reverse acc)</span>
|
||||
<span class="lineno"> 309 </span><span class="spaces"> </span><span class="nottickedoff">| otherwise = helper (v1:acc) v2 vs</span>
|
||||
<span class="lineno"> 310 </span><span class="spaces"> </span><span class="nottickedoff">searchRight = searchFn isLeftTurn</span>
|
||||
<span class="lineno"> 311 </span><span class="spaces"> </span><span class="nottickedoff">searchLeft = searchFn isRightTurn</span>
|
||||
<span class="lineno"> 312 </span><span class="spaces"> </span><span class="nottickedoff">-- adj x = x -- ringClamp p (x-dualRoot d)</span>
|
||||
<span class="lineno"> 313 </span><span class="spaces"> </span><span class="nottickedoff">-- optTrace msg =</span>
|
||||
<span class="lineno"> 314 </span><span class="spaces"> </span><span class="nottickedoff">-- if False -- dualRoot d == 1 || dualRoot d == 0</span>
|
||||
<span class="lineno"> 315 </span><span class="spaces"> </span><span class="nottickedoff">-- then trace msg</span>
|
||||
<span class="lineno"> 316 </span><span class="spaces"> </span><span class="nottickedoff">-- else id</span>
|
||||
<span class="lineno"> 317 </span><span class="spaces"> </span><span class="nottickedoff">worker _ _ _ EmptyDual = []</span>
|
||||
<span class="lineno"> 318 </span><span class="spaces"> </span><span class="nottickedoff">worker f1 f2 cusp (NodeDual x l r) =</span>
|
||||
<span class="lineno"> 319 </span><span class="spaces"> </span><span class="nottickedoff">-- (optTrace ("Funnel: " ++ show</span>
|
||||
<span class="lineno"> 320 </span><span class="spaces"> </span><span class="nottickedoff">-- (map adj $ toList f1</span>
|
||||
<span class="lineno"> 321 </span><span class="spaces"> </span><span class="nottickedoff">-- ,adj cusp</span>
|
||||
<span class="lineno"> 322 </span><span class="spaces"> </span><span class="nottickedoff">-- ,map adj $ toList f2</span>
|
||||
<span class="lineno"> 323 </span><span class="spaces"> </span><span class="nottickedoff">-- ,adj x</span>
|
||||
<span class="lineno"> 324 </span><span class="spaces"> </span><span class="nottickedoff">-- , dualRoot d))</span>
|
||||
<span class="lineno"> 325 </span><span class="spaces"> </span><span class="nottickedoff">-- ) $</span>
|
||||
<span class="lineno"> 326 </span><span class="spaces"> </span><span class="nottickedoff">case searchLeft cusp x (toList f1) of</span>
|
||||
<span class="lineno"> 327 </span><span class="spaces"> </span><span class="nottickedoff">Just (v, f1Hi, f1Lo) -></span>
|
||||
<span class="lineno"> 328 </span><span class="spaces"> </span><span class="nottickedoff">-- optTrace (" Visble from left: " ++ show (adj x,adj v)) $</span>
|
||||
<span class="lineno"> 329 </span><span class="spaces"> </span><span class="nottickedoff">(x, v::Int) :</span>
|
||||
<span class="lineno"> 330 </span><span class="spaces"> </span><span class="nottickedoff">worker f1Hi [x] v l ++</span>
|
||||
<span class="lineno"> 331 </span><span class="spaces"> </span><span class="nottickedoff">worker (f1Lo ++ [v, x]) f2 cusp r</span>
|
||||
<span class="lineno"> 332 </span><span class="spaces"> </span><span class="nottickedoff">Nothing -></span>
|
||||
<span class="lineno"> 333 </span><span class="spaces"> </span><span class="nottickedoff">case searchRight cusp x (toList f2) of</span>
|
||||
<span class="lineno"> 334 </span><span class="spaces"> </span><span class="nottickedoff">Just (v, f2Hi, f2Lo) -></span>
|
||||
<span class="lineno"> 335 </span><span class="spaces"> </span><span class="nottickedoff">-- optTrace (" Visble from right: " ++ show (adj x,adj v)) $</span>
|
||||
<span class="lineno"> 336 </span><span class="spaces"> </span><span class="nottickedoff">(x, v::Int) :</span>
|
||||
<span class="lineno"> 337 </span><span class="spaces"> </span><span class="nottickedoff">worker f1 (f2Lo ++ [v, x]) cusp l ++</span>
|
||||
<span class="lineno"> 338 </span><span class="spaces"> </span><span class="nottickedoff">worker [x] f2Hi v r</span>
|
||||
<span class="lineno"> 339 </span><span class="spaces"> </span><span class="nottickedoff">Nothing -></span>
|
||||
<span class="lineno"> 340 </span><span class="spaces"> </span><span class="nottickedoff">-- optTrace (" Visble from cusp: " ++ show (adj x,adj cusp)) $</span>
|
||||
<span class="lineno"> 341 </span><span class="spaces"> </span><span class="nottickedoff">(x, cusp::Int) :</span>
|
||||
<span class="lineno"> 342 </span><span class="spaces"> </span><span class="nottickedoff">worker f1 [x] cusp l ++</span>
|
||||
<span class="lineno"> 343 </span><span class="spaces"> </span><span class="nottickedoff">worker [x] f2 cusp r</span></span>
|
||||
|
||||
</pre>
|
||||
</body>
|
||||
|
|
|
|||
|
|
@ -19,88 +19,89 @@ span.spaces { background: white }
|
|||
<pre>
|
||||
<span class="lineno"> 1 </span>{-# LANGUAGE DataKinds #-}
|
||||
<span class="lineno"> 2 </span>{-# LANGUAGE ScopedTypeVariables #-}
|
||||
<span class="lineno"> 3 </span>module Reanimate.Math.Triangulate
|
||||
<span class="lineno"> 4 </span> ( Triangulation
|
||||
<span class="lineno"> 5 </span> , edgesToTriangulation
|
||||
<span class="lineno"> 6 </span> , edgesToTriangulationM
|
||||
<span class="lineno"> 7 </span> , trianglesToTriangulation
|
||||
<span class="lineno"> 8 </span> , trianglesToTriangulationM
|
||||
<span class="lineno"> 9 </span> , triangulate
|
||||
<span class="lineno"> 10 </span> )
|
||||
<span class="lineno"> 11 </span>where
|
||||
<span class="lineno"> 12 </span>
|
||||
<span class="lineno"> 13 </span>import Algorithms.Geometry.PolygonTriangulation.Triangulate (triangulate')
|
||||
<span class="lineno"> 14 </span>import Algorithms.Geometry.PolygonTriangulation.Types
|
||||
<span class="lineno"> 15 </span>import Control.Lens
|
||||
<span class="lineno"> 16 </span>import Control.Monad
|
||||
<span class="lineno"> 17 </span>import Control.Monad.ST
|
||||
<span class="lineno"> 18 </span>import Data.Ext
|
||||
<span class="lineno"> 19 </span>import Data.Geometry.PlanarSubdivision (PolygonFaceData)
|
||||
<span class="lineno"> 20 </span>import Data.Geometry.Point
|
||||
<span class="lineno"> 21 </span>import Data.Geometry.Polygon
|
||||
<span class="lineno"> 22 </span>import qualified Data.IntSet as ISet
|
||||
<span class="lineno"> 23 </span>import qualified Data.PlaneGraph as Geo
|
||||
<span class="lineno"> 24 </span>import Data.Proxy
|
||||
<span class="lineno"> 25 </span>import qualified Data.Vector as V
|
||||
<span class="lineno"> 26 </span>import qualified Data.Vector.Mutable as MV
|
||||
<span class="lineno"> 27 </span>import Linear.V2
|
||||
<span class="lineno"> 28 </span>import Reanimate.Math.Common
|
||||
<span class="lineno"> 29 </span>-- Max edges: n-2
|
||||
<span class="lineno"> 30 </span>-- Each edge is represented twice: 2n-4
|
||||
<span class="lineno"> 31 </span>-- Flat structure:
|
||||
<span class="lineno"> 32 </span>-- edges :: V.Vector Int -- max length (2n-4)
|
||||
<span class="lineno"> 33 </span>-- offsets :: V.Vector Int -- length n
|
||||
<span class="lineno"> 34 </span>-- Combine the two vectors? < n => offsets, >= n => edges?
|
||||
<span class="lineno"> 35 </span>type Triangulation = V.Vector [Int]
|
||||
<span class="lineno"> 36 </span>
|
||||
<span class="lineno"> 37 </span>-- FIXME: Move to Common or a Triangulation module
|
||||
<span class="lineno"> 38 </span>-- O(n)
|
||||
<span class="lineno"> 39 </span>edgesToTriangulation :: Int -> [(Int, Int)] -> Triangulation
|
||||
<span class="lineno"> 40 </span><span class="decl"><span class="nottickedoff">edgesToTriangulation size edges = runST $ do</span>
|
||||
<span class="lineno"> 41 </span><span class="spaces"> </span><span class="nottickedoff">v <- edgesToTriangulationM size edges</span>
|
||||
<span class="lineno"> 42 </span><span class="spaces"> </span><span class="nottickedoff">V.unsafeFreeze v</span></span>
|
||||
<span class="lineno"> 43 </span>
|
||||
<span class="lineno"> 44 </span>edgesToTriangulationM :: Int -> [(Int, Int)] -> ST s (V.MVector s [Int])
|
||||
<span class="lineno"> 45 </span><span class="decl"><span class="nottickedoff">edgesToTriangulationM size edges = do</span>
|
||||
<span class="lineno"> 46 </span><span class="spaces"> </span><span class="nottickedoff">v <- MV.replicate size []</span>
|
||||
<span class="lineno"> 47 </span><span class="spaces"> </span><span class="nottickedoff">forM_ edges $ \(e1, e2) -> do</span>
|
||||
<span class="lineno"> 48 </span><span class="spaces"> </span><span class="nottickedoff">MV.modify v (e1 :) e2</span>
|
||||
<span class="lineno"> 49 </span><span class="spaces"> </span><span class="nottickedoff">MV.modify v (e2 :) e1</span>
|
||||
<span class="lineno"> 50 </span><span class="spaces"> </span><span class="nottickedoff">forM_ [0 .. size - 1] $ \i -> MV.modify v (ISet.toList . ISet.fromList) i</span>
|
||||
<span class="lineno"> 51 </span><span class="spaces"> </span><span class="nottickedoff">return v</span></span>
|
||||
<span class="lineno"> 52 </span>
|
||||
<span class="lineno"> 53 </span>trianglesToTriangulation :: Int -> V.Vector (Int, Int, Int) -> Triangulation
|
||||
<span class="lineno"> 54 </span><span class="decl"><span class="nottickedoff">trianglesToTriangulation size edges = runST $ do</span>
|
||||
<span class="lineno"> 55 </span><span class="spaces"> </span><span class="nottickedoff">v <- trianglesToTriangulationM size edges</span>
|
||||
<span class="lineno"> 56 </span><span class="spaces"> </span><span class="nottickedoff">V.unsafeFreeze v</span></span>
|
||||
<span class="lineno"> 57 </span>
|
||||
<span class="lineno"> 58 </span>trianglesToTriangulationM
|
||||
<span class="lineno"> 59 </span> :: Int -> V.Vector (Int, Int, Int) -> ST s (V.MVector s [Int])
|
||||
<span class="lineno"> 60 </span><span class="decl"><span class="nottickedoff">trianglesToTriangulationM size trigs = do</span>
|
||||
<span class="lineno"> 61 </span><span class="spaces"> </span><span class="nottickedoff">v <- MV.replicate size []</span>
|
||||
<span class="lineno"> 62 </span><span class="spaces"> </span><span class="nottickedoff">forM_ (V.toList trigs) $ \(a, b, c) -> do</span>
|
||||
<span class="lineno"> 63 </span><span class="spaces"> </span><span class="nottickedoff">MV.modify v (\x -> b : c : x) a</span>
|
||||
<span class="lineno"> 64 </span><span class="spaces"> </span><span class="nottickedoff">MV.modify v (\x -> a : c : x) b</span>
|
||||
<span class="lineno"> 65 </span><span class="spaces"> </span><span class="nottickedoff">MV.modify v (\x -> a : b : x) c</span>
|
||||
<span class="lineno"> 66 </span><span class="spaces"> </span><span class="nottickedoff">forM_ [0 .. size - 1] $ \i -> MV.modify v (ISet.toList . ISet.fromList) i</span>
|
||||
<span class="lineno"> 67 </span><span class="spaces"> </span><span class="nottickedoff">return v</span></span>
|
||||
<span class="lineno"> 68 </span>
|
||||
<span class="lineno"> 3 </span>{-# OPTIONS_HADDOCK hide #-}
|
||||
<span class="lineno"> 4 </span>module Reanimate.Math.Triangulate
|
||||
<span class="lineno"> 5 </span> ( Triangulation
|
||||
<span class="lineno"> 6 </span> , edgesToTriangulation
|
||||
<span class="lineno"> 7 </span> , edgesToTriangulationM
|
||||
<span class="lineno"> 8 </span> , trianglesToTriangulation
|
||||
<span class="lineno"> 9 </span> , trianglesToTriangulationM
|
||||
<span class="lineno"> 10 </span> , triangulate
|
||||
<span class="lineno"> 11 </span> )
|
||||
<span class="lineno"> 12 </span>where
|
||||
<span class="lineno"> 13 </span>
|
||||
<span class="lineno"> 14 </span>import Algorithms.Geometry.PolygonTriangulation.Triangulate (triangulate')
|
||||
<span class="lineno"> 15 </span>import Algorithms.Geometry.PolygonTriangulation.Types
|
||||
<span class="lineno"> 16 </span>import Control.Lens
|
||||
<span class="lineno"> 17 </span>import Control.Monad
|
||||
<span class="lineno"> 18 </span>import Control.Monad.ST
|
||||
<span class="lineno"> 19 </span>import Data.Ext
|
||||
<span class="lineno"> 20 </span>import Data.Geometry.PlanarSubdivision (PolygonFaceData)
|
||||
<span class="lineno"> 21 </span>import Data.Geometry.Point
|
||||
<span class="lineno"> 22 </span>import Data.Geometry.Polygon
|
||||
<span class="lineno"> 23 </span>import qualified Data.IntSet as ISet
|
||||
<span class="lineno"> 24 </span>import qualified Data.PlaneGraph as Geo
|
||||
<span class="lineno"> 25 </span>import Data.Proxy
|
||||
<span class="lineno"> 26 </span>import qualified Data.Vector as V
|
||||
<span class="lineno"> 27 </span>import qualified Data.Vector.Mutable as MV
|
||||
<span class="lineno"> 28 </span>import Linear.V2
|
||||
<span class="lineno"> 29 </span>import Reanimate.Math.Common
|
||||
<span class="lineno"> 30 </span>-- Max edges: n-2
|
||||
<span class="lineno"> 31 </span>-- Each edge is represented twice: 2n-4
|
||||
<span class="lineno"> 32 </span>-- Flat structure:
|
||||
<span class="lineno"> 33 </span>-- edges :: V.Vector Int -- max length (2n-4)
|
||||
<span class="lineno"> 34 </span>-- offsets :: V.Vector Int -- length n
|
||||
<span class="lineno"> 35 </span>-- Combine the two vectors? < n => offsets, >= n => edges?
|
||||
<span class="lineno"> 36 </span>type Triangulation = V.Vector [Int]
|
||||
<span class="lineno"> 37 </span>
|
||||
<span class="lineno"> 38 </span>-- FIXME: Move to Common or a Triangulation module
|
||||
<span class="lineno"> 39 </span>-- O(n)
|
||||
<span class="lineno"> 40 </span>edgesToTriangulation :: Int -> [(Int, Int)] -> Triangulation
|
||||
<span class="lineno"> 41 </span><span class="decl"><span class="nottickedoff">edgesToTriangulation size edges = runST $ do</span>
|
||||
<span class="lineno"> 42 </span><span class="spaces"> </span><span class="nottickedoff">v <- edgesToTriangulationM size edges</span>
|
||||
<span class="lineno"> 43 </span><span class="spaces"> </span><span class="nottickedoff">V.unsafeFreeze v</span></span>
|
||||
<span class="lineno"> 44 </span>
|
||||
<span class="lineno"> 45 </span>edgesToTriangulationM :: Int -> [(Int, Int)] -> ST s (V.MVector s [Int])
|
||||
<span class="lineno"> 46 </span><span class="decl"><span class="nottickedoff">edgesToTriangulationM size edges = do</span>
|
||||
<span class="lineno"> 47 </span><span class="spaces"> </span><span class="nottickedoff">v <- MV.replicate size []</span>
|
||||
<span class="lineno"> 48 </span><span class="spaces"> </span><span class="nottickedoff">forM_ edges $ \(e1, e2) -> do</span>
|
||||
<span class="lineno"> 49 </span><span class="spaces"> </span><span class="nottickedoff">MV.modify v (e1 :) e2</span>
|
||||
<span class="lineno"> 50 </span><span class="spaces"> </span><span class="nottickedoff">MV.modify v (e2 :) e1</span>
|
||||
<span class="lineno"> 51 </span><span class="spaces"> </span><span class="nottickedoff">forM_ [0 .. size - 1] $ \i -> MV.modify v (ISet.toList . ISet.fromList) i</span>
|
||||
<span class="lineno"> 52 </span><span class="spaces"> </span><span class="nottickedoff">return v</span></span>
|
||||
<span class="lineno"> 53 </span>
|
||||
<span class="lineno"> 54 </span>trianglesToTriangulation :: Int -> V.Vector (Int, Int, Int) -> Triangulation
|
||||
<span class="lineno"> 55 </span><span class="decl"><span class="nottickedoff">trianglesToTriangulation size edges = runST $ do</span>
|
||||
<span class="lineno"> 56 </span><span class="spaces"> </span><span class="nottickedoff">v <- trianglesToTriangulationM size edges</span>
|
||||
<span class="lineno"> 57 </span><span class="spaces"> </span><span class="nottickedoff">V.unsafeFreeze v</span></span>
|
||||
<span class="lineno"> 58 </span>
|
||||
<span class="lineno"> 59 </span>trianglesToTriangulationM
|
||||
<span class="lineno"> 60 </span> :: Int -> V.Vector (Int, Int, Int) -> ST s (V.MVector s [Int])
|
||||
<span class="lineno"> 61 </span><span class="decl"><span class="nottickedoff">trianglesToTriangulationM size trigs = do</span>
|
||||
<span class="lineno"> 62 </span><span class="spaces"> </span><span class="nottickedoff">v <- MV.replicate size []</span>
|
||||
<span class="lineno"> 63 </span><span class="spaces"> </span><span class="nottickedoff">forM_ (V.toList trigs) $ \(a, b, c) -> do</span>
|
||||
<span class="lineno"> 64 </span><span class="spaces"> </span><span class="nottickedoff">MV.modify v (\x -> b : c : x) a</span>
|
||||
<span class="lineno"> 65 </span><span class="spaces"> </span><span class="nottickedoff">MV.modify v (\x -> a : c : x) b</span>
|
||||
<span class="lineno"> 66 </span><span class="spaces"> </span><span class="nottickedoff">MV.modify v (\x -> a : b : x) c</span>
|
||||
<span class="lineno"> 67 </span><span class="spaces"> </span><span class="nottickedoff">forM_ [0 .. size - 1] $ \i -> MV.modify v (ISet.toList . ISet.fromList) i</span>
|
||||
<span class="lineno"> 68 </span><span class="spaces"> </span><span class="nottickedoff">return v</span></span>
|
||||
<span class="lineno"> 69 </span>
|
||||
<span class="lineno"> 70 </span>triangulate :: forall a. (Fractional a, Ord a) => Ring a -> Triangulation
|
||||
<span class="lineno"> 71 </span><span class="decl"><span class="nottickedoff">triangulate r = edgesToTriangulation (ringSize r) ds</span>
|
||||
<span class="lineno"> 72 </span><span class="spaces"> </span><span class="nottickedoff">where</span>
|
||||
<span class="lineno"> 73 </span><span class="spaces"> </span><span class="nottickedoff">ds :: [(Int,Int)]</span>
|
||||
<span class="lineno"> 74 </span><span class="spaces"> </span><span class="nottickedoff">ds =</span>
|
||||
<span class="lineno"> 75 </span><span class="spaces"> </span><span class="nottickedoff">[ (a^.Geo.vData, b^.Geo.vData)</span>
|
||||
<span class="lineno"> 76 </span><span class="spaces"> </span><span class="nottickedoff">| (d, Diagonal) <- V.toList (Geo.edges pg)</span>
|
||||
<span class="lineno"> 77 </span><span class="spaces"> </span><span class="nottickedoff">, let (a,b) = Geo.endPointData d pg ]</span>
|
||||
<span class="lineno"> 78 </span><span class="spaces"> </span><span class="nottickedoff">pg :: Geo.PlaneGraph () Int PolygonEdgeType PolygonFaceData a</span>
|
||||
<span class="lineno"> 79 </span><span class="spaces"> </span><span class="nottickedoff">pg = triangulate' Proxy p</span>
|
||||
<span class="lineno"> 80 </span><span class="spaces"> </span><span class="nottickedoff">p :: SimplePolygon Int a</span>
|
||||
<span class="lineno"> 81 </span><span class="spaces"> </span><span class="nottickedoff">p = fromPoints $</span>
|
||||
<span class="lineno"> 82 </span><span class="spaces"> </span><span class="nottickedoff">[ Point2 x y :+ n</span>
|
||||
<span class="lineno"> 83 </span><span class="spaces"> </span><span class="nottickedoff">| (n,V2 x y) <- zip [0..] (V.toList (ringUnpack r)) ]</span></span>
|
||||
<span class="lineno"> 84 </span> -- ringUnpack
|
||||
<span class="lineno"> 70 </span>
|
||||
<span class="lineno"> 71 </span>triangulate :: forall a. (Fractional a, Ord a) => Ring a -> Triangulation
|
||||
<span class="lineno"> 72 </span><span class="decl"><span class="nottickedoff">triangulate r = edgesToTriangulation (ringSize r) ds</span>
|
||||
<span class="lineno"> 73 </span><span class="spaces"> </span><span class="nottickedoff">where</span>
|
||||
<span class="lineno"> 74 </span><span class="spaces"> </span><span class="nottickedoff">ds :: [(Int,Int)]</span>
|
||||
<span class="lineno"> 75 </span><span class="spaces"> </span><span class="nottickedoff">ds =</span>
|
||||
<span class="lineno"> 76 </span><span class="spaces"> </span><span class="nottickedoff">[ (a^.Geo.vData, b^.Geo.vData)</span>
|
||||
<span class="lineno"> 77 </span><span class="spaces"> </span><span class="nottickedoff">| (d, Diagonal) <- V.toList (Geo.edges pg)</span>
|
||||
<span class="lineno"> 78 </span><span class="spaces"> </span><span class="nottickedoff">, let (a,b) = Geo.endPointData d pg ]</span>
|
||||
<span class="lineno"> 79 </span><span class="spaces"> </span><span class="nottickedoff">pg :: Geo.PlaneGraph () Int PolygonEdgeType PolygonFaceData a</span>
|
||||
<span class="lineno"> 80 </span><span class="spaces"> </span><span class="nottickedoff">pg = triangulate' Proxy p</span>
|
||||
<span class="lineno"> 81 </span><span class="spaces"> </span><span class="nottickedoff">p :: SimplePolygon Int a</span>
|
||||
<span class="lineno"> 82 </span><span class="spaces"> </span><span class="nottickedoff">p = fromPoints $</span>
|
||||
<span class="lineno"> 83 </span><span class="spaces"> </span><span class="nottickedoff">[ Point2 x y :+ n</span>
|
||||
<span class="lineno"> 84 </span><span class="spaces"> </span><span class="nottickedoff">| (n,V2 x y) <- zip [0..] (V.toList (ringUnpack r)) ]</span></span>
|
||||
<span class="lineno"> 85 </span> -- ringUnpack
|
||||
|
||||
</pre>
|
||||
</body>
|
||||
|
|
|
|||
|
|
@ -20,214 +20,221 @@ span.spaces { background: white }
|
|||
<span class="lineno"> 1 </span>{-# LANGUAGE RecordWildCards #-}
|
||||
<span class="lineno"> 2 </span>{-# LANGUAGE TupleSections #-}
|
||||
<span class="lineno"> 3 </span>{-# LANGUAGE UnicodeSyntax #-}
|
||||
<span class="lineno"> 4 </span>module Reanimate.Morph.Common
|
||||
<span class="lineno"> 5 </span> ( PointCorrespondence
|
||||
<span class="lineno"> 6 </span> , Trajectory
|
||||
<span class="lineno"> 7 </span> , ObjectCorrespondence
|
||||
<span class="lineno"> 8 </span> , Morph(..)
|
||||
<span class="lineno"> 9 </span> , morph
|
||||
<span class="lineno"> 10 </span> , splitObjectCorrespondence
|
||||
<span class="lineno"> 11 </span> , dupObjectCorrespondence
|
||||
<span class="lineno"> 12 </span> , genesisObjectCorrespondence
|
||||
<span class="lineno"> 13 </span> , toShapes
|
||||
<span class="lineno"> 14 </span> , normalizePolygons
|
||||
<span class="lineno"> 15 </span> , annotatePolygons
|
||||
<span class="lineno"> 16 </span> , unsafeSVGToPolygon
|
||||
<span class="lineno"> 17 </span> ) where
|
||||
<span class="lineno"> 18 </span>
|
||||
<span class="lineno"> 19 </span>import Control.Lens
|
||||
<span class="lineno"> 20 </span>import qualified Data.Vector as V
|
||||
<span class="lineno"> 21 </span>import Graphics.SvgTree (DrawAttributes, Texture (..),
|
||||
<span class="lineno"> 22 </span> drawAttributes, fillColor,
|
||||
<span class="lineno"> 23 </span> fillOpacity, groupOpacity,
|
||||
<span class="lineno"> 24 </span> strokeColor, strokeOpacity)
|
||||
<span class="lineno"> 25 </span>import Linear.V2
|
||||
<span class="lineno"> 26 </span>import Reanimate.Animation
|
||||
<span class="lineno"> 27 </span>import Reanimate.ColorComponents
|
||||
<span class="lineno"> 28 </span>import Reanimate.Ease
|
||||
<span class="lineno"> 29 </span>import Reanimate.Math.Polygon (APolygon, Epsilon, Polygon,
|
||||
<span class="lineno"> 30 </span> mkPolygon, pAddPoints, pCentroid,
|
||||
<span class="lineno"> 31 </span> pCutEqual, pSize, polygonPoints)
|
||||
<span class="lineno"> 32 </span>import Reanimate.PolyShape
|
||||
<span class="lineno"> 33 </span>import Reanimate.Svg
|
||||
<span class="lineno"> 34 </span>
|
||||
<span class="lineno"> 35 </span>-- import Debug.Trace
|
||||
<span class="lineno"> 36 </span>
|
||||
<span class="lineno"> 37 </span>-- Correspondence
|
||||
<span class="lineno"> 38 </span>-- Trajectory
|
||||
<span class="lineno"> 39 </span>-- Color interpolation
|
||||
<span class="lineno"> 40 </span>-- Polygon holes
|
||||
<span class="lineno"> 41 </span>-- Polygon splitting
|
||||
<span class="lineno"> 42 </span>
|
||||
<span class="lineno"> 43 </span>-- Graphical polygon? FIXME: Come up with a better name.
|
||||
<span class="lineno"> 44 </span>type GPolygon = (DrawAttributes, Polygon)
|
||||
<span class="lineno"> 45 </span>
|
||||
<span class="lineno"> 46 </span>-- | Method determining how points in the source polygon align with
|
||||
<span class="lineno"> 47 </span>-- points in the target polygon.
|
||||
<span class="lineno"> 48 </span>type PointCorrespondence = Polygon → Polygon → (Polygon, Polygon)
|
||||
<span class="lineno"> 4 </span>{-|
|
||||
<span class="lineno"> 5 </span>Copyright : Written by David Himmelstrup
|
||||
<span class="lineno"> 6 </span>License : Unlicense
|
||||
<span class="lineno"> 7 </span>Maintainer : lemmih@gmail.com
|
||||
<span class="lineno"> 8 </span>Stability : experimental
|
||||
<span class="lineno"> 9 </span>Portability : POSIX
|
||||
<span class="lineno"> 10 </span>-}
|
||||
<span class="lineno"> 11 </span>module Reanimate.Morph.Common
|
||||
<span class="lineno"> 12 </span> ( PointCorrespondence
|
||||
<span class="lineno"> 13 </span> , Trajectory
|
||||
<span class="lineno"> 14 </span> , ObjectCorrespondence
|
||||
<span class="lineno"> 15 </span> , Morph(..)
|
||||
<span class="lineno"> 16 </span> , morph
|
||||
<span class="lineno"> 17 </span> , splitObjectCorrespondence
|
||||
<span class="lineno"> 18 </span> , dupObjectCorrespondence
|
||||
<span class="lineno"> 19 </span> , genesisObjectCorrespondence
|
||||
<span class="lineno"> 20 </span> , toShapes
|
||||
<span class="lineno"> 21 </span> , normalizePolygons
|
||||
<span class="lineno"> 22 </span> , annotatePolygons
|
||||
<span class="lineno"> 23 </span> , unsafeSVGToPolygon
|
||||
<span class="lineno"> 24 </span> ) where
|
||||
<span class="lineno"> 25 </span>
|
||||
<span class="lineno"> 26 </span>import Control.Lens
|
||||
<span class="lineno"> 27 </span>import qualified Data.Vector as V
|
||||
<span class="lineno"> 28 </span>import Graphics.SvgTree (DrawAttributes, Texture (..),
|
||||
<span class="lineno"> 29 </span> drawAttributes, fillColor,
|
||||
<span class="lineno"> 30 </span> fillOpacity, groupOpacity,
|
||||
<span class="lineno"> 31 </span> strokeColor, strokeOpacity)
|
||||
<span class="lineno"> 32 </span>import Linear.V2
|
||||
<span class="lineno"> 33 </span>import Reanimate.Animation
|
||||
<span class="lineno"> 34 </span>import Reanimate.ColorComponents
|
||||
<span class="lineno"> 35 </span>import Reanimate.Ease
|
||||
<span class="lineno"> 36 </span>import Reanimate.Math.Polygon (APolygon, Epsilon, Polygon,
|
||||
<span class="lineno"> 37 </span> mkPolygon, pAddPoints, pCentroid,
|
||||
<span class="lineno"> 38 </span> pCutEqual, pSize, polygonPoints)
|
||||
<span class="lineno"> 39 </span>import Reanimate.PolyShape
|
||||
<span class="lineno"> 40 </span>import Reanimate.Svg
|
||||
<span class="lineno"> 41 </span>
|
||||
<span class="lineno"> 42 </span>-- import Debug.Trace
|
||||
<span class="lineno"> 43 </span>
|
||||
<span class="lineno"> 44 </span>-- Correspondence
|
||||
<span class="lineno"> 45 </span>-- Trajectory
|
||||
<span class="lineno"> 46 </span>-- Color interpolation
|
||||
<span class="lineno"> 47 </span>-- Polygon holes
|
||||
<span class="lineno"> 48 </span>-- Polygon splitting
|
||||
<span class="lineno"> 49 </span>
|
||||
<span class="lineno"> 50 </span>-- | Method for interpolating between two aligned polygons.
|
||||
<span class="lineno"> 51 </span>type Trajectory = (Polygon, Polygon) → (Double → Polygon)
|
||||
<span class="lineno"> 50 </span>-- Graphical polygon? FIXME: Come up with a better name.
|
||||
<span class="lineno"> 51 </span>type GPolygon = (DrawAttributes, Polygon)
|
||||
<span class="lineno"> 52 </span>
|
||||
<span class="lineno"> 53 </span>-- | Method for pairing sets of polygons.
|
||||
<span class="lineno"> 54 </span>type ObjectCorrespondence = [GPolygon] → [GPolygon] → [(GPolygon, GPolygon)]
|
||||
<span class="lineno"> 55 </span>
|
||||
<span class="lineno"> 56 </span>-- | Morphing strategy
|
||||
<span class="lineno"> 57 </span>data Morph = Morph
|
||||
<span class="lineno"> 58 </span> { <span class="nottickedoff"><span class="decl"><span class="nottickedoff">morphTolerance</span></span></span> :: Double
|
||||
<span class="lineno"> 59 </span> -- ^ Morphing curves is not always possible and
|
||||
<span class="lineno"> 60 </span> -- sometimes shapes are reduced to polygons or meta-curves.
|
||||
<span class="lineno"> 61 </span> -- This parameter determined the accuracy of this transformation.
|
||||
<span class="lineno"> 62 </span> , <span class="nottickedoff"><span class="decl"><span class="nottickedoff">morphColorComponents</span></span></span> :: ColorComponents
|
||||
<span class="lineno"> 63 </span> -- ^ Color components used for color interpolation. LAB is usually
|
||||
<span class="lineno"> 64 </span> -- the best option here.
|
||||
<span class="lineno"> 65 </span> , <span class="nottickedoff"><span class="decl"><span class="nottickedoff">morphPointCorrespondence</span></span></span> :: PointCorrespondence
|
||||
<span class="lineno"> 66 </span> -- ^ Desired point-correspondence algorithm.
|
||||
<span class="lineno"> 67 </span> , <span class="nottickedoff"><span class="decl"><span class="nottickedoff">morphTrajectory</span></span></span> :: Trajectory
|
||||
<span class="lineno"> 68 </span> -- ^ Desired interpolation algorithm.
|
||||
<span class="lineno"> 69 </span> , <span class="nottickedoff"><span class="decl"><span class="nottickedoff">morphObjectCorrespondence</span></span></span> :: ObjectCorrespondence
|
||||
<span class="lineno"> 70 </span> -- ^ Desired object-correspondence algorithm.
|
||||
<span class="lineno"> 71 </span> }
|
||||
<span class="lineno"> 72 </span>
|
||||
<span class="lineno"> 73 </span>{-# INLINE morph #-}
|
||||
<span class="lineno"> 74 </span>-- | Apply morphing strategy to interpolate between two SVG images.
|
||||
<span class="lineno"> 75 </span>morph :: Morph -> SVG -> SVG -> Double -> SVG
|
||||
<span class="lineno"> 76 </span><span class="decl"><span class="istickedoff">morph Morph{..} src dst = \t -></span>
|
||||
<span class="lineno"> 77 </span><span class="spaces"> </span><span class="istickedoff">case <span class="nottickedoff">t</span> of</span>
|
||||
<span class="lineno"> 78 </span><span class="spaces"> </span><span class="istickedoff">-- 0 -> lowerTransformations src</span>
|
||||
<span class="lineno"> 79 </span><span class="spaces"> </span><span class="istickedoff">-- 1 -> lowerTransformations dst</span>
|
||||
<span class="lineno"> 80 </span><span class="spaces"> </span><span class="istickedoff">_ -> mkGroup</span>
|
||||
<span class="lineno"> 81 </span><span class="spaces"> </span><span class="istickedoff">[ render (genPoints t)</span>
|
||||
<span class="lineno"> 82 </span><span class="spaces"> </span><span class="istickedoff">& drawAttributes .~ genAttrs <span class="nottickedoff">t</span></span>
|
||||
<span class="lineno"> 83 </span><span class="spaces"> </span><span class="istickedoff">| (genAttrs, genPoints) <- gens</span>
|
||||
<span class="lineno"> 84 </span><span class="spaces"> </span><span class="istickedoff">]</span>
|
||||
<span class="lineno"> 85 </span><span class="spaces"> </span><span class="istickedoff">where</span>
|
||||
<span class="lineno"> 86 </span><span class="spaces"> </span><span class="istickedoff">render p = mkLinePathClosed</span>
|
||||
<span class="lineno"> 87 </span><span class="spaces"> </span><span class="istickedoff">[ (x,y) | V2 x y <- map (fmap realToFrac) $ V.toList $ polygonPoints p ]</span>
|
||||
<span class="lineno"> 88 </span><span class="spaces"> </span><span class="istickedoff">srcShapes = toShapes morphTolerance src</span>
|
||||
<span class="lineno"> 89 </span><span class="spaces"> </span><span class="istickedoff">dstShapes = toShapes morphTolerance dst</span>
|
||||
<span class="lineno"> 90 </span><span class="spaces"> </span><span class="istickedoff">pairs = morphObjectCorrespondence srcShapes dstShapes</span>
|
||||
<span class="lineno"> 91 </span><span class="spaces"> </span><span class="istickedoff">gens =</span>
|
||||
<span class="lineno"> 92 </span><span class="spaces"> </span><span class="istickedoff">[ (interpolateAttrs <span class="nottickedoff">morphColorComponents</span> srcAttr <span class="nottickedoff">dstAttr</span>, morphTrajectory arranged)</span>
|
||||
<span class="lineno"> 93 </span><span class="spaces"> </span><span class="istickedoff">| ((srcAttr, srcPoly'), (dstAttr, dstPoly')) <- pairs</span>
|
||||
<span class="lineno"> 94 </span><span class="spaces"> </span><span class="istickedoff">, let arranged = morphPointCorrespondence srcPoly' dstPoly'</span>
|
||||
<span class="lineno"> 95 </span><span class="spaces"> </span><span class="istickedoff">]</span></span>
|
||||
<span class="lineno"> 96 </span>
|
||||
<span class="lineno"> 97 </span>-- | Add points to each polygon such that they end up with same size.
|
||||
<span class="lineno"> 98 </span>normalizePolygons :: (Real a, Fractional a, Epsilon a) => APolygon a -> APolygon a -> (APolygon a, APolygon a)
|
||||
<span class="lineno"> 99 </span><span class="decl"><span class="istickedoff">normalizePolygons src dst =</span>
|
||||
<span class="lineno"> 100 </span><span class="spaces"> </span><span class="istickedoff">(pAddPoints (max 0 $ dstN-srcN) src</span>
|
||||
<span class="lineno"> 101 </span><span class="spaces"> </span><span class="istickedoff">,pAddPoints (max 0 $ srcN-dstN) dst)</span>
|
||||
<span class="lineno"> 102 </span><span class="spaces"> </span><span class="istickedoff">where</span>
|
||||
<span class="lineno"> 103 </span><span class="spaces"> </span><span class="istickedoff">srcN = pSize src</span>
|
||||
<span class="lineno"> 104 </span><span class="spaces"> </span><span class="istickedoff">dstN = pSize dst</span></span>
|
||||
<span class="lineno"> 105 </span>
|
||||
<span class="lineno"> 106 </span>interpolateAttrs :: ColorComponents -> DrawAttributes -> DrawAttributes -> Double -> DrawAttributes
|
||||
<span class="lineno"> 107 </span><span class="decl"><span class="istickedoff">interpolateAttrs colorComps src dst t =</span>
|
||||
<span class="lineno"> 108 </span><span class="spaces"> </span><span class="istickedoff">src & fillColor .~ (<span class="nottickedoff">interpColor</span> <$> src^.fillColor <*> <span class="nottickedoff">dst^.fillColor</span>)</span>
|
||||
<span class="lineno"> 109 </span><span class="spaces"> </span><span class="istickedoff">& strokeColor .~ (<span class="nottickedoff">interpColor</span> <$> src^.strokeColor <*> <span class="nottickedoff">dst^.strokeColor</span>)</span>
|
||||
<span class="lineno"> 110 </span><span class="spaces"> </span><span class="istickedoff">& fillOpacity .~ (<span class="nottickedoff">interpOpacity</span> <$> src^.fillOpacity <*> <span class="nottickedoff">dst^.fillOpacity</span>)</span>
|
||||
<span class="lineno"> 111 </span><span class="spaces"> </span><span class="istickedoff">& groupOpacity .~ (<span class="nottickedoff">interpOpacity</span> <$> src^.groupOpacity <*> <span class="nottickedoff">dst^.groupOpacity</span>)</span>
|
||||
<span class="lineno"> 112 </span><span class="spaces"> </span><span class="istickedoff">& strokeOpacity .~ (<span class="nottickedoff">interpOpacity</span> <$> src^.strokeOpacity <*> <span class="nottickedoff">dst^.strokeOpacity</span>)</span>
|
||||
<span class="lineno"> 113 </span><span class="spaces"> </span><span class="istickedoff">where</span>
|
||||
<span class="lineno"> 114 </span><span class="spaces"> </span><span class="istickedoff"><span class="nottickedoff">interpColor (ColorRef a) (ColorRef b) =</span></span>
|
||||
<span class="lineno"> 115 </span><span class="spaces"> </span><span class="istickedoff"><span class="nottickedoff">ColorRef $ interpolateRGBA8 colorComps a b t</span></span>
|
||||
<span class="lineno"> 116 </span><span class="spaces"> </span><span class="istickedoff"><span class="nottickedoff">-- interpolateColor (ColorRef a) FillNone = ColorRef a</span></span>
|
||||
<span class="lineno"> 117 </span><span class="spaces"> </span><span class="istickedoff"><span class="nottickedoff">interpColor a _ = a</span></span>
|
||||
<span class="lineno"> 118 </span><span class="spaces"> </span><span class="istickedoff"><span class="nottickedoff">interpOpacity a b = realToFrac (fromToS (realToFrac a) (realToFrac b) t)</span></span></span>
|
||||
<span class="lineno"> 119 </span>
|
||||
<span class="lineno"> 120 </span>-- | Object-correspondence algorithm that spawn objects as necessary.
|
||||
<span class="lineno"> 121 </span>genesisObjectCorrespondence :: ObjectCorrespondence
|
||||
<span class="lineno"> 122 </span><span class="decl"><span class="nottickedoff">genesisObjectCorrespondence left right =</span>
|
||||
<span class="lineno"> 123 </span><span class="spaces"> </span><span class="nottickedoff">case (left, right) of</span>
|
||||
<span class="lineno"> 124 </span><span class="spaces"> </span><span class="nottickedoff">([] , []) -> []</span>
|
||||
<span class="lineno"> 125 </span><span class="spaces"> </span><span class="nottickedoff">([], (y1,y2):ys) -></span>
|
||||
<span class="lineno"> 126 </span><span class="spaces"> </span><span class="nottickedoff">((y1,y2), (y1, emptyFrom y2 y2)) : genesisObjectCorrespondence [] ys</span>
|
||||
<span class="lineno"> 127 </span><span class="spaces"> </span><span class="nottickedoff">((x1,x2):xs, []) -></span>
|
||||
<span class="lineno"> 128 </span><span class="spaces"> </span><span class="nottickedoff">((x1,x2), (x1, emptyFrom x2 x2)) : genesisObjectCorrespondence xs []</span>
|
||||
<span class="lineno"> 129 </span><span class="spaces"> </span><span class="nottickedoff">(x:xs, y:ys) -></span>
|
||||
<span class="lineno"> 130 </span><span class="spaces"> </span><span class="nottickedoff">(x,y) : genesisObjectCorrespondence xs ys</span>
|
||||
<span class="lineno"> 131 </span><span class="spaces"> </span><span class="nottickedoff">where</span>
|
||||
<span class="lineno"> 132 </span><span class="spaces"> </span><span class="nottickedoff">emptyFrom a b = mkPolygon $ V.map (const $ pCentroid a) (polygonPoints b)</span></span>
|
||||
<span class="lineno"> 133 </span>
|
||||
<span class="lineno"> 134 </span>-- | Object-correspondence algorithm that duplicate objects as necessary.
|
||||
<span class="lineno"> 135 </span>dupObjectCorrespondence :: ObjectCorrespondence
|
||||
<span class="lineno"> 136 </span><span class="decl"><span class="nottickedoff">dupObjectCorrespondence left right =</span>
|
||||
<span class="lineno"> 137 </span><span class="spaces"> </span><span class="nottickedoff">case (left, right) of</span>
|
||||
<span class="lineno"> 138 </span><span class="spaces"> </span><span class="nottickedoff">(_, []) -> []</span>
|
||||
<span class="lineno"> 139 </span><span class="spaces"> </span><span class="nottickedoff">([], _) -> []</span>
|
||||
<span class="lineno"> 140 </span><span class="spaces"> </span><span class="nottickedoff">([x], [y]) -></span>
|
||||
<span class="lineno"> 141 </span><span class="spaces"> </span><span class="nottickedoff">[(x,y)]</span>
|
||||
<span class="lineno"> 142 </span><span class="spaces"> </span><span class="nottickedoff">([(x1,x2)], yShapes) -></span>
|
||||
<span class="lineno"> 143 </span><span class="spaces"> </span><span class="nottickedoff">let x2s = replicate (length yShapes) x2</span>
|
||||
<span class="lineno"> 144 </span><span class="spaces"> </span><span class="nottickedoff">in dupObjectCorrespondence (map (x1,) x2s) yShapes</span>
|
||||
<span class="lineno"> 145 </span><span class="spaces"> </span><span class="nottickedoff">(xShapes, [(y1,y2)]) -></span>
|
||||
<span class="lineno"> 146 </span><span class="spaces"> </span><span class="nottickedoff">let y2s = replicate (length xShapes) y2</span>
|
||||
<span class="lineno"> 147 </span><span class="spaces"> </span><span class="nottickedoff">in dupObjectCorrespondence xShapes (map (y1,) y2s)</span>
|
||||
<span class="lineno"> 148 </span><span class="spaces"> </span><span class="nottickedoff">(x:xs, y:ys) -></span>
|
||||
<span class="lineno"> 149 </span><span class="spaces"> </span><span class="nottickedoff">(x, y) : dupObjectCorrespondence xs ys</span></span>
|
||||
<span class="lineno"> 150 </span>
|
||||
<span class="lineno"> 151 </span>-- | Object-correspondence algorithm that splits objects in smaller pieces
|
||||
<span class="lineno"> 152 </span>-- as necessary.
|
||||
<span class="lineno"> 153 </span>splitObjectCorrespondence :: ObjectCorrespondence
|
||||
<span class="lineno"> 154 </span>-- splitObjectCorrespondence = dupObjectCorrespondence
|
||||
<span class="lineno"> 155 </span><span class="decl"><span class="istickedoff">splitObjectCorrespondence left right =</span>
|
||||
<span class="lineno"> 156 </span><span class="spaces"> </span><span class="istickedoff">case (left, right) of</span>
|
||||
<span class="lineno"> 157 </span><span class="spaces"> </span><span class="istickedoff">(_, []) -> <span class="nottickedoff">[]</span></span>
|
||||
<span class="lineno"> 158 </span><span class="spaces"> </span><span class="istickedoff">([], _) -> <span class="nottickedoff">[]</span></span>
|
||||
<span class="lineno"> 159 </span><span class="spaces"> </span><span class="istickedoff">([x], [y]) -></span>
|
||||
<span class="lineno"> 160 </span><span class="spaces"> </span><span class="istickedoff">[(x,y)]</span>
|
||||
<span class="lineno"> 161 </span><span class="spaces"> </span><span class="istickedoff">([(x1,x2)], yShapes) -></span>
|
||||
<span class="lineno"> 162 </span><span class="spaces"> </span><span class="istickedoff"><span class="nottickedoff">let x2s = splitPolygon (length yShapes) x2</span></span>
|
||||
<span class="lineno"> 163 </span><span class="spaces"> </span><span class="istickedoff"><span class="nottickedoff">in splitObjectCorrespondence (map (x1,) x2s) yShapes</span></span>
|
||||
<span class="lineno"> 164 </span><span class="spaces"> </span><span class="istickedoff">(xShapes, [(y1,y2)]) -></span>
|
||||
<span class="lineno"> 165 </span><span class="spaces"> </span><span class="istickedoff"><span class="nottickedoff">let y2s = splitPolygon (length xShapes) y2</span></span>
|
||||
<span class="lineno"> 166 </span><span class="spaces"> </span><span class="istickedoff"><span class="nottickedoff">in splitObjectCorrespondence xShapes (map (y1,) y2s)</span></span>
|
||||
<span class="lineno"> 167 </span><span class="spaces"> </span><span class="istickedoff">(x:xs, y:ys) -></span>
|
||||
<span class="lineno"> 168 </span><span class="spaces"> </span><span class="istickedoff"><span class="nottickedoff">(x,y) : splitObjectCorrespondence xs ys</span></span></span>
|
||||
<span class="lineno"> 169 </span>
|
||||
<span class="lineno"> 170 </span>splitPolygon :: Int -> Polygon -> [Polygon]
|
||||
<span class="lineno"> 171 </span><span class="decl"><span class="nottickedoff">splitPolygon 1 p = [p]</span>
|
||||
<span class="lineno"> 172 </span><span class="spaces"></span><span class="nottickedoff">splitPolygon n p =</span>
|
||||
<span class="lineno"> 173 </span><span class="spaces"> </span><span class="nottickedoff">let (a,b) = pCutEqual p</span>
|
||||
<span class="lineno"> 174 </span><span class="spaces"> </span><span class="nottickedoff">in splitPolygon (n`div`2) a ++ splitPolygon ((n+1)`div`2) b</span></span>
|
||||
<span class="lineno"> 175 </span>
|
||||
<span class="lineno"> 176 </span>-- joinPairs :: Correspondence -> [(DrawAttributes, PolyShape)] -> [(DrawAttributes, PolyShape)]
|
||||
<span class="lineno"> 177 </span>-- -> [(DrawAttributes, DrawAttributes, [(RPoint, RPoint)])]
|
||||
<span class="lineno"> 178 </span>-- joinPairs _ _ [] = []
|
||||
<span class="lineno"> 179 </span>-- joinPairs _ [] _ = []
|
||||
<span class="lineno"> 180 </span>-- joinPairs corr [(x1,x2)] [(y1,y2)] =
|
||||
<span class="lineno"> 181 </span>-- [(x1,y1, corr x2 y2)]
|
||||
<span class="lineno"> 182 </span>-- joinPairs corr [(x1,x2)] yShapes =
|
||||
<span class="lineno"> 183 </span>-- let x2s = splitPolyShape 0.001 (length yShapes) x2
|
||||
<span class="lineno"> 184 </span>-- in joinPairs corr (map (x1,) x2s) yShapes
|
||||
<span class="lineno"> 185 </span>-- joinPairs corr xShapes [(y1,y2)] =
|
||||
<span class="lineno"> 186 </span>-- let y2s = reverse $ splitPolyShape 0.001 (length xShapes) y2
|
||||
<span class="lineno"> 187 </span>-- in joinPairs corr xShapes (map (y1,) y2s)
|
||||
<span class="lineno"> 188 </span>-- joinPairs corr ((x1,x2):xs) ((y1,y2):ys) =
|
||||
<span class="lineno"> 189 </span>-- (x1,y1, corr x2 y2) : joinPairs corr xs ys
|
||||
<span class="lineno"> 190 </span>-- joinPairs _ _ _ = []
|
||||
<span class="lineno"> 191 </span>
|
||||
<span class="lineno"> 192 </span>-- FIXME: sort by size, smallest to largest
|
||||
<span class="lineno"> 193 </span>-- | Extract shapes and their graphical attributes from an SVG node.
|
||||
<span class="lineno"> 194 </span>toShapes :: Double -> SVG -> [(DrawAttributes, Polygon)]
|
||||
<span class="lineno"> 195 </span><span class="decl"><span class="istickedoff">toShapes tol src =</span>
|
||||
<span class="lineno"> 196 </span><span class="spaces"> </span><span class="istickedoff">[ (attrs, plToPolygon tol shape)</span>
|
||||
<span class="lineno"> 197 </span><span class="spaces"> </span><span class="istickedoff">| (_, attrs, glyph) <- svgGlyphs $ lowerTransformations $ pathify src</span>
|
||||
<span class="lineno"> 198 </span><span class="spaces"> </span><span class="istickedoff">, shape <- map mergePolyShapeHoles $ plGroupShapes $ svgToPolyShapes glyph</span>
|
||||
<span class="lineno"> 199 </span><span class="spaces"> </span><span class="istickedoff">]</span></span>
|
||||
<span class="lineno"> 200 </span>
|
||||
<span class="lineno"> 201 </span>-- | Extract the first polygon in an SVG node. Will fail if there
|
||||
<span class="lineno"> 202 </span>-- are no acceptable shapes.
|
||||
<span class="lineno"> 203 </span>unsafeSVGToPolygon :: Double -> SVG -> Polygon
|
||||
<span class="lineno"> 204 </span><span class="decl"><span class="nottickedoff">unsafeSVGToPolygon tol src = snd $ head $ toShapes tol src</span></span>
|
||||
<span class="lineno"> 205 </span>
|
||||
<span class="lineno"> 206 </span>-- | Map over each polygon in an SVG node.
|
||||
<span class="lineno"> 207 </span>annotatePolygons :: (Polygon -> SVG) -> SVG -> SVG
|
||||
<span class="lineno"> 208 </span><span class="decl"><span class="nottickedoff">annotatePolygons fn svg = mkGroup</span>
|
||||
<span class="lineno"> 209 </span><span class="spaces"> </span><span class="nottickedoff">[ fn poly & drawAttributes .~ attr</span>
|
||||
<span class="lineno"> 210 </span><span class="spaces"> </span><span class="nottickedoff">| (attr, poly) <- toShapes 0.001 svg</span>
|
||||
<span class="lineno"> 211 </span><span class="spaces"> </span><span class="nottickedoff">]</span></span>
|
||||
<span class="lineno"> 53 </span>-- | Method determining how points in the source polygon align with
|
||||
<span class="lineno"> 54 </span>-- points in the target polygon.
|
||||
<span class="lineno"> 55 </span>type PointCorrespondence = Polygon → Polygon → (Polygon, Polygon)
|
||||
<span class="lineno"> 56 </span>
|
||||
<span class="lineno"> 57 </span>-- | Method for interpolating between two aligned polygons.
|
||||
<span class="lineno"> 58 </span>type Trajectory = (Polygon, Polygon) → (Double → Polygon)
|
||||
<span class="lineno"> 59 </span>
|
||||
<span class="lineno"> 60 </span>-- | Method for pairing sets of polygons.
|
||||
<span class="lineno"> 61 </span>type ObjectCorrespondence = [GPolygon] → [GPolygon] → [(GPolygon, GPolygon)]
|
||||
<span class="lineno"> 62 </span>
|
||||
<span class="lineno"> 63 </span>-- | Morphing strategy
|
||||
<span class="lineno"> 64 </span>data Morph = Morph
|
||||
<span class="lineno"> 65 </span> { <span class="nottickedoff"><span class="decl"><span class="nottickedoff">morphTolerance</span></span></span> :: Double
|
||||
<span class="lineno"> 66 </span> -- ^ Morphing curves is not always possible and
|
||||
<span class="lineno"> 67 </span> -- sometimes shapes are reduced to polygons or meta-curves.
|
||||
<span class="lineno"> 68 </span> -- This parameter determined the accuracy of this transformation.
|
||||
<span class="lineno"> 69 </span> , <span class="nottickedoff"><span class="decl"><span class="nottickedoff">morphColorComponents</span></span></span> :: ColorComponents
|
||||
<span class="lineno"> 70 </span> -- ^ Color components used for color interpolation. LAB is usually
|
||||
<span class="lineno"> 71 </span> -- the best option here.
|
||||
<span class="lineno"> 72 </span> , <span class="nottickedoff"><span class="decl"><span class="nottickedoff">morphPointCorrespondence</span></span></span> :: PointCorrespondence
|
||||
<span class="lineno"> 73 </span> -- ^ Desired point-correspondence algorithm.
|
||||
<span class="lineno"> 74 </span> , <span class="nottickedoff"><span class="decl"><span class="nottickedoff">morphTrajectory</span></span></span> :: Trajectory
|
||||
<span class="lineno"> 75 </span> -- ^ Desired interpolation algorithm.
|
||||
<span class="lineno"> 76 </span> , <span class="nottickedoff"><span class="decl"><span class="nottickedoff">morphObjectCorrespondence</span></span></span> :: ObjectCorrespondence
|
||||
<span class="lineno"> 77 </span> -- ^ Desired object-correspondence algorithm.
|
||||
<span class="lineno"> 78 </span> }
|
||||
<span class="lineno"> 79 </span>
|
||||
<span class="lineno"> 80 </span>{-# INLINE morph #-}
|
||||
<span class="lineno"> 81 </span>-- | Apply morphing strategy to interpolate between two SVG images.
|
||||
<span class="lineno"> 82 </span>morph :: Morph -> SVG -> SVG -> Double -> SVG
|
||||
<span class="lineno"> 83 </span><span class="decl"><span class="istickedoff">morph Morph{..} src dst = \t -></span>
|
||||
<span class="lineno"> 84 </span><span class="spaces"> </span><span class="istickedoff">case <span class="nottickedoff">t</span> of</span>
|
||||
<span class="lineno"> 85 </span><span class="spaces"> </span><span class="istickedoff">-- 0 -> lowerTransformations src</span>
|
||||
<span class="lineno"> 86 </span><span class="spaces"> </span><span class="istickedoff">-- 1 -> lowerTransformations dst</span>
|
||||
<span class="lineno"> 87 </span><span class="spaces"> </span><span class="istickedoff">_ -> mkGroup</span>
|
||||
<span class="lineno"> 88 </span><span class="spaces"> </span><span class="istickedoff">[ render (genPoints t)</span>
|
||||
<span class="lineno"> 89 </span><span class="spaces"> </span><span class="istickedoff">& drawAttributes .~ genAttrs <span class="nottickedoff">t</span></span>
|
||||
<span class="lineno"> 90 </span><span class="spaces"> </span><span class="istickedoff">| (genAttrs, genPoints) <- gens</span>
|
||||
<span class="lineno"> 91 </span><span class="spaces"> </span><span class="istickedoff">]</span>
|
||||
<span class="lineno"> 92 </span><span class="spaces"> </span><span class="istickedoff">where</span>
|
||||
<span class="lineno"> 93 </span><span class="spaces"> </span><span class="istickedoff">render p = mkLinePathClosed</span>
|
||||
<span class="lineno"> 94 </span><span class="spaces"> </span><span class="istickedoff">[ (x,y) | V2 x y <- map (fmap realToFrac) $ V.toList $ polygonPoints p ]</span>
|
||||
<span class="lineno"> 95 </span><span class="spaces"> </span><span class="istickedoff">srcShapes = toShapes morphTolerance src</span>
|
||||
<span class="lineno"> 96 </span><span class="spaces"> </span><span class="istickedoff">dstShapes = toShapes morphTolerance dst</span>
|
||||
<span class="lineno"> 97 </span><span class="spaces"> </span><span class="istickedoff">pairs = morphObjectCorrespondence srcShapes dstShapes</span>
|
||||
<span class="lineno"> 98 </span><span class="spaces"> </span><span class="istickedoff">gens =</span>
|
||||
<span class="lineno"> 99 </span><span class="spaces"> </span><span class="istickedoff">[ (interpolateAttrs <span class="nottickedoff">morphColorComponents</span> srcAttr <span class="nottickedoff">dstAttr</span>, morphTrajectory arranged)</span>
|
||||
<span class="lineno"> 100 </span><span class="spaces"> </span><span class="istickedoff">| ((srcAttr, srcPoly'), (dstAttr, dstPoly')) <- pairs</span>
|
||||
<span class="lineno"> 101 </span><span class="spaces"> </span><span class="istickedoff">, let arranged = morphPointCorrespondence srcPoly' dstPoly'</span>
|
||||
<span class="lineno"> 102 </span><span class="spaces"> </span><span class="istickedoff">]</span></span>
|
||||
<span class="lineno"> 103 </span>
|
||||
<span class="lineno"> 104 </span>-- | Add points to each polygon such that they end up with same size.
|
||||
<span class="lineno"> 105 </span>normalizePolygons :: (Real a, Fractional a, Epsilon a) => APolygon a -> APolygon a -> (APolygon a, APolygon a)
|
||||
<span class="lineno"> 106 </span><span class="decl"><span class="istickedoff">normalizePolygons src dst =</span>
|
||||
<span class="lineno"> 107 </span><span class="spaces"> </span><span class="istickedoff">(pAddPoints (max 0 $ dstN-srcN) src</span>
|
||||
<span class="lineno"> 108 </span><span class="spaces"> </span><span class="istickedoff">,pAddPoints (max 0 $ srcN-dstN) dst)</span>
|
||||
<span class="lineno"> 109 </span><span class="spaces"> </span><span class="istickedoff">where</span>
|
||||
<span class="lineno"> 110 </span><span class="spaces"> </span><span class="istickedoff">srcN = pSize src</span>
|
||||
<span class="lineno"> 111 </span><span class="spaces"> </span><span class="istickedoff">dstN = pSize dst</span></span>
|
||||
<span class="lineno"> 112 </span>
|
||||
<span class="lineno"> 113 </span>interpolateAttrs :: ColorComponents -> DrawAttributes -> DrawAttributes -> Double -> DrawAttributes
|
||||
<span class="lineno"> 114 </span><span class="decl"><span class="istickedoff">interpolateAttrs colorComps src dst t =</span>
|
||||
<span class="lineno"> 115 </span><span class="spaces"> </span><span class="istickedoff">src & fillColor .~ (<span class="nottickedoff">interpColor</span> <$> src^.fillColor <*> <span class="nottickedoff">dst^.fillColor</span>)</span>
|
||||
<span class="lineno"> 116 </span><span class="spaces"> </span><span class="istickedoff">& strokeColor .~ (<span class="nottickedoff">interpColor</span> <$> src^.strokeColor <*> <span class="nottickedoff">dst^.strokeColor</span>)</span>
|
||||
<span class="lineno"> 117 </span><span class="spaces"> </span><span class="istickedoff">& fillOpacity .~ (<span class="nottickedoff">interpOpacity</span> <$> src^.fillOpacity <*> <span class="nottickedoff">dst^.fillOpacity</span>)</span>
|
||||
<span class="lineno"> 118 </span><span class="spaces"> </span><span class="istickedoff">& groupOpacity .~ (<span class="nottickedoff">interpOpacity</span> <$> src^.groupOpacity <*> <span class="nottickedoff">dst^.groupOpacity</span>)</span>
|
||||
<span class="lineno"> 119 </span><span class="spaces"> </span><span class="istickedoff">& strokeOpacity .~ (<span class="nottickedoff">interpOpacity</span> <$> src^.strokeOpacity <*> <span class="nottickedoff">dst^.strokeOpacity</span>)</span>
|
||||
<span class="lineno"> 120 </span><span class="spaces"> </span><span class="istickedoff">where</span>
|
||||
<span class="lineno"> 121 </span><span class="spaces"> </span><span class="istickedoff"><span class="nottickedoff">interpColor (ColorRef a) (ColorRef b) =</span></span>
|
||||
<span class="lineno"> 122 </span><span class="spaces"> </span><span class="istickedoff"><span class="nottickedoff">ColorRef $ interpolateRGBA8 colorComps a b t</span></span>
|
||||
<span class="lineno"> 123 </span><span class="spaces"> </span><span class="istickedoff"><span class="nottickedoff">-- interpolateColor (ColorRef a) FillNone = ColorRef a</span></span>
|
||||
<span class="lineno"> 124 </span><span class="spaces"> </span><span class="istickedoff"><span class="nottickedoff">interpColor a _ = a</span></span>
|
||||
<span class="lineno"> 125 </span><span class="spaces"> </span><span class="istickedoff"><span class="nottickedoff">interpOpacity a b = realToFrac (fromToS (realToFrac a) (realToFrac b) t)</span></span></span>
|
||||
<span class="lineno"> 126 </span>
|
||||
<span class="lineno"> 127 </span>-- | Object-correspondence algorithm that spawn objects as necessary.
|
||||
<span class="lineno"> 128 </span>genesisObjectCorrespondence :: ObjectCorrespondence
|
||||
<span class="lineno"> 129 </span><span class="decl"><span class="nottickedoff">genesisObjectCorrespondence left right =</span>
|
||||
<span class="lineno"> 130 </span><span class="spaces"> </span><span class="nottickedoff">case (left, right) of</span>
|
||||
<span class="lineno"> 131 </span><span class="spaces"> </span><span class="nottickedoff">([] , []) -> []</span>
|
||||
<span class="lineno"> 132 </span><span class="spaces"> </span><span class="nottickedoff">([], (y1,y2):ys) -></span>
|
||||
<span class="lineno"> 133 </span><span class="spaces"> </span><span class="nottickedoff">((y1,y2), (y1, emptyFrom y2 y2)) : genesisObjectCorrespondence [] ys</span>
|
||||
<span class="lineno"> 134 </span><span class="spaces"> </span><span class="nottickedoff">((x1,x2):xs, []) -></span>
|
||||
<span class="lineno"> 135 </span><span class="spaces"> </span><span class="nottickedoff">((x1,x2), (x1, emptyFrom x2 x2)) : genesisObjectCorrespondence xs []</span>
|
||||
<span class="lineno"> 136 </span><span class="spaces"> </span><span class="nottickedoff">(x:xs, y:ys) -></span>
|
||||
<span class="lineno"> 137 </span><span class="spaces"> </span><span class="nottickedoff">(x,y) : genesisObjectCorrespondence xs ys</span>
|
||||
<span class="lineno"> 138 </span><span class="spaces"> </span><span class="nottickedoff">where</span>
|
||||
<span class="lineno"> 139 </span><span class="spaces"> </span><span class="nottickedoff">emptyFrom a b = mkPolygon $ V.map (const $ pCentroid a) (polygonPoints b)</span></span>
|
||||
<span class="lineno"> 140 </span>
|
||||
<span class="lineno"> 141 </span>-- | Object-correspondence algorithm that duplicate objects as necessary.
|
||||
<span class="lineno"> 142 </span>dupObjectCorrespondence :: ObjectCorrespondence
|
||||
<span class="lineno"> 143 </span><span class="decl"><span class="nottickedoff">dupObjectCorrespondence left right =</span>
|
||||
<span class="lineno"> 144 </span><span class="spaces"> </span><span class="nottickedoff">case (left, right) of</span>
|
||||
<span class="lineno"> 145 </span><span class="spaces"> </span><span class="nottickedoff">(_, []) -> []</span>
|
||||
<span class="lineno"> 146 </span><span class="spaces"> </span><span class="nottickedoff">([], _) -> []</span>
|
||||
<span class="lineno"> 147 </span><span class="spaces"> </span><span class="nottickedoff">([x], [y]) -></span>
|
||||
<span class="lineno"> 148 </span><span class="spaces"> </span><span class="nottickedoff">[(x,y)]</span>
|
||||
<span class="lineno"> 149 </span><span class="spaces"> </span><span class="nottickedoff">([(x1,x2)], yShapes) -></span>
|
||||
<span class="lineno"> 150 </span><span class="spaces"> </span><span class="nottickedoff">let x2s = replicate (length yShapes) x2</span>
|
||||
<span class="lineno"> 151 </span><span class="spaces"> </span><span class="nottickedoff">in dupObjectCorrespondence (map (x1,) x2s) yShapes</span>
|
||||
<span class="lineno"> 152 </span><span class="spaces"> </span><span class="nottickedoff">(xShapes, [(y1,y2)]) -></span>
|
||||
<span class="lineno"> 153 </span><span class="spaces"> </span><span class="nottickedoff">let y2s = replicate (length xShapes) y2</span>
|
||||
<span class="lineno"> 154 </span><span class="spaces"> </span><span class="nottickedoff">in dupObjectCorrespondence xShapes (map (y1,) y2s)</span>
|
||||
<span class="lineno"> 155 </span><span class="spaces"> </span><span class="nottickedoff">(x:xs, y:ys) -></span>
|
||||
<span class="lineno"> 156 </span><span class="spaces"> </span><span class="nottickedoff">(x, y) : dupObjectCorrespondence xs ys</span></span>
|
||||
<span class="lineno"> 157 </span>
|
||||
<span class="lineno"> 158 </span>-- | Object-correspondence algorithm that splits objects in smaller pieces
|
||||
<span class="lineno"> 159 </span>-- as necessary.
|
||||
<span class="lineno"> 160 </span>splitObjectCorrespondence :: ObjectCorrespondence
|
||||
<span class="lineno"> 161 </span>-- splitObjectCorrespondence = dupObjectCorrespondence
|
||||
<span class="lineno"> 162 </span><span class="decl"><span class="istickedoff">splitObjectCorrespondence left right =</span>
|
||||
<span class="lineno"> 163 </span><span class="spaces"> </span><span class="istickedoff">case (left, right) of</span>
|
||||
<span class="lineno"> 164 </span><span class="spaces"> </span><span class="istickedoff">(_, []) -> <span class="nottickedoff">[]</span></span>
|
||||
<span class="lineno"> 165 </span><span class="spaces"> </span><span class="istickedoff">([], _) -> <span class="nottickedoff">[]</span></span>
|
||||
<span class="lineno"> 166 </span><span class="spaces"> </span><span class="istickedoff">([x], [y]) -></span>
|
||||
<span class="lineno"> 167 </span><span class="spaces"> </span><span class="istickedoff">[(x,y)]</span>
|
||||
<span class="lineno"> 168 </span><span class="spaces"> </span><span class="istickedoff">([(x1,x2)], yShapes) -></span>
|
||||
<span class="lineno"> 169 </span><span class="spaces"> </span><span class="istickedoff"><span class="nottickedoff">let x2s = splitPolygon (length yShapes) x2</span></span>
|
||||
<span class="lineno"> 170 </span><span class="spaces"> </span><span class="istickedoff"><span class="nottickedoff">in splitObjectCorrespondence (map (x1,) x2s) yShapes</span></span>
|
||||
<span class="lineno"> 171 </span><span class="spaces"> </span><span class="istickedoff">(xShapes, [(y1,y2)]) -></span>
|
||||
<span class="lineno"> 172 </span><span class="spaces"> </span><span class="istickedoff"><span class="nottickedoff">let y2s = splitPolygon (length xShapes) y2</span></span>
|
||||
<span class="lineno"> 173 </span><span class="spaces"> </span><span class="istickedoff"><span class="nottickedoff">in splitObjectCorrespondence xShapes (map (y1,) y2s)</span></span>
|
||||
<span class="lineno"> 174 </span><span class="spaces"> </span><span class="istickedoff">(x:xs, y:ys) -></span>
|
||||
<span class="lineno"> 175 </span><span class="spaces"> </span><span class="istickedoff"><span class="nottickedoff">(x,y) : splitObjectCorrespondence xs ys</span></span></span>
|
||||
<span class="lineno"> 176 </span>
|
||||
<span class="lineno"> 177 </span>splitPolygon :: Int -> Polygon -> [Polygon]
|
||||
<span class="lineno"> 178 </span><span class="decl"><span class="nottickedoff">splitPolygon 1 p = [p]</span>
|
||||
<span class="lineno"> 179 </span><span class="spaces"></span><span class="nottickedoff">splitPolygon n p =</span>
|
||||
<span class="lineno"> 180 </span><span class="spaces"> </span><span class="nottickedoff">let (a,b) = pCutEqual p</span>
|
||||
<span class="lineno"> 181 </span><span class="spaces"> </span><span class="nottickedoff">in splitPolygon (n`div`2) a ++ splitPolygon ((n+1)`div`2) b</span></span>
|
||||
<span class="lineno"> 182 </span>
|
||||
<span class="lineno"> 183 </span>-- joinPairs :: Correspondence -> [(DrawAttributes, PolyShape)] -> [(DrawAttributes, PolyShape)]
|
||||
<span class="lineno"> 184 </span>-- -> [(DrawAttributes, DrawAttributes, [(RPoint, RPoint)])]
|
||||
<span class="lineno"> 185 </span>-- joinPairs _ _ [] = []
|
||||
<span class="lineno"> 186 </span>-- joinPairs _ [] _ = []
|
||||
<span class="lineno"> 187 </span>-- joinPairs corr [(x1,x2)] [(y1,y2)] =
|
||||
<span class="lineno"> 188 </span>-- [(x1,y1, corr x2 y2)]
|
||||
<span class="lineno"> 189 </span>-- joinPairs corr [(x1,x2)] yShapes =
|
||||
<span class="lineno"> 190 </span>-- let x2s = splitPolyShape 0.001 (length yShapes) x2
|
||||
<span class="lineno"> 191 </span>-- in joinPairs corr (map (x1,) x2s) yShapes
|
||||
<span class="lineno"> 192 </span>-- joinPairs corr xShapes [(y1,y2)] =
|
||||
<span class="lineno"> 193 </span>-- let y2s = reverse $ splitPolyShape 0.001 (length xShapes) y2
|
||||
<span class="lineno"> 194 </span>-- in joinPairs corr xShapes (map (y1,) y2s)
|
||||
<span class="lineno"> 195 </span>-- joinPairs corr ((x1,x2):xs) ((y1,y2):ys) =
|
||||
<span class="lineno"> 196 </span>-- (x1,y1, corr x2 y2) : joinPairs corr xs ys
|
||||
<span class="lineno"> 197 </span>-- joinPairs _ _ _ = []
|
||||
<span class="lineno"> 198 </span>
|
||||
<span class="lineno"> 199 </span>-- FIXME: sort by size, smallest to largest
|
||||
<span class="lineno"> 200 </span>-- | Extract shapes and their graphical attributes from an SVG node.
|
||||
<span class="lineno"> 201 </span>toShapes :: Double -> SVG -> [(DrawAttributes, Polygon)]
|
||||
<span class="lineno"> 202 </span><span class="decl"><span class="istickedoff">toShapes tol src =</span>
|
||||
<span class="lineno"> 203 </span><span class="spaces"> </span><span class="istickedoff">[ (attrs, plToPolygon tol shape)</span>
|
||||
<span class="lineno"> 204 </span><span class="spaces"> </span><span class="istickedoff">| (_, attrs, glyph) <- svgGlyphs $ lowerTransformations $ pathify src</span>
|
||||
<span class="lineno"> 205 </span><span class="spaces"> </span><span class="istickedoff">, shape <- map mergePolyShapeHoles $ plGroupShapes $ svgToPolyShapes glyph</span>
|
||||
<span class="lineno"> 206 </span><span class="spaces"> </span><span class="istickedoff">]</span></span>
|
||||
<span class="lineno"> 207 </span>
|
||||
<span class="lineno"> 208 </span>-- | Extract the first polygon in an SVG node. Will fail if there
|
||||
<span class="lineno"> 209 </span>-- are no acceptable shapes.
|
||||
<span class="lineno"> 210 </span>unsafeSVGToPolygon :: Double -> SVG -> Polygon
|
||||
<span class="lineno"> 211 </span><span class="decl"><span class="nottickedoff">unsafeSVGToPolygon tol src = snd $ head $ toShapes tol src</span></span>
|
||||
<span class="lineno"> 212 </span>
|
||||
<span class="lineno"> 213 </span>-- | Map over each polygon in an SVG node.
|
||||
<span class="lineno"> 214 </span>annotatePolygons :: (Polygon -> SVG) -> SVG -> SVG
|
||||
<span class="lineno"> 215 </span><span class="decl"><span class="nottickedoff">annotatePolygons fn svg = mkGroup</span>
|
||||
<span class="lineno"> 216 </span><span class="spaces"> </span><span class="nottickedoff">[ fn poly & drawAttributes .~ attr</span>
|
||||
<span class="lineno"> 217 </span><span class="spaces"> </span><span class="nottickedoff">| (attr, poly) <- toShapes 0.001 svg</span>
|
||||
<span class="lineno"> 218 </span><span class="spaces"> </span><span class="nottickedoff">]</span></span>
|
||||
|
||||
</pre>
|
||||
</body>
|
||||
|
|
|
|||
|
|
@ -17,65 +17,72 @@ span.spaces { background: white }
|
|||
<span class="decl"><span class="nottickedoff">never executed</span> <span class="tickonlytrue">always true</span> <span class="tickonlyfalse">always false</span></span>
|
||||
</pre>
|
||||
<pre>
|
||||
<span class="lineno"> 1 </span>module Reanimate.Morph.Linear
|
||||
<span class="lineno"> 2 </span> ( linear, rawLinear
|
||||
<span class="lineno"> 3 </span> , linearCorrespondence
|
||||
<span class="lineno"> 4 </span> , closestLinearCorrespondence
|
||||
<span class="lineno"> 5 </span> , closestLinearCorrespondenceA
|
||||
<span class="lineno"> 6 </span> , linearTrajectory
|
||||
<span class="lineno"> 7 </span> ) where
|
||||
<span class="lineno"> 8 </span>
|
||||
<span class="lineno"> 9 </span>import Data.Hashable
|
||||
<span class="lineno"> 10 </span>import qualified Data.Vector as V
|
||||
<span class="lineno"> 11 </span>import Linear.Vector
|
||||
<span class="lineno"> 12 </span>import Reanimate.ColorComponents
|
||||
<span class="lineno"> 13 </span>import Reanimate.Math.Common
|
||||
<span class="lineno"> 14 </span>import Reanimate.Math.Polygon
|
||||
<span class="lineno"> 15 </span>import Reanimate.Morph.Cache
|
||||
<span class="lineno"> 16 </span>import Reanimate.Morph.Common
|
||||
<span class="lineno"> 17 </span>
|
||||
<span class="lineno"> 18 </span>linear :: Morph
|
||||
<span class="lineno"> 19 </span><span class="decl"><span class="nottickedoff">linear = rawLinear</span>
|
||||
<span class="lineno"> 20 </span><span class="spaces"> </span><span class="nottickedoff">{ morphPointCorrespondence =</span>
|
||||
<span class="lineno"> 21 </span><span class="spaces"> </span><span class="nottickedoff">cachePointCorrespondence (hash ("closest"::String))</span>
|
||||
<span class="lineno"> 22 </span><span class="spaces"> </span><span class="nottickedoff">closestLinearCorrespondence }</span></span>
|
||||
<span class="lineno"> 23 </span>
|
||||
<span class="lineno"> 24 </span>rawLinear :: Morph
|
||||
<span class="lineno"> 25 </span><span class="decl"><span class="istickedoff">rawLinear = Morph</span>
|
||||
<span class="lineno"> 26 </span><span class="spaces"> </span><span class="istickedoff">{ morphTolerance = 0.001</span>
|
||||
<span class="lineno"> 27 </span><span class="spaces"> </span><span class="istickedoff">, morphColorComponents = <span class="nottickedoff">labComponents</span></span>
|
||||
<span class="lineno"> 28 </span><span class="spaces"> </span><span class="istickedoff">, morphPointCorrespondence = linearCorrespondence</span>
|
||||
<span class="lineno"> 29 </span><span class="spaces"> </span><span class="istickedoff">, morphTrajectory = linearTrajectory</span>
|
||||
<span class="lineno"> 30 </span><span class="spaces"> </span><span class="istickedoff">, morphObjectCorrespondence = splitObjectCorrespondence }</span></span>
|
||||
<span class="lineno"> 31 </span>
|
||||
<span class="lineno"> 32 </span>linearCorrespondence :: PointCorrespondence
|
||||
<span class="lineno"> 33 </span><span class="decl"><span class="istickedoff">linearCorrespondence = normalizePolygons</span></span>
|
||||
<span class="lineno"> 34 </span>
|
||||
<span class="lineno"> 35 </span>closestLinearCorrespondence :: PointCorrespondence
|
||||
<span class="lineno"> 36 </span><span class="decl"><span class="nottickedoff">closestLinearCorrespondence = closestLinearCorrespondenceA</span></span>
|
||||
<span class="lineno"> 37 </span>
|
||||
<span class="lineno"> 38 </span>closestLinearCorrespondenceA :: (Real a, Fractional a, Epsilon a) => APolygon a -> APolygon a -> (APolygon a, APolygon a)
|
||||
<span class="lineno"> 39 </span><span class="decl"><span class="nottickedoff">closestLinearCorrespondenceA src' dst' =</span>
|
||||
<span class="lineno"> 40 </span><span class="spaces"> </span><span class="nottickedoff">(src, worker dst (score dst) options)</span>
|
||||
<span class="lineno"> 41 </span><span class="spaces"> </span><span class="nottickedoff">where</span>
|
||||
<span class="lineno"> 42 </span><span class="spaces"> </span><span class="nottickedoff">(src, dst) = normalizePolygons src' dst'</span>
|
||||
<span class="lineno"> 43 </span><span class="spaces"> </span><span class="nottickedoff">worker bestP _bestPScore [] = bestP</span>
|
||||
<span class="lineno"> 44 </span><span class="spaces"> </span><span class="nottickedoff">worker bestP bestPScore (x:xs) =</span>
|
||||
<span class="lineno"> 45 </span><span class="spaces"> </span><span class="nottickedoff">let newScore = score x in</span>
|
||||
<span class="lineno"> 46 </span><span class="spaces"> </span><span class="nottickedoff">if newScore < bestPScore</span>
|
||||
<span class="lineno"> 47 </span><span class="spaces"> </span><span class="nottickedoff">then worker x newScore xs</span>
|
||||
<span class="lineno"> 48 </span><span class="spaces"> </span><span class="nottickedoff">else worker bestP bestPScore xs</span>
|
||||
<span class="lineno"> 49 </span><span class="spaces"> </span><span class="nottickedoff">options = pCycles dst</span>
|
||||
<span class="lineno"> 50 </span><span class="spaces"> </span><span class="nottickedoff">score p = sum</span>
|
||||
<span class="lineno"> 51 </span><span class="spaces"> </span><span class="nottickedoff">[ -- approxDist (pAccess src n) (pAccess p n)</span>
|
||||
<span class="lineno"> 52 </span><span class="spaces"> </span><span class="nottickedoff">distSquared (pAccess src n) (pAccess p n)</span>
|
||||
<span class="lineno"> 53 </span><span class="spaces"> </span><span class="nottickedoff">| n <- [0 .. pSize src-1] ]</span></span>
|
||||
<span class="lineno"> 54 </span>
|
||||
<span class="lineno"> 55 </span>linearTrajectory :: Trajectory
|
||||
<span class="lineno"> 56 </span><span class="decl"><span class="istickedoff">linearTrajectory (src,dst)</span>
|
||||
<span class="lineno"> 57 </span><span class="spaces"> </span><span class="istickedoff">| <span class="tickonlytrue">pSize src == pSize dst</span> = \t -> mkPolygon $</span>
|
||||
<span class="lineno"> 58 </span><span class="spaces"> </span><span class="istickedoff">V.zipWith (lerp $ realToFrac t) (polygonPoints dst) (polygonPoints src)</span>
|
||||
<span class="lineno"> 59 </span><span class="spaces"> </span><span class="istickedoff">| <span class="nottickedoff">otherwise</span> = <span class="nottickedoff">error $ "Invalid lengths: " ++ show (pSize src, pSize dst)</span></span></span>
|
||||
<span class="lineno"> 1 </span>{-|
|
||||
<span class="lineno"> 2 </span>Copyright : Written by David Himmelstrup
|
||||
<span class="lineno"> 3 </span>License : Unlicense
|
||||
<span class="lineno"> 4 </span>Maintainer : lemmih@gmail.com
|
||||
<span class="lineno"> 5 </span>Stability : experimental
|
||||
<span class="lineno"> 6 </span>Portability : POSIX
|
||||
<span class="lineno"> 7 </span>-}
|
||||
<span class="lineno"> 8 </span>module Reanimate.Morph.Linear
|
||||
<span class="lineno"> 9 </span> ( linear, rawLinear
|
||||
<span class="lineno"> 10 </span> , linearCorrespondence
|
||||
<span class="lineno"> 11 </span> , closestLinearCorrespondence
|
||||
<span class="lineno"> 12 </span> , closestLinearCorrespondenceA
|
||||
<span class="lineno"> 13 </span> , linearTrajectory
|
||||
<span class="lineno"> 14 </span> ) where
|
||||
<span class="lineno"> 15 </span>
|
||||
<span class="lineno"> 16 </span>import Data.Hashable
|
||||
<span class="lineno"> 17 </span>import qualified Data.Vector as V
|
||||
<span class="lineno"> 18 </span>import Linear.Vector
|
||||
<span class="lineno"> 19 </span>import Reanimate.ColorComponents
|
||||
<span class="lineno"> 20 </span>import Reanimate.Math.Common
|
||||
<span class="lineno"> 21 </span>import Reanimate.Math.Polygon
|
||||
<span class="lineno"> 22 </span>import Reanimate.Morph.Cache
|
||||
<span class="lineno"> 23 </span>import Reanimate.Morph.Common
|
||||
<span class="lineno"> 24 </span>
|
||||
<span class="lineno"> 25 </span>linear :: Morph
|
||||
<span class="lineno"> 26 </span><span class="decl"><span class="nottickedoff">linear = rawLinear</span>
|
||||
<span class="lineno"> 27 </span><span class="spaces"> </span><span class="nottickedoff">{ morphPointCorrespondence =</span>
|
||||
<span class="lineno"> 28 </span><span class="spaces"> </span><span class="nottickedoff">cachePointCorrespondence (hash ("closest"::String))</span>
|
||||
<span class="lineno"> 29 </span><span class="spaces"> </span><span class="nottickedoff">closestLinearCorrespondence }</span></span>
|
||||
<span class="lineno"> 30 </span>
|
||||
<span class="lineno"> 31 </span>rawLinear :: Morph
|
||||
<span class="lineno"> 32 </span><span class="decl"><span class="istickedoff">rawLinear = Morph</span>
|
||||
<span class="lineno"> 33 </span><span class="spaces"> </span><span class="istickedoff">{ morphTolerance = 0.001</span>
|
||||
<span class="lineno"> 34 </span><span class="spaces"> </span><span class="istickedoff">, morphColorComponents = <span class="nottickedoff">labComponents</span></span>
|
||||
<span class="lineno"> 35 </span><span class="spaces"> </span><span class="istickedoff">, morphPointCorrespondence = linearCorrespondence</span>
|
||||
<span class="lineno"> 36 </span><span class="spaces"> </span><span class="istickedoff">, morphTrajectory = linearTrajectory</span>
|
||||
<span class="lineno"> 37 </span><span class="spaces"> </span><span class="istickedoff">, morphObjectCorrespondence = splitObjectCorrespondence }</span></span>
|
||||
<span class="lineno"> 38 </span>
|
||||
<span class="lineno"> 39 </span>linearCorrespondence :: PointCorrespondence
|
||||
<span class="lineno"> 40 </span><span class="decl"><span class="istickedoff">linearCorrespondence = normalizePolygons</span></span>
|
||||
<span class="lineno"> 41 </span>
|
||||
<span class="lineno"> 42 </span>closestLinearCorrespondence :: PointCorrespondence
|
||||
<span class="lineno"> 43 </span><span class="decl"><span class="nottickedoff">closestLinearCorrespondence = closestLinearCorrespondenceA</span></span>
|
||||
<span class="lineno"> 44 </span>
|
||||
<span class="lineno"> 45 </span>closestLinearCorrespondenceA :: (Real a, Fractional a, Epsilon a) => APolygon a -> APolygon a -> (APolygon a, APolygon a)
|
||||
<span class="lineno"> 46 </span><span class="decl"><span class="nottickedoff">closestLinearCorrespondenceA src' dst' =</span>
|
||||
<span class="lineno"> 47 </span><span class="spaces"> </span><span class="nottickedoff">(src, worker dst (score dst) options)</span>
|
||||
<span class="lineno"> 48 </span><span class="spaces"> </span><span class="nottickedoff">where</span>
|
||||
<span class="lineno"> 49 </span><span class="spaces"> </span><span class="nottickedoff">(src, dst) = normalizePolygons src' dst'</span>
|
||||
<span class="lineno"> 50 </span><span class="spaces"> </span><span class="nottickedoff">worker bestP _bestPScore [] = bestP</span>
|
||||
<span class="lineno"> 51 </span><span class="spaces"> </span><span class="nottickedoff">worker bestP bestPScore (x:xs) =</span>
|
||||
<span class="lineno"> 52 </span><span class="spaces"> </span><span class="nottickedoff">let newScore = score x in</span>
|
||||
<span class="lineno"> 53 </span><span class="spaces"> </span><span class="nottickedoff">if newScore < bestPScore</span>
|
||||
<span class="lineno"> 54 </span><span class="spaces"> </span><span class="nottickedoff">then worker x newScore xs</span>
|
||||
<span class="lineno"> 55 </span><span class="spaces"> </span><span class="nottickedoff">else worker bestP bestPScore xs</span>
|
||||
<span class="lineno"> 56 </span><span class="spaces"> </span><span class="nottickedoff">options = pCycles dst</span>
|
||||
<span class="lineno"> 57 </span><span class="spaces"> </span><span class="nottickedoff">score p = sum</span>
|
||||
<span class="lineno"> 58 </span><span class="spaces"> </span><span class="nottickedoff">[ -- approxDist (pAccess src n) (pAccess p n)</span>
|
||||
<span class="lineno"> 59 </span><span class="spaces"> </span><span class="nottickedoff">distSquared (pAccess src n) (pAccess p n)</span>
|
||||
<span class="lineno"> 60 </span><span class="spaces"> </span><span class="nottickedoff">| n <- [0 .. pSize src-1] ]</span></span>
|
||||
<span class="lineno"> 61 </span>
|
||||
<span class="lineno"> 62 </span>linearTrajectory :: Trajectory
|
||||
<span class="lineno"> 63 </span><span class="decl"><span class="istickedoff">linearTrajectory (src,dst)</span>
|
||||
<span class="lineno"> 64 </span><span class="spaces"> </span><span class="istickedoff">| <span class="tickonlytrue">pSize src == pSize dst</span> = \t -> mkPolygon $</span>
|
||||
<span class="lineno"> 65 </span><span class="spaces"> </span><span class="istickedoff">V.zipWith (lerp $ realToFrac t) (polygonPoints dst) (polygonPoints src)</span>
|
||||
<span class="lineno"> 66 </span><span class="spaces"> </span><span class="istickedoff">| <span class="nottickedoff">otherwise</span> = <span class="nottickedoff">error $ "Invalid lengths: " ++ show (pSize src, pSize dst)</span></span></span>
|
||||
|
||||
</pre>
|
||||
</body>
|
||||
|
|
|
|||
|
|
@ -117,8 +117,8 @@ span.spaces { background: white }
|
|||
<span class="lineno"> 98 </span>
|
||||
<span class="lineno"> 99 </span>{-# NOINLINE pNoExternals #-}
|
||||
<span class="lineno"> 100 </span>-- | This parameter determined whether or not external tools are allowed.
|
||||
<span class="lineno"> 101 </span>-- If this flag is True then tools such as 'latex' and 'blender' will not
|
||||
<span class="lineno"> 102 </span>-- be invoked.
|
||||
<span class="lineno"> 101 </span>-- If this flag is True then tools such as 'Reanimate.LaTeX.latex' and
|
||||
<span class="lineno"> 102 </span>-- 'Reanimate.Blender.blender' will not be invoked.
|
||||
<span class="lineno"> 103 </span>pNoExternals :: Bool
|
||||
<span class="lineno"> 104 </span><span class="decl"><span class="istickedoff">pNoExternals = unsafePerformIO (readIORef pNoExternalsRef)</span></span>
|
||||
<span class="lineno"> 105 </span>
|
||||
|
|
|
|||
|
|
@ -271,11 +271,11 @@ span.spaces { background: white }
|
|||
<span class="lineno"> 252 </span><span class="spaces"> </span><span class="nottickedoff">Left{} -> error "bad image"</span>
|
||||
<span class="lineno"> 253 </span><span class="spaces"> </span><span class="nottickedoff">Right img -> return img</span></span>
|
||||
<span class="lineno"> 254 </span>
|
||||
<span class="lineno"> 255 </span>-- | Use 'potrace' to trace edges in a raster image and convert them to SVG polygons.
|
||||
<span class="lineno"> 255 </span>-- | Use \'potrace\' to trace edges in a raster image and convert them to SVG polygons.
|
||||
<span class="lineno"> 256 </span>vectorize :: FilePath -> SVG
|
||||
<span class="lineno"> 257 </span><span class="decl"><span class="nottickedoff">vectorize = vectorize_ []</span></span>
|
||||
<span class="lineno"> 258 </span>
|
||||
<span class="lineno"> 259 </span>-- | Same as 'vectorize' but takes a list of arguments for 'potrace'.
|
||||
<span class="lineno"> 259 </span>-- | Same as 'vectorize' but takes a list of arguments for \'potrace\'.
|
||||
<span class="lineno"> 260 </span>vectorize_ :: [String] -> FilePath -> SVG
|
||||
<span class="lineno"> 261 </span><span class="decl"><span class="nottickedoff">vectorize_ _ path | pNoExternals = mkText $ T.pack path</span>
|
||||
<span class="lineno"> 262 </span><span class="spaces"></span><span class="nottickedoff">vectorize_ args path = unsafePerformIO $ do</span>
|
||||
|
|
|
|||
|
|
@ -18,394 +18,401 @@ span.spaces { background: white }
|
|||
</pre>
|
||||
<pre>
|
||||
<span class="lineno"> 1 </span>{-# LANGUAGE MultiWayIf #-}
|
||||
<span class="lineno"> 2 </span>module Reanimate.Render
|
||||
<span class="lineno"> 3 </span> ( render
|
||||
<span class="lineno"> 4 </span> , renderSvgs
|
||||
<span class="lineno"> 5 </span> , renderSnippets -- :: Animation -> IO ()
|
||||
<span class="lineno"> 6 </span> , renderOneFrame
|
||||
<span class="lineno"> 7 </span> , Format(..)
|
||||
<span class="lineno"> 8 </span> , Raster(..)
|
||||
<span class="lineno"> 9 </span> , Width, Height, FPS
|
||||
<span class="lineno"> 10 </span> , requireRaster -- :: Raster -> IO Raster
|
||||
<span class="lineno"> 11 </span> , selectRaster -- :: Raster -> IO Raster
|
||||
<span class="lineno"> 12 </span> , applyRaster -- :: Raster -> FilePath -> IO ()
|
||||
<span class="lineno"> 13 </span> ) where
|
||||
<span class="lineno"> 14 </span>
|
||||
<span class="lineno"> 15 </span>import Control.Concurrent
|
||||
<span class="lineno"> 16 </span>import Control.Exception
|
||||
<span class="lineno"> 17 </span>import Control.Monad (forM_, forever, unless, void, when)
|
||||
<span class="lineno"> 18 </span>import Data.Either
|
||||
<span class="lineno"> 19 </span>import Data.Function
|
||||
<span class="lineno"> 20 </span>import qualified Data.Text as T
|
||||
<span class="lineno"> 21 </span>import qualified Data.Text.IO as T
|
||||
<span class="lineno"> 22 </span>import Data.Time
|
||||
<span class="lineno"> 23 </span>import Graphics.SvgTree (Number (..))
|
||||
<span class="lineno"> 24 </span>import Numeric
|
||||
<span class="lineno"> 25 </span>import Reanimate.Animation
|
||||
<span class="lineno"> 26 </span>import Reanimate.Driver.Check
|
||||
<span class="lineno"> 27 </span>import Reanimate.Driver.Magick
|
||||
<span class="lineno"> 28 </span>import Reanimate.Misc
|
||||
<span class="lineno"> 29 </span>import Reanimate.Parameters
|
||||
<span class="lineno"> 30 </span>import System.Console.ANSI.Codes
|
||||
<span class="lineno"> 31 </span>import System.Exit
|
||||
<span class="lineno"> 32 </span>import System.FileLock (withTryFileLock, SharedExclusive(..), unlockFile)
|
||||
<span class="lineno"> 33 </span>import System.Directory
|
||||
<span class="lineno"> 34 </span>import System.FilePath (replaceExtension, (<.>), (</>))
|
||||
<span class="lineno"> 35 </span>import System.IO
|
||||
<span class="lineno"> 36 </span>import Text.Printf (printf)
|
||||
<span class="lineno"> 37 </span>
|
||||
<span class="lineno"> 38 </span>idempotentFile :: FilePath -> IO () -> IO ()
|
||||
<span class="lineno"> 39 </span><span class="decl"><span class="nottickedoff">idempotentFile path action = do</span>
|
||||
<span class="lineno"> 40 </span><span class="spaces"> </span><span class="nottickedoff">_ <- withTryFileLock lockFile Exclusive $ \lock -> do</span>
|
||||
<span class="lineno"> 41 </span><span class="spaces"> </span><span class="nottickedoff">haveFile <- doesFileExist path</span>
|
||||
<span class="lineno"> 42 </span><span class="spaces"> </span><span class="nottickedoff">unless haveFile action</span>
|
||||
<span class="lineno"> 43 </span><span class="spaces"> </span><span class="nottickedoff">unlockFile lock</span>
|
||||
<span class="lineno"> 44 </span><span class="spaces"> </span><span class="nottickedoff">_ <- try (removeFile lockFile) :: IO (Either SomeException ())</span>
|
||||
<span class="lineno"> 45 </span><span class="spaces"> </span><span class="nottickedoff">return ()</span>
|
||||
<span class="lineno"> 46 </span><span class="spaces"> </span><span class="nottickedoff">return ()</span>
|
||||
<span class="lineno"> 47 </span><span class="spaces"> </span><span class="nottickedoff">where</span>
|
||||
<span class="lineno"> 48 </span><span class="spaces"> </span><span class="nottickedoff">lockFile = path <.> "lock"</span></span>
|
||||
<span class="lineno"> 49 </span>
|
||||
<span class="lineno"> 50 </span>renderSvgs :: FilePath -> Int -> Bool -> Animation -> IO ()
|
||||
<span class="lineno"> 51 </span><span class="decl"><span class="nottickedoff">renderSvgs folder offset _prettyPrint ani = do</span>
|
||||
<span class="lineno"> 52 </span><span class="spaces"> </span><span class="nottickedoff">print frameCount</span>
|
||||
<span class="lineno"> 53 </span><span class="spaces"> </span><span class="nottickedoff">lock <- newMVar ()</span>
|
||||
<span class="lineno"> 54 </span><span class="spaces"></span><span class="nottickedoff"></span>
|
||||
<span class="lineno"> 55 </span><span class="spaces"> </span><span class="nottickedoff">handle errHandler $ concurrentForM_ (frameOrder rate frameCount) $ \nth' -> do</span>
|
||||
<span class="lineno"> 56 </span><span class="spaces"> </span><span class="nottickedoff">let nth = (nth'+offset) `mod` frameCount</span>
|
||||
<span class="lineno"> 57 </span><span class="spaces"> </span><span class="nottickedoff">now = (duration ani / (fromIntegral frameCount - 1)) * fromIntegral nth</span>
|
||||
<span class="lineno"> 58 </span><span class="spaces"> </span><span class="nottickedoff">frame = frameAt (if frameCount <= 1 then 0 else now) ani</span>
|
||||
<span class="lineno"> 59 </span><span class="spaces"> </span><span class="nottickedoff">svg = renderSvg Nothing Nothing frame</span>
|
||||
<span class="lineno"> 60 </span><span class="spaces"> </span><span class="nottickedoff">path = folder </> show nth <.> "svg"</span>
|
||||
<span class="lineno"> 2 </span>{-|
|
||||
<span class="lineno"> 3 </span>Copyright : Written by David Himmelstrup
|
||||
<span class="lineno"> 4 </span>License : Unlicense
|
||||
<span class="lineno"> 5 </span>Maintainer : lemmih@gmail.com
|
||||
<span class="lineno"> 6 </span>Stability : experimental
|
||||
<span class="lineno"> 7 </span>Portability : POSIX
|
||||
<span class="lineno"> 8 </span>-}
|
||||
<span class="lineno"> 9 </span>module Reanimate.Render
|
||||
<span class="lineno"> 10 </span> ( render
|
||||
<span class="lineno"> 11 </span> , renderSvgs
|
||||
<span class="lineno"> 12 </span> , renderSnippets -- :: Animation -> IO ()
|
||||
<span class="lineno"> 13 </span> , renderOneFrame
|
||||
<span class="lineno"> 14 </span> , Format(..)
|
||||
<span class="lineno"> 15 </span> , Raster(..)
|
||||
<span class="lineno"> 16 </span> , Width, Height, FPS
|
||||
<span class="lineno"> 17 </span> , requireRaster -- :: Raster -> IO Raster
|
||||
<span class="lineno"> 18 </span> , selectRaster -- :: Raster -> IO Raster
|
||||
<span class="lineno"> 19 </span> , applyRaster -- :: Raster -> FilePath -> IO ()
|
||||
<span class="lineno"> 20 </span> ) where
|
||||
<span class="lineno"> 21 </span>
|
||||
<span class="lineno"> 22 </span>import Control.Concurrent
|
||||
<span class="lineno"> 23 </span>import Control.Exception
|
||||
<span class="lineno"> 24 </span>import Control.Monad (forM_, forever, unless, void, when)
|
||||
<span class="lineno"> 25 </span>import Data.Either
|
||||
<span class="lineno"> 26 </span>import Data.Function
|
||||
<span class="lineno"> 27 </span>import qualified Data.Text as T
|
||||
<span class="lineno"> 28 </span>import qualified Data.Text.IO as T
|
||||
<span class="lineno"> 29 </span>import Data.Time
|
||||
<span class="lineno"> 30 </span>import Graphics.SvgTree (Number (..))
|
||||
<span class="lineno"> 31 </span>import Numeric
|
||||
<span class="lineno"> 32 </span>import Reanimate.Animation
|
||||
<span class="lineno"> 33 </span>import Reanimate.Driver.Check
|
||||
<span class="lineno"> 34 </span>import Reanimate.Driver.Magick
|
||||
<span class="lineno"> 35 </span>import Reanimate.Misc
|
||||
<span class="lineno"> 36 </span>import Reanimate.Parameters
|
||||
<span class="lineno"> 37 </span>import System.Console.ANSI.Codes
|
||||
<span class="lineno"> 38 </span>import System.Exit
|
||||
<span class="lineno"> 39 </span>import System.FileLock (withTryFileLock, SharedExclusive(..), unlockFile)
|
||||
<span class="lineno"> 40 </span>import System.Directory
|
||||
<span class="lineno"> 41 </span>import System.FilePath (replaceExtension, (<.>), (</>))
|
||||
<span class="lineno"> 42 </span>import System.IO
|
||||
<span class="lineno"> 43 </span>import Text.Printf (printf)
|
||||
<span class="lineno"> 44 </span>
|
||||
<span class="lineno"> 45 </span>idempotentFile :: FilePath -> IO () -> IO ()
|
||||
<span class="lineno"> 46 </span><span class="decl"><span class="nottickedoff">idempotentFile path action = do</span>
|
||||
<span class="lineno"> 47 </span><span class="spaces"> </span><span class="nottickedoff">_ <- withTryFileLock lockFile Exclusive $ \lock -> do</span>
|
||||
<span class="lineno"> 48 </span><span class="spaces"> </span><span class="nottickedoff">haveFile <- doesFileExist path</span>
|
||||
<span class="lineno"> 49 </span><span class="spaces"> </span><span class="nottickedoff">unless haveFile action</span>
|
||||
<span class="lineno"> 50 </span><span class="spaces"> </span><span class="nottickedoff">unlockFile lock</span>
|
||||
<span class="lineno"> 51 </span><span class="spaces"> </span><span class="nottickedoff">_ <- try (removeFile lockFile) :: IO (Either SomeException ())</span>
|
||||
<span class="lineno"> 52 </span><span class="spaces"> </span><span class="nottickedoff">return ()</span>
|
||||
<span class="lineno"> 53 </span><span class="spaces"> </span><span class="nottickedoff">return ()</span>
|
||||
<span class="lineno"> 54 </span><span class="spaces"> </span><span class="nottickedoff">where</span>
|
||||
<span class="lineno"> 55 </span><span class="spaces"> </span><span class="nottickedoff">lockFile = path <.> "lock"</span></span>
|
||||
<span class="lineno"> 56 </span>
|
||||
<span class="lineno"> 57 </span>renderSvgs :: FilePath -> Int -> Bool -> Animation -> IO ()
|
||||
<span class="lineno"> 58 </span><span class="decl"><span class="nottickedoff">renderSvgs folder offset _prettyPrint ani = do</span>
|
||||
<span class="lineno"> 59 </span><span class="spaces"> </span><span class="nottickedoff">print frameCount</span>
|
||||
<span class="lineno"> 60 </span><span class="spaces"> </span><span class="nottickedoff">lock <- newMVar ()</span>
|
||||
<span class="lineno"> 61 </span><span class="spaces"></span><span class="nottickedoff"></span>
|
||||
<span class="lineno"> 62 </span><span class="spaces"> </span><span class="nottickedoff">idempotentFile path $ writeFile path svg</span>
|
||||
<span class="lineno"> 63 </span><span class="spaces"> </span><span class="nottickedoff">withMVar lock $ \_ -> do</span>
|
||||
<span class="lineno"> 64 </span><span class="spaces"> </span><span class="nottickedoff">print nth</span>
|
||||
<span class="lineno"> 65 </span><span class="spaces"> </span><span class="nottickedoff">hFlush stdout</span>
|
||||
<span class="lineno"> 66 </span><span class="spaces"> </span><span class="nottickedoff">where</span>
|
||||
<span class="lineno"> 67 </span><span class="spaces"> </span><span class="nottickedoff">rate = 60</span>
|
||||
<span class="lineno"> 68 </span><span class="spaces"> </span><span class="nottickedoff">frameCount = round (duration ani * fromIntegral rate) :: Int</span>
|
||||
<span class="lineno"> 69 </span><span class="spaces"> </span><span class="nottickedoff">errHandler (ErrorCall msg) = do</span>
|
||||
<span class="lineno"> 70 </span><span class="spaces"> </span><span class="nottickedoff">hPutStrLn stderr msg</span>
|
||||
<span class="lineno"> 71 </span><span class="spaces"> </span><span class="nottickedoff">exitWith (ExitFailure 1)</span></span>
|
||||
<span class="lineno"> 72 </span>
|
||||
<span class="lineno"> 73 </span>renderOneFrame :: FilePath -> Int -> Bool -> Int -> Animation -> IO ()
|
||||
<span class="lineno"> 74 </span><span class="decl"><span class="nottickedoff">renderOneFrame folder offset _prettyPrint rate ani =</span>
|
||||
<span class="lineno"> 75 </span><span class="spaces"> </span><span class="nottickedoff">worker (frameOrder rate frameCount)</span>
|
||||
<span class="lineno"> 76 </span><span class="spaces"> </span><span class="nottickedoff">where</span>
|
||||
<span class="lineno"> 77 </span><span class="spaces"> </span><span class="nottickedoff">worker [] = putStrLn "Done"</span>
|
||||
<span class="lineno"> 78 </span><span class="spaces"> </span><span class="nottickedoff">worker (x:xs) = do</span>
|
||||
<span class="lineno"> 79 </span><span class="spaces"> </span><span class="nottickedoff">let nth = (x+offset) `mod` frameCount</span>
|
||||
<span class="lineno"> 80 </span><span class="spaces"> </span><span class="nottickedoff">now = (duration ani / (fromIntegral frameCount - 1)) * fromIntegral nth</span>
|
||||
<span class="lineno"> 81 </span><span class="spaces"> </span><span class="nottickedoff">frame = frameAt (if frameCount <= 1 then 0 else now) ani</span>
|
||||
<span class="lineno"> 82 </span><span class="spaces"> </span><span class="nottickedoff">svg = renderSvg Nothing Nothing frame</span>
|
||||
<span class="lineno"> 83 </span><span class="spaces"> </span><span class="nottickedoff">path = folder </> show nth <.> "svg"</span>
|
||||
<span class="lineno"> 84 </span><span class="spaces"> </span><span class="nottickedoff">tmpPath = path <.> "tmp"</span>
|
||||
<span class="lineno"> 85 </span><span class="spaces"> </span><span class="nottickedoff">haveFile <- doesFileExist path</span>
|
||||
<span class="lineno"> 86 </span><span class="spaces"> </span><span class="nottickedoff">if haveFile</span>
|
||||
<span class="lineno"> 87 </span><span class="spaces"> </span><span class="nottickedoff">then worker xs</span>
|
||||
<span class="lineno"> 88 </span><span class="spaces"> </span><span class="nottickedoff">else do</span>
|
||||
<span class="lineno"> 89 </span><span class="spaces"> </span><span class="nottickedoff">writeFile tmpPath svg</span>
|
||||
<span class="lineno"> 90 </span><span class="spaces"> </span><span class="nottickedoff">renameOrCopyFile tmpPath path</span>
|
||||
<span class="lineno"> 91 </span><span class="spaces"> </span><span class="nottickedoff">print nth</span>
|
||||
<span class="lineno"> 92 </span><span class="spaces"> </span><span class="nottickedoff">frameCount = round (duration ani * fromIntegral rate) :: Int</span></span>
|
||||
<span class="lineno"> 93 </span>
|
||||
<span class="lineno"> 94 </span>-- XXX: Merge with 'renderSvgs'
|
||||
<span class="lineno"> 95 </span>renderSnippets :: Animation -> IO ()
|
||||
<span class="lineno"> 96 </span><span class="decl"><span class="istickedoff">renderSnippets ani = forM_ [0 .. frameCount - 1] $ \nth -> do</span>
|
||||
<span class="lineno"> 97 </span><span class="spaces"> </span><span class="istickedoff">let now = (duration ani / (fromIntegral frameCount - 1)) * fromIntegral nth</span>
|
||||
<span class="lineno"> 98 </span><span class="spaces"> </span><span class="istickedoff">frame = frameAt now ani</span>
|
||||
<span class="lineno"> 99 </span><span class="spaces"> </span><span class="istickedoff">svg = renderSvg Nothing Nothing frame</span>
|
||||
<span class="lineno"> 100 </span><span class="spaces"> </span><span class="istickedoff">putStr (show nth)</span>
|
||||
<span class="lineno"> 101 </span><span class="spaces"> </span><span class="istickedoff">T.putStrLn $ T.concat . T.lines . T.pack $ svg</span>
|
||||
<span class="lineno"> 102 </span><span class="spaces"> </span><span class="istickedoff">where frameCount = 10 :: Integer</span></span>
|
||||
<span class="lineno"> 103 </span>
|
||||
<span class="lineno"> 104 </span>frameOrder :: Int -> Int -> [Int]
|
||||
<span class="lineno"> 105 </span><span class="decl"><span class="nottickedoff">frameOrder fps nFrames = worker [] fps</span>
|
||||
<span class="lineno"> 106 </span><span class="spaces"> </span><span class="nottickedoff">where</span>
|
||||
<span class="lineno"> 107 </span><span class="spaces"> </span><span class="nottickedoff">worker _seen 0 = []</span>
|
||||
<span class="lineno"> 108 </span><span class="spaces"> </span><span class="nottickedoff">worker seen nthFrame = filterFrameList seen nthFrame nFrames</span>
|
||||
<span class="lineno"> 109 </span><span class="spaces"> </span><span class="nottickedoff">++ worker (nthFrame : seen) (nthFrame `div` 2)</span></span>
|
||||
<span class="lineno"> 62 </span><span class="spaces"> </span><span class="nottickedoff">handle errHandler $ concurrentForM_ (frameOrder rate frameCount) $ \nth' -> do</span>
|
||||
<span class="lineno"> 63 </span><span class="spaces"> </span><span class="nottickedoff">let nth = (nth'+offset) `mod` frameCount</span>
|
||||
<span class="lineno"> 64 </span><span class="spaces"> </span><span class="nottickedoff">now = (duration ani / (fromIntegral frameCount - 1)) * fromIntegral nth</span>
|
||||
<span class="lineno"> 65 </span><span class="spaces"> </span><span class="nottickedoff">frame = frameAt (if frameCount <= 1 then 0 else now) ani</span>
|
||||
<span class="lineno"> 66 </span><span class="spaces"> </span><span class="nottickedoff">svg = renderSvg Nothing Nothing frame</span>
|
||||
<span class="lineno"> 67 </span><span class="spaces"> </span><span class="nottickedoff">path = folder </> show nth <.> "svg"</span>
|
||||
<span class="lineno"> 68 </span><span class="spaces"></span><span class="nottickedoff"></span>
|
||||
<span class="lineno"> 69 </span><span class="spaces"> </span><span class="nottickedoff">idempotentFile path $ writeFile path svg</span>
|
||||
<span class="lineno"> 70 </span><span class="spaces"> </span><span class="nottickedoff">withMVar lock $ \_ -> do</span>
|
||||
<span class="lineno"> 71 </span><span class="spaces"> </span><span class="nottickedoff">print nth</span>
|
||||
<span class="lineno"> 72 </span><span class="spaces"> </span><span class="nottickedoff">hFlush stdout</span>
|
||||
<span class="lineno"> 73 </span><span class="spaces"> </span><span class="nottickedoff">where</span>
|
||||
<span class="lineno"> 74 </span><span class="spaces"> </span><span class="nottickedoff">rate = 60</span>
|
||||
<span class="lineno"> 75 </span><span class="spaces"> </span><span class="nottickedoff">frameCount = round (duration ani * fromIntegral rate) :: Int</span>
|
||||
<span class="lineno"> 76 </span><span class="spaces"> </span><span class="nottickedoff">errHandler (ErrorCall msg) = do</span>
|
||||
<span class="lineno"> 77 </span><span class="spaces"> </span><span class="nottickedoff">hPutStrLn stderr msg</span>
|
||||
<span class="lineno"> 78 </span><span class="spaces"> </span><span class="nottickedoff">exitWith (ExitFailure 1)</span></span>
|
||||
<span class="lineno"> 79 </span>
|
||||
<span class="lineno"> 80 </span>renderOneFrame :: FilePath -> Int -> Bool -> Int -> Animation -> IO ()
|
||||
<span class="lineno"> 81 </span><span class="decl"><span class="nottickedoff">renderOneFrame folder offset _prettyPrint rate ani =</span>
|
||||
<span class="lineno"> 82 </span><span class="spaces"> </span><span class="nottickedoff">worker (frameOrder rate frameCount)</span>
|
||||
<span class="lineno"> 83 </span><span class="spaces"> </span><span class="nottickedoff">where</span>
|
||||
<span class="lineno"> 84 </span><span class="spaces"> </span><span class="nottickedoff">worker [] = putStrLn "Done"</span>
|
||||
<span class="lineno"> 85 </span><span class="spaces"> </span><span class="nottickedoff">worker (x:xs) = do</span>
|
||||
<span class="lineno"> 86 </span><span class="spaces"> </span><span class="nottickedoff">let nth = (x+offset) `mod` frameCount</span>
|
||||
<span class="lineno"> 87 </span><span class="spaces"> </span><span class="nottickedoff">now = (duration ani / (fromIntegral frameCount - 1)) * fromIntegral nth</span>
|
||||
<span class="lineno"> 88 </span><span class="spaces"> </span><span class="nottickedoff">frame = frameAt (if frameCount <= 1 then 0 else now) ani</span>
|
||||
<span class="lineno"> 89 </span><span class="spaces"> </span><span class="nottickedoff">svg = renderSvg Nothing Nothing frame</span>
|
||||
<span class="lineno"> 90 </span><span class="spaces"> </span><span class="nottickedoff">path = folder </> show nth <.> "svg"</span>
|
||||
<span class="lineno"> 91 </span><span class="spaces"> </span><span class="nottickedoff">tmpPath = path <.> "tmp"</span>
|
||||
<span class="lineno"> 92 </span><span class="spaces"> </span><span class="nottickedoff">haveFile <- doesFileExist path</span>
|
||||
<span class="lineno"> 93 </span><span class="spaces"> </span><span class="nottickedoff">if haveFile</span>
|
||||
<span class="lineno"> 94 </span><span class="spaces"> </span><span class="nottickedoff">then worker xs</span>
|
||||
<span class="lineno"> 95 </span><span class="spaces"> </span><span class="nottickedoff">else do</span>
|
||||
<span class="lineno"> 96 </span><span class="spaces"> </span><span class="nottickedoff">writeFile tmpPath svg</span>
|
||||
<span class="lineno"> 97 </span><span class="spaces"> </span><span class="nottickedoff">renameOrCopyFile tmpPath path</span>
|
||||
<span class="lineno"> 98 </span><span class="spaces"> </span><span class="nottickedoff">print nth</span>
|
||||
<span class="lineno"> 99 </span><span class="spaces"> </span><span class="nottickedoff">frameCount = round (duration ani * fromIntegral rate) :: Int</span></span>
|
||||
<span class="lineno"> 100 </span>
|
||||
<span class="lineno"> 101 </span>-- XXX: Merge with 'renderSvgs'
|
||||
<span class="lineno"> 102 </span>renderSnippets :: Animation -> IO ()
|
||||
<span class="lineno"> 103 </span><span class="decl"><span class="istickedoff">renderSnippets ani = forM_ [0 .. frameCount - 1] $ \nth -> do</span>
|
||||
<span class="lineno"> 104 </span><span class="spaces"> </span><span class="istickedoff">let now = (duration ani / (fromIntegral frameCount - 1)) * fromIntegral nth</span>
|
||||
<span class="lineno"> 105 </span><span class="spaces"> </span><span class="istickedoff">frame = frameAt now ani</span>
|
||||
<span class="lineno"> 106 </span><span class="spaces"> </span><span class="istickedoff">svg = renderSvg Nothing Nothing frame</span>
|
||||
<span class="lineno"> 107 </span><span class="spaces"> </span><span class="istickedoff">putStr (show nth)</span>
|
||||
<span class="lineno"> 108 </span><span class="spaces"> </span><span class="istickedoff">T.putStrLn $ T.concat . T.lines . T.pack $ svg</span>
|
||||
<span class="lineno"> 109 </span><span class="spaces"> </span><span class="istickedoff">where frameCount = 10 :: Integer</span></span>
|
||||
<span class="lineno"> 110 </span>
|
||||
<span class="lineno"> 111 </span>filterFrameList :: [Int] -> Int -> Int -> [Int]
|
||||
<span class="lineno"> 112 </span><span class="decl"><span class="nottickedoff">filterFrameList seen nthFrame nFrames = filter (not . isSeen)</span>
|
||||
<span class="lineno"> 113 </span><span class="spaces"> </span><span class="nottickedoff">[0, nthFrame .. nFrames - 1]</span>
|
||||
<span class="lineno"> 114 </span><span class="spaces"> </span><span class="nottickedoff">where isSeen x = any (\y -> x `mod` y == 0) seen</span></span>
|
||||
<span class="lineno"> 115 </span>
|
||||
<span class="lineno"> 116 </span>data Format = RenderMp4 | RenderGif | RenderWebm
|
||||
<span class="lineno"> 117 </span> deriving (<span class="decl"><span class="nottickedoff">Show</span></span>)
|
||||
<span class="lineno"> 118 </span>
|
||||
<span class="lineno"> 119 </span>mp4Arguments :: FPS -> FilePath -> FilePath -> FilePath -> [String]
|
||||
<span class="lineno"> 120 </span><span class="decl"><span class="nottickedoff">mp4Arguments fps progress template target =</span>
|
||||
<span class="lineno"> 121 </span><span class="spaces"> </span><span class="nottickedoff">[ "-r"</span>
|
||||
<span class="lineno"> 122 </span><span class="spaces"> </span><span class="nottickedoff">, show fps</span>
|
||||
<span class="lineno"> 123 </span><span class="spaces"> </span><span class="nottickedoff">, "-i"</span>
|
||||
<span class="lineno"> 124 </span><span class="spaces"> </span><span class="nottickedoff">, template</span>
|
||||
<span class="lineno"> 125 </span><span class="spaces"> </span><span class="nottickedoff">, "-y"</span>
|
||||
<span class="lineno"> 126 </span><span class="spaces"> </span><span class="nottickedoff">, "-c:v"</span>
|
||||
<span class="lineno"> 127 </span><span class="spaces"> </span><span class="nottickedoff">, "libx264"</span>
|
||||
<span class="lineno"> 128 </span><span class="spaces"> </span><span class="nottickedoff">, "-vf"</span>
|
||||
<span class="lineno"> 129 </span><span class="spaces"> </span><span class="nottickedoff">, "fps=" ++ show fps</span>
|
||||
<span class="lineno"> 130 </span><span class="spaces"> </span><span class="nottickedoff">, "-preset"</span>
|
||||
<span class="lineno"> 131 </span><span class="spaces"> </span><span class="nottickedoff">, "slow"</span>
|
||||
<span class="lineno"> 132 </span><span class="spaces"> </span><span class="nottickedoff">, "-crf"</span>
|
||||
<span class="lineno"> 133 </span><span class="spaces"> </span><span class="nottickedoff">, "18"</span>
|
||||
<span class="lineno"> 134 </span><span class="spaces"> </span><span class="nottickedoff">, "-movflags"</span>
|
||||
<span class="lineno"> 135 </span><span class="spaces"> </span><span class="nottickedoff">, "+faststart"</span>
|
||||
<span class="lineno"> 136 </span><span class="spaces"> </span><span class="nottickedoff">, "-progress"</span>
|
||||
<span class="lineno"> 137 </span><span class="spaces"> </span><span class="nottickedoff">, progress</span>
|
||||
<span class="lineno"> 138 </span><span class="spaces"> </span><span class="nottickedoff">, "-pix_fmt"</span>
|
||||
<span class="lineno"> 139 </span><span class="spaces"> </span><span class="nottickedoff">, "yuv420p"</span>
|
||||
<span class="lineno"> 140 </span><span class="spaces"> </span><span class="nottickedoff">, target</span>
|
||||
<span class="lineno"> 141 </span><span class="spaces"> </span><span class="nottickedoff">]</span></span>
|
||||
<span class="lineno"> 142 </span>
|
||||
<span class="lineno"> 143 </span>-- gifArguments :: FPS -> FilePath -> FilePath -> FilePath -> [String]
|
||||
<span class="lineno"> 144 </span>-- gifArguments fps progress template target =
|
||||
<span class="lineno"> 145 </span>
|
||||
<span class="lineno"> 146 </span>render
|
||||
<span class="lineno"> 147 </span> :: Animation
|
||||
<span class="lineno"> 148 </span> -> FilePath
|
||||
<span class="lineno"> 149 </span> -> Raster
|
||||
<span class="lineno"> 150 </span> -> Format
|
||||
<span class="lineno"> 151 </span> -> Width
|
||||
<span class="lineno"> 152 </span> -> Height
|
||||
<span class="lineno"> 153 </span> -> FPS
|
||||
<span class="lineno"> 154 </span> -> Bool
|
||||
<span class="lineno"> 155 </span> -> IO ()
|
||||
<span class="lineno"> 156 </span><span class="decl"><span class="nottickedoff">render ani target raster format width height fps partial = do</span>
|
||||
<span class="lineno"> 157 </span><span class="spaces"> </span><span class="nottickedoff">printf "Starting render of animation: %.1f\n" (duration ani)</span>
|
||||
<span class="lineno"> 158 </span><span class="spaces"> </span><span class="nottickedoff">ffmpeg <- requireExecutable "ffmpeg"</span>
|
||||
<span class="lineno"> 159 </span><span class="spaces"> </span><span class="nottickedoff">generateFrames raster ani width height fps partial $ \template -></span>
|
||||
<span class="lineno"> 160 </span><span class="spaces"> </span><span class="nottickedoff">withTempFile "txt" $ \progress -> do</span>
|
||||
<span class="lineno"> 161 </span><span class="spaces"> </span><span class="nottickedoff">writeFile progress ""</span>
|
||||
<span class="lineno"> 162 </span><span class="spaces"> </span><span class="nottickedoff">progressH <- openFile progress ReadMode</span>
|
||||
<span class="lineno"> 163 </span><span class="spaces"> </span><span class="nottickedoff">hSetBuffering progressH NoBuffering</span>
|
||||
<span class="lineno"> 164 </span><span class="spaces"> </span><span class="nottickedoff">allFinished <- newEmptyMVar</span>
|
||||
<span class="lineno"> 165 </span><span class="spaces"> </span><span class="nottickedoff">void $ forkIO $ do</span>
|
||||
<span class="lineno"> 166 </span><span class="spaces"> </span><span class="nottickedoff">progressPrinter "rendered" (animationFrameCount ani fps)</span>
|
||||
<span class="lineno"> 167 </span><span class="spaces"> </span><span class="nottickedoff">$ \done -> fix $ \loop -> do</span>
|
||||
<span class="lineno"> 168 </span><span class="spaces"> </span><span class="nottickedoff">eof <- hIsEOF progressH</span>
|
||||
<span class="lineno"> 169 </span><span class="spaces"> </span><span class="nottickedoff">if eof</span>
|
||||
<span class="lineno"> 170 </span><span class="spaces"> </span><span class="nottickedoff">then threadDelay 1000000 >> loop</span>
|
||||
<span class="lineno"> 171 </span><span class="spaces"> </span><span class="nottickedoff">else do</span>
|
||||
<span class="lineno"> 172 </span><span class="spaces"> </span><span class="nottickedoff">l <- try (hGetLine progressH)</span>
|
||||
<span class="lineno"> 173 </span><span class="spaces"> </span><span class="nottickedoff">case l of</span>
|
||||
<span class="lineno"> 174 </span><span class="spaces"> </span><span class="nottickedoff">Left SomeException{} -> return ()</span>
|
||||
<span class="lineno"> 175 </span><span class="spaces"> </span><span class="nottickedoff">Right str -></span>
|
||||
<span class="lineno"> 176 </span><span class="spaces"> </span><span class="nottickedoff">case take 6 str of</span>
|
||||
<span class="lineno"> 177 </span><span class="spaces"> </span><span class="nottickedoff">"frame=" -> do</span>
|
||||
<span class="lineno"> 178 </span><span class="spaces"> </span><span class="nottickedoff">void $ swapMVar done (read (drop 6 str))</span>
|
||||
<span class="lineno"> 179 </span><span class="spaces"> </span><span class="nottickedoff">loop</span>
|
||||
<span class="lineno"> 180 </span><span class="spaces"> </span><span class="nottickedoff">_ | str == "progress=end" -> return ()</span>
|
||||
<span class="lineno"> 181 </span><span class="spaces"> </span><span class="nottickedoff">_ -> loop</span>
|
||||
<span class="lineno"> 182 </span><span class="spaces"> </span><span class="nottickedoff">putMVar allFinished ()</span>
|
||||
<span class="lineno"> 183 </span><span class="spaces"> </span><span class="nottickedoff">case format of</span>
|
||||
<span class="lineno"> 184 </span><span class="spaces"> </span><span class="nottickedoff">RenderMp4 -> runCmd ffmpeg (mp4Arguments fps progress template target)</span>
|
||||
<span class="lineno"> 185 </span><span class="spaces"> </span><span class="nottickedoff">RenderGif -> withTempFile "png" $ \palette -> do</span>
|
||||
<span class="lineno"> 186 </span><span class="spaces"> </span><span class="nottickedoff">runCmd</span>
|
||||
<span class="lineno"> 187 </span><span class="spaces"> </span><span class="nottickedoff">ffmpeg</span>
|
||||
<span class="lineno"> 188 </span><span class="spaces"> </span><span class="nottickedoff">[ "-i"</span>
|
||||
<span class="lineno"> 189 </span><span class="spaces"> </span><span class="nottickedoff">, template</span>
|
||||
<span class="lineno"> 190 </span><span class="spaces"> </span><span class="nottickedoff">, "-y"</span>
|
||||
<span class="lineno"> 191 </span><span class="spaces"> </span><span class="nottickedoff">, "-vf"</span>
|
||||
<span class="lineno"> 192 </span><span class="spaces"> </span><span class="nottickedoff">, "fps="</span>
|
||||
<span class="lineno"> 193 </span><span class="spaces"> </span><span class="nottickedoff">++ show fps</span>
|
||||
<span class="lineno"> 194 </span><span class="spaces"> </span><span class="nottickedoff">++ ",scale="</span>
|
||||
<span class="lineno"> 195 </span><span class="spaces"> </span><span class="nottickedoff">++ show width</span>
|
||||
<span class="lineno"> 196 </span><span class="spaces"> </span><span class="nottickedoff">++ ":"</span>
|
||||
<span class="lineno"> 197 </span><span class="spaces"> </span><span class="nottickedoff">++ show height</span>
|
||||
<span class="lineno"> 198 </span><span class="spaces"> </span><span class="nottickedoff">++ ":flags=lanczos,palettegen"</span>
|
||||
<span class="lineno"> 199 </span><span class="spaces"> </span><span class="nottickedoff">, "-t"</span>
|
||||
<span class="lineno"> 200 </span><span class="spaces"> </span><span class="nottickedoff">, showFFloat Nothing (duration ani) ""</span>
|
||||
<span class="lineno"> 201 </span><span class="spaces"> </span><span class="nottickedoff">, palette</span>
|
||||
<span class="lineno"> 202 </span><span class="spaces"> </span><span class="nottickedoff">]</span>
|
||||
<span class="lineno"> 203 </span><span class="spaces"> </span><span class="nottickedoff">runCmd</span>
|
||||
<span class="lineno"> 204 </span><span class="spaces"> </span><span class="nottickedoff">ffmpeg</span>
|
||||
<span class="lineno"> 205 </span><span class="spaces"> </span><span class="nottickedoff">[ "-framerate"</span>
|
||||
<span class="lineno"> 206 </span><span class="spaces"> </span><span class="nottickedoff">, show fps</span>
|
||||
<span class="lineno"> 207 </span><span class="spaces"> </span><span class="nottickedoff">, "-i"</span>
|
||||
<span class="lineno"> 208 </span><span class="spaces"> </span><span class="nottickedoff">, template</span>
|
||||
<span class="lineno"> 209 </span><span class="spaces"> </span><span class="nottickedoff">, "-y"</span>
|
||||
<span class="lineno"> 210 </span><span class="spaces"> </span><span class="nottickedoff">, "-i"</span>
|
||||
<span class="lineno"> 211 </span><span class="spaces"> </span><span class="nottickedoff">, palette</span>
|
||||
<span class="lineno"> 212 </span><span class="spaces"> </span><span class="nottickedoff">, "-progress"</span>
|
||||
<span class="lineno"> 213 </span><span class="spaces"> </span><span class="nottickedoff">, progress</span>
|
||||
<span class="lineno"> 214 </span><span class="spaces"> </span><span class="nottickedoff">, "-filter_complex"</span>
|
||||
<span class="lineno"> 215 </span><span class="spaces"> </span><span class="nottickedoff">, "fps="</span>
|
||||
<span class="lineno"> 216 </span><span class="spaces"> </span><span class="nottickedoff">++ show fps</span>
|
||||
<span class="lineno"> 217 </span><span class="spaces"> </span><span class="nottickedoff">++ ",scale="</span>
|
||||
<span class="lineno"> 218 </span><span class="spaces"> </span><span class="nottickedoff">++ show width</span>
|
||||
<span class="lineno"> 219 </span><span class="spaces"> </span><span class="nottickedoff">++ ":"</span>
|
||||
<span class="lineno"> 220 </span><span class="spaces"> </span><span class="nottickedoff">++ show height</span>
|
||||
<span class="lineno"> 221 </span><span class="spaces"> </span><span class="nottickedoff">++ ":flags=lanczos[x];[x][1:v]paletteuse"</span>
|
||||
<span class="lineno"> 222 </span><span class="spaces"> </span><span class="nottickedoff">, "-t"</span>
|
||||
<span class="lineno"> 223 </span><span class="spaces"> </span><span class="nottickedoff">, showFFloat Nothing (duration ani) ""</span>
|
||||
<span class="lineno"> 224 </span><span class="spaces"> </span><span class="nottickedoff">, target</span>
|
||||
<span class="lineno"> 225 </span><span class="spaces"> </span><span class="nottickedoff">]</span>
|
||||
<span class="lineno"> 226 </span><span class="spaces"> </span><span class="nottickedoff">RenderWebm -> runCmd</span>
|
||||
<span class="lineno"> 227 </span><span class="spaces"> </span><span class="nottickedoff">ffmpeg</span>
|
||||
<span class="lineno"> 228 </span><span class="spaces"> </span><span class="nottickedoff">[ "-r"</span>
|
||||
<span class="lineno"> 229 </span><span class="spaces"> </span><span class="nottickedoff">, show fps</span>
|
||||
<span class="lineno"> 230 </span><span class="spaces"> </span><span class="nottickedoff">, "-i"</span>
|
||||
<span class="lineno"> 231 </span><span class="spaces"> </span><span class="nottickedoff">, template</span>
|
||||
<span class="lineno"> 232 </span><span class="spaces"> </span><span class="nottickedoff">, "-y"</span>
|
||||
<span class="lineno"> 233 </span><span class="spaces"> </span><span class="nottickedoff">, "-progress"</span>
|
||||
<span class="lineno"> 234 </span><span class="spaces"> </span><span class="nottickedoff">, progress</span>
|
||||
<span class="lineno"> 235 </span><span class="spaces"> </span><span class="nottickedoff">, "-c:v"</span>
|
||||
<span class="lineno"> 236 </span><span class="spaces"> </span><span class="nottickedoff">, "libvpx-vp9"</span>
|
||||
<span class="lineno"> 237 </span><span class="spaces"> </span><span class="nottickedoff">, "-vf"</span>
|
||||
<span class="lineno"> 238 </span><span class="spaces"> </span><span class="nottickedoff">, "fps=" ++ show fps</span>
|
||||
<span class="lineno"> 239 </span><span class="spaces"> </span><span class="nottickedoff">, target</span>
|
||||
<span class="lineno"> 240 </span><span class="spaces"> </span><span class="nottickedoff">]</span>
|
||||
<span class="lineno"> 241 </span><span class="spaces"> </span><span class="nottickedoff">takeMVar allFinished</span></span>
|
||||
<span class="lineno"> 242 </span>
|
||||
<span class="lineno"> 243 </span>---------------------------------------------------------------------------------
|
||||
<span class="lineno"> 244 </span>-- Helpers
|
||||
<span class="lineno"> 245 </span>
|
||||
<span class="lineno"> 246 </span>progressPrinter :: String -> Int -> (MVar Int -> IO ()) -> IO ()
|
||||
<span class="lineno"> 247 </span><span class="decl"><span class="nottickedoff">progressPrinter typeName maxCount action = do</span>
|
||||
<span class="lineno"> 248 </span><span class="spaces"> </span><span class="nottickedoff">printf "\rFrames %s: 0/%d" typeName maxCount</span>
|
||||
<span class="lineno"> 249 </span><span class="spaces"> </span><span class="nottickedoff">putStr $ clearFromCursorToLineEndCode ++ "\r"</span>
|
||||
<span class="lineno"> 250 </span><span class="spaces"> </span><span class="nottickedoff">done <- newMVar (0 :: Int)</span>
|
||||
<span class="lineno"> 251 </span><span class="spaces"> </span><span class="nottickedoff">start <- getCurrentTime</span>
|
||||
<span class="lineno"> 252 </span><span class="spaces"> </span><span class="nottickedoff">let bgThread = forever $ do</span>
|
||||
<span class="lineno"> 253 </span><span class="spaces"> </span><span class="nottickedoff">nDone <- readMVar done</span>
|
||||
<span class="lineno"> 254 </span><span class="spaces"> </span><span class="nottickedoff">now <- getCurrentTime</span>
|
||||
<span class="lineno"> 255 </span><span class="spaces"> </span><span class="nottickedoff">let spent = diffUTCTime now start</span>
|
||||
<span class="lineno"> 256 </span><span class="spaces"> </span><span class="nottickedoff">remaining =</span>
|
||||
<span class="lineno"> 257 </span><span class="spaces"> </span><span class="nottickedoff">(spent / (fromIntegral nDone / fromIntegral maxCount)) - spent</span>
|
||||
<span class="lineno"> 258 </span><span class="spaces"> </span><span class="nottickedoff">printf "\rFrames %s: %d/%d" typeName nDone maxCount</span>
|
||||
<span class="lineno"> 259 </span><span class="spaces"> </span><span class="nottickedoff">putStr $ ", time spent: " ++ ppDiff spent</span>
|
||||
<span class="lineno"> 260 </span><span class="spaces"> </span><span class="nottickedoff">unless (nDone == 0) $ do</span>
|
||||
<span class="lineno"> 261 </span><span class="spaces"> </span><span class="nottickedoff">putStr $ ", time remaining: " ++ ppDiff remaining</span>
|
||||
<span class="lineno"> 262 </span><span class="spaces"> </span><span class="nottickedoff">putStr $ ", total time: " ++ ppDiff (remaining + spent)</span>
|
||||
<span class="lineno"> 263 </span><span class="spaces"> </span><span class="nottickedoff">putStr $ clearFromCursorToLineEndCode ++ "\r"</span>
|
||||
<span class="lineno"> 264 </span><span class="spaces"> </span><span class="nottickedoff">hFlush stdout</span>
|
||||
<span class="lineno"> 265 </span><span class="spaces"> </span><span class="nottickedoff">threadDelay 1000000</span>
|
||||
<span class="lineno"> 266 </span><span class="spaces"> </span><span class="nottickedoff">withBackgroundThread bgThread $ action done</span>
|
||||
<span class="lineno"> 267 </span><span class="spaces"> </span><span class="nottickedoff">now <- getCurrentTime</span>
|
||||
<span class="lineno"> 268 </span><span class="spaces"> </span><span class="nottickedoff">let spent = diffUTCTime now start</span>
|
||||
<span class="lineno"> 269 </span><span class="spaces"> </span><span class="nottickedoff">printf "\rFrames %s: %d/%d" typeName maxCount maxCount</span>
|
||||
<span class="lineno"> 270 </span><span class="spaces"> </span><span class="nottickedoff">putStr $ ", time spent: " ++ ppDiff spent</span>
|
||||
<span class="lineno"> 271 </span><span class="spaces"> </span><span class="nottickedoff">putStr $ clearFromCursorToLineEndCode ++ "\n"</span></span>
|
||||
<span class="lineno"> 272 </span>
|
||||
<span class="lineno"> 273 </span>animationFrameCount :: Animation -> FPS -> Int
|
||||
<span class="lineno"> 274 </span><span class="decl"><span class="nottickedoff">animationFrameCount ani rate = round (duration ani * fromIntegral rate) :: Int</span></span>
|
||||
<span class="lineno"> 275 </span>
|
||||
<span class="lineno"> 276 </span>generateFrames
|
||||
<span class="lineno"> 277 </span> :: Raster -> Animation -> Width -> Height -> FPS -> Bool -> (FilePath -> IO a) -> IO a
|
||||
<span class="lineno"> 278 </span><span class="decl"><span class="nottickedoff">generateFrames raster ani width_ height_ rate partial action = withTempDir $ \tmp -> do</span>
|
||||
<span class="lineno"> 279 </span><span class="spaces"> </span><span class="nottickedoff">let frameName nth = tmp </> printf nameTemplate nth</span>
|
||||
<span class="lineno"> 280 </span><span class="spaces"> </span><span class="nottickedoff">setRootDirectory tmp</span>
|
||||
<span class="lineno"> 281 </span><span class="spaces"> </span><span class="nottickedoff">progressPrinter "generated" frameCount</span>
|
||||
<span class="lineno"> 282 </span><span class="spaces"> </span><span class="nottickedoff">$ \done -> handle h $ concurrentForM_ frames $ \n -> do</span>
|
||||
<span class="lineno"> 283 </span><span class="spaces"> </span><span class="nottickedoff">writeFile (frameName n) $ renderSvg width height $ nthFrame n</span>
|
||||
<span class="lineno"> 284 </span><span class="spaces"> </span><span class="nottickedoff">modifyMVar_ done $ \nDone -> return (nDone + 1)</span>
|
||||
<span class="lineno"> 285 </span><span class="spaces"></span><span class="nottickedoff"></span>
|
||||
<span class="lineno"> 286 </span><span class="spaces"> </span><span class="nottickedoff">when (isValidRaster raster)</span>
|
||||
<span class="lineno"> 287 </span><span class="spaces"> </span><span class="nottickedoff">$ progressPrinter "rastered" frameCount</span>
|
||||
<span class="lineno"> 288 </span><span class="spaces"> </span><span class="nottickedoff">$ \done -> handle h $ concurrentForM_ frames $ \n -> do</span>
|
||||
<span class="lineno"> 289 </span><span class="spaces"> </span><span class="nottickedoff">applyRaster raster (frameName n)</span>
|
||||
<span class="lineno"> 290 </span><span class="spaces"> </span><span class="nottickedoff">modifyMVar_ done $ \nDone -> return (nDone + 1)</span>
|
||||
<span class="lineno"> 291 </span><span class="spaces"></span><span class="nottickedoff"></span>
|
||||
<span class="lineno"> 292 </span><span class="spaces"> </span><span class="nottickedoff">action (tmp </> rasterTemplate raster)</span>
|
||||
<span class="lineno"> 293 </span><span class="spaces"> </span><span class="nottickedoff">where</span>
|
||||
<span class="lineno"> 294 </span><span class="spaces"> </span><span class="nottickedoff">isValidRaster RasterNone = False</span>
|
||||
<span class="lineno"> 295 </span><span class="spaces"> </span><span class="nottickedoff">isValidRaster RasterAuto = False</span>
|
||||
<span class="lineno"> 296 </span><span class="spaces"> </span><span class="nottickedoff">isValidRaster _ = True</span>
|
||||
<span class="lineno"> 297 </span><span class="spaces"></span><span class="nottickedoff"></span>
|
||||
<span class="lineno"> 298 </span><span class="spaces"> </span><span class="nottickedoff">width = Just $ Px $ fromIntegral width_</span>
|
||||
<span class="lineno"> 299 </span><span class="spaces"> </span><span class="nottickedoff">height = Just $ Px $ fromIntegral height_</span>
|
||||
<span class="lineno"> 300 </span><span class="spaces"> </span><span class="nottickedoff">h UserInterrupt | partial = do</span>
|
||||
<span class="lineno"> 301 </span><span class="spaces"> </span><span class="nottickedoff">hPutStrLn</span>
|
||||
<span class="lineno"> 302 </span><span class="spaces"> </span><span class="nottickedoff">stderr</span>
|
||||
<span class="lineno"> 303 </span><span class="spaces"> </span><span class="nottickedoff">"\nCtrl-C detected. Trying to generate video with available frames. \</span>
|
||||
<span class="lineno"> 304 </span><span class="spaces"> </span><span class="nottickedoff">\Hit ctrl-c again to abort."</span>
|
||||
<span class="lineno"> 305 </span><span class="spaces"> </span><span class="nottickedoff">return ()</span>
|
||||
<span class="lineno"> 306 </span><span class="spaces"> </span><span class="nottickedoff">h other = throwIO other</span>
|
||||
<span class="lineno"> 307 </span><span class="spaces"> </span><span class="nottickedoff">-- frames = [0..frameCount-1]</span>
|
||||
<span class="lineno"> 308 </span><span class="spaces"> </span><span class="nottickedoff">frames = frameOrder rate frameCount</span>
|
||||
<span class="lineno"> 309 </span><span class="spaces"> </span><span class="nottickedoff">nthFrame nth = frameAt (recip (fromIntegral rate) * fromIntegral nth) ani</span>
|
||||
<span class="lineno"> 310 </span><span class="spaces"> </span><span class="nottickedoff">frameCount = animationFrameCount ani rate</span>
|
||||
<span class="lineno"> 311 </span><span class="spaces"> </span><span class="nottickedoff">nameTemplate :: String</span>
|
||||
<span class="lineno"> 312 </span><span class="spaces"> </span><span class="nottickedoff">nameTemplate = "render-%05d.svg"</span></span>
|
||||
<span class="lineno"> 313 </span>
|
||||
<span class="lineno"> 314 </span>withBackgroundThread :: IO () -> IO a -> IO a
|
||||
<span class="lineno"> 315 </span><span class="decl"><span class="nottickedoff">withBackgroundThread t = bracket (forkIO t) killThread . const</span></span>
|
||||
<span class="lineno"> 316 </span>
|
||||
<span class="lineno"> 317 </span>ppDiff :: NominalDiffTime -> String
|
||||
<span class="lineno"> 318 </span><span class="decl"><span class="nottickedoff">ppDiff diff | hours == 0 && mins == 0 = show secs ++ "s"</span>
|
||||
<span class="lineno"> 319 </span><span class="spaces"> </span><span class="nottickedoff">| hours == 0 = printf "%.2d:%.2d" mins secs</span>
|
||||
<span class="lineno"> 320 </span><span class="spaces"> </span><span class="nottickedoff">| otherwise = printf "%.2d:%.2d:%.2d" hours mins secs</span>
|
||||
<span class="lineno"> 321 </span><span class="spaces"> </span><span class="nottickedoff">where</span>
|
||||
<span class="lineno"> 322 </span><span class="spaces"> </span><span class="nottickedoff">(osecs, secs) = round diff `divMod` (60 :: Int)</span>
|
||||
<span class="lineno"> 323 </span><span class="spaces"> </span><span class="nottickedoff">(hours, mins) = osecs `divMod` 60</span></span>
|
||||
<span class="lineno"> 324 </span>
|
||||
<span class="lineno"> 325 </span>rasterTemplate :: Raster -> String
|
||||
<span class="lineno"> 326 </span><span class="decl"><span class="nottickedoff">rasterTemplate RasterNone = "render-%05d.svg"</span>
|
||||
<span class="lineno"> 327 </span><span class="spaces"></span><span class="nottickedoff">rasterTemplate RasterAuto = "render-%05d.svg"</span>
|
||||
<span class="lineno"> 328 </span><span class="spaces"></span><span class="nottickedoff">rasterTemplate _ = "render-%05d.png"</span></span>
|
||||
<span class="lineno"> 329 </span>
|
||||
<span class="lineno"> 330 </span>requireRaster :: Raster -> IO Raster
|
||||
<span class="lineno"> 331 </span><span class="decl"><span class="nottickedoff">requireRaster raster = do</span>
|
||||
<span class="lineno"> 332 </span><span class="spaces"> </span><span class="nottickedoff">raster' <- selectRaster (if raster == RasterNone then RasterAuto else raster)</span>
|
||||
<span class="lineno"> 333 </span><span class="spaces"> </span><span class="nottickedoff">case raster' of</span>
|
||||
<span class="lineno"> 334 </span><span class="spaces"> </span><span class="nottickedoff">RasterNone -> do</span>
|
||||
<span class="lineno"> 335 </span><span class="spaces"> </span><span class="nottickedoff">hPutStrLn</span>
|
||||
<span class="lineno"> 336 </span><span class="spaces"> </span><span class="nottickedoff">stderr</span>
|
||||
<span class="lineno"> 337 </span><span class="spaces"> </span><span class="nottickedoff">"Raster required but none could be found. \</span>
|
||||
<span class="lineno"> 338 </span><span class="spaces"> </span><span class="nottickedoff">\Please install either inkscape, imagemagick, or rsvg-convert."</span>
|
||||
<span class="lineno"> 339 </span><span class="spaces"> </span><span class="nottickedoff">exitWith (ExitFailure 1)</span>
|
||||
<span class="lineno"> 340 </span><span class="spaces"> </span><span class="nottickedoff">_ -> pure raster'</span></span>
|
||||
<span class="lineno"> 341 </span>
|
||||
<span class="lineno"> 342 </span>selectRaster :: Raster -> IO Raster
|
||||
<span class="lineno"> 343 </span><span class="decl"><span class="nottickedoff">selectRaster RasterAuto = do</span>
|
||||
<span class="lineno"> 344 </span><span class="spaces"> </span><span class="nottickedoff">rsvg <- hasRSvg</span>
|
||||
<span class="lineno"> 345 </span><span class="spaces"> </span><span class="nottickedoff">ink <- hasInkscape</span>
|
||||
<span class="lineno"> 346 </span><span class="spaces"> </span><span class="nottickedoff">magick <- hasMagick</span>
|
||||
<span class="lineno"> 347 </span><span class="spaces"> </span><span class="nottickedoff">if</span>
|
||||
<span class="lineno"> 348 </span><span class="spaces"> </span><span class="nottickedoff">| isRight rsvg -> pure RasterRSvg</span>
|
||||
<span class="lineno"> 349 </span><span class="spaces"> </span><span class="nottickedoff">| isRight ink -> pure RasterInkscape</span>
|
||||
<span class="lineno"> 350 </span><span class="spaces"> </span><span class="nottickedoff">| isRight magick -> pure RasterMagick</span>
|
||||
<span class="lineno"> 351 </span><span class="spaces"> </span><span class="nottickedoff">| otherwise -> pure RasterNone</span>
|
||||
<span class="lineno"> 352 </span><span class="spaces"></span><span class="nottickedoff">selectRaster r = pure r</span></span>
|
||||
<span class="lineno"> 353 </span>
|
||||
<span class="lineno"> 354 </span>applyRaster :: Raster -> FilePath -> IO ()
|
||||
<span class="lineno"> 355 </span><span class="decl"><span class="nottickedoff">applyRaster RasterNone _ = return ()</span>
|
||||
<span class="lineno"> 356 </span><span class="spaces"></span><span class="nottickedoff">applyRaster RasterAuto _ = return ()</span>
|
||||
<span class="lineno"> 357 </span><span class="spaces"></span><span class="nottickedoff">applyRaster RasterInkscape path = runCmd</span>
|
||||
<span class="lineno"> 358 </span><span class="spaces"> </span><span class="nottickedoff">"inkscape"</span>
|
||||
<span class="lineno"> 359 </span><span class="spaces"> </span><span class="nottickedoff">[ "--without-gui"</span>
|
||||
<span class="lineno"> 360 </span><span class="spaces"> </span><span class="nottickedoff">, "--file=" ++ path</span>
|
||||
<span class="lineno"> 361 </span><span class="spaces"> </span><span class="nottickedoff">, "--export-png=" ++ replaceExtension path "png"</span>
|
||||
<span class="lineno"> 362 </span><span class="spaces"> </span><span class="nottickedoff">]</span>
|
||||
<span class="lineno"> 363 </span><span class="spaces"></span><span class="nottickedoff">applyRaster RasterRSvg path = runCmd</span>
|
||||
<span class="lineno"> 364 </span><span class="spaces"> </span><span class="nottickedoff">"rsvg-convert"</span>
|
||||
<span class="lineno"> 365 </span><span class="spaces"> </span><span class="nottickedoff">[path, "--unlimited", "--output", replaceExtension path "png"]</span>
|
||||
<span class="lineno"> 366 </span><span class="spaces"></span><span class="nottickedoff">applyRaster RasterMagick path =</span>
|
||||
<span class="lineno"> 367 </span><span class="spaces"> </span><span class="nottickedoff">runCmd magickCmd [path, replaceExtension path "png"]</span></span>
|
||||
<span class="lineno"> 368 </span>
|
||||
<span class="lineno"> 369 </span>concurrentForM_ :: [a] -> (a -> IO ()) -> IO ()
|
||||
<span class="lineno"> 370 </span><span class="decl"><span class="nottickedoff">concurrentForM_ lst action = do</span>
|
||||
<span class="lineno"> 371 </span><span class="spaces"> </span><span class="nottickedoff">n <- getNumCapabilities</span>
|
||||
<span class="lineno"> 372 </span><span class="spaces"> </span><span class="nottickedoff">sem <- newQSemN n</span>
|
||||
<span class="lineno"> 373 </span><span class="spaces"> </span><span class="nottickedoff">eVar <- newEmptyMVar</span>
|
||||
<span class="lineno"> 374 </span><span class="spaces"> </span><span class="nottickedoff">forM_ lst $ \elt -> do</span>
|
||||
<span class="lineno"> 375 </span><span class="spaces"> </span><span class="nottickedoff">waitQSemN sem 1</span>
|
||||
<span class="lineno"> 376 </span><span class="spaces"> </span><span class="nottickedoff">emp <- isEmptyMVar eVar</span>
|
||||
<span class="lineno"> 377 </span><span class="spaces"> </span><span class="nottickedoff">if emp</span>
|
||||
<span class="lineno"> 378 </span><span class="spaces"> </span><span class="nottickedoff">then</span>
|
||||
<span class="lineno"> 379 </span><span class="spaces"> </span><span class="nottickedoff">void</span>
|
||||
<span class="lineno"> 380 </span><span class="spaces"> </span><span class="nottickedoff">$ forkIO</span>
|
||||
<span class="lineno"> 381 </span><span class="spaces"> </span><span class="nottickedoff">( catch (action elt) (void . tryPutMVar eVar)</span>
|
||||
<span class="lineno"> 382 </span><span class="spaces"> </span><span class="nottickedoff">`finally` signalQSemN sem 1</span>
|
||||
<span class="lineno"> 383 </span><span class="spaces"> </span><span class="nottickedoff">)</span>
|
||||
<span class="lineno"> 384 </span><span class="spaces"> </span><span class="nottickedoff">else signalQSemN sem 1</span>
|
||||
<span class="lineno"> 385 </span><span class="spaces"> </span><span class="nottickedoff">waitQSemN sem n</span>
|
||||
<span class="lineno"> 386 </span><span class="spaces"> </span><span class="nottickedoff">mbE <- tryTakeMVar eVar</span>
|
||||
<span class="lineno"> 387 </span><span class="spaces"> </span><span class="nottickedoff">case mbE of</span>
|
||||
<span class="lineno"> 388 </span><span class="spaces"> </span><span class="nottickedoff">Nothing -> return ()</span>
|
||||
<span class="lineno"> 389 </span><span class="spaces"> </span><span class="nottickedoff">Just e -> throwIO (e :: SomeException)</span></span>
|
||||
<span class="lineno"> 111 </span>frameOrder :: Int -> Int -> [Int]
|
||||
<span class="lineno"> 112 </span><span class="decl"><span class="nottickedoff">frameOrder fps nFrames = worker [] fps</span>
|
||||
<span class="lineno"> 113 </span><span class="spaces"> </span><span class="nottickedoff">where</span>
|
||||
<span class="lineno"> 114 </span><span class="spaces"> </span><span class="nottickedoff">worker _seen 0 = []</span>
|
||||
<span class="lineno"> 115 </span><span class="spaces"> </span><span class="nottickedoff">worker seen nthFrame = filterFrameList seen nthFrame nFrames</span>
|
||||
<span class="lineno"> 116 </span><span class="spaces"> </span><span class="nottickedoff">++ worker (nthFrame : seen) (nthFrame `div` 2)</span></span>
|
||||
<span class="lineno"> 117 </span>
|
||||
<span class="lineno"> 118 </span>filterFrameList :: [Int] -> Int -> Int -> [Int]
|
||||
<span class="lineno"> 119 </span><span class="decl"><span class="nottickedoff">filterFrameList seen nthFrame nFrames = filter (not . isSeen)</span>
|
||||
<span class="lineno"> 120 </span><span class="spaces"> </span><span class="nottickedoff">[0, nthFrame .. nFrames - 1]</span>
|
||||
<span class="lineno"> 121 </span><span class="spaces"> </span><span class="nottickedoff">where isSeen x = any (\y -> x `mod` y == 0) seen</span></span>
|
||||
<span class="lineno"> 122 </span>
|
||||
<span class="lineno"> 123 </span>data Format = RenderMp4 | RenderGif | RenderWebm
|
||||
<span class="lineno"> 124 </span> deriving (<span class="decl"><span class="nottickedoff">Show</span></span>)
|
||||
<span class="lineno"> 125 </span>
|
||||
<span class="lineno"> 126 </span>mp4Arguments :: FPS -> FilePath -> FilePath -> FilePath -> [String]
|
||||
<span class="lineno"> 127 </span><span class="decl"><span class="nottickedoff">mp4Arguments fps progress template target =</span>
|
||||
<span class="lineno"> 128 </span><span class="spaces"> </span><span class="nottickedoff">[ "-r"</span>
|
||||
<span class="lineno"> 129 </span><span class="spaces"> </span><span class="nottickedoff">, show fps</span>
|
||||
<span class="lineno"> 130 </span><span class="spaces"> </span><span class="nottickedoff">, "-i"</span>
|
||||
<span class="lineno"> 131 </span><span class="spaces"> </span><span class="nottickedoff">, template</span>
|
||||
<span class="lineno"> 132 </span><span class="spaces"> </span><span class="nottickedoff">, "-y"</span>
|
||||
<span class="lineno"> 133 </span><span class="spaces"> </span><span class="nottickedoff">, "-c:v"</span>
|
||||
<span class="lineno"> 134 </span><span class="spaces"> </span><span class="nottickedoff">, "libx264"</span>
|
||||
<span class="lineno"> 135 </span><span class="spaces"> </span><span class="nottickedoff">, "-vf"</span>
|
||||
<span class="lineno"> 136 </span><span class="spaces"> </span><span class="nottickedoff">, "fps=" ++ show fps</span>
|
||||
<span class="lineno"> 137 </span><span class="spaces"> </span><span class="nottickedoff">, "-preset"</span>
|
||||
<span class="lineno"> 138 </span><span class="spaces"> </span><span class="nottickedoff">, "slow"</span>
|
||||
<span class="lineno"> 139 </span><span class="spaces"> </span><span class="nottickedoff">, "-crf"</span>
|
||||
<span class="lineno"> 140 </span><span class="spaces"> </span><span class="nottickedoff">, "18"</span>
|
||||
<span class="lineno"> 141 </span><span class="spaces"> </span><span class="nottickedoff">, "-movflags"</span>
|
||||
<span class="lineno"> 142 </span><span class="spaces"> </span><span class="nottickedoff">, "+faststart"</span>
|
||||
<span class="lineno"> 143 </span><span class="spaces"> </span><span class="nottickedoff">, "-progress"</span>
|
||||
<span class="lineno"> 144 </span><span class="spaces"> </span><span class="nottickedoff">, progress</span>
|
||||
<span class="lineno"> 145 </span><span class="spaces"> </span><span class="nottickedoff">, "-pix_fmt"</span>
|
||||
<span class="lineno"> 146 </span><span class="spaces"> </span><span class="nottickedoff">, "yuv420p"</span>
|
||||
<span class="lineno"> 147 </span><span class="spaces"> </span><span class="nottickedoff">, target</span>
|
||||
<span class="lineno"> 148 </span><span class="spaces"> </span><span class="nottickedoff">]</span></span>
|
||||
<span class="lineno"> 149 </span>
|
||||
<span class="lineno"> 150 </span>-- gifArguments :: FPS -> FilePath -> FilePath -> FilePath -> [String]
|
||||
<span class="lineno"> 151 </span>-- gifArguments fps progress template target =
|
||||
<span class="lineno"> 152 </span>
|
||||
<span class="lineno"> 153 </span>render
|
||||
<span class="lineno"> 154 </span> :: Animation
|
||||
<span class="lineno"> 155 </span> -> FilePath
|
||||
<span class="lineno"> 156 </span> -> Raster
|
||||
<span class="lineno"> 157 </span> -> Format
|
||||
<span class="lineno"> 158 </span> -> Width
|
||||
<span class="lineno"> 159 </span> -> Height
|
||||
<span class="lineno"> 160 </span> -> FPS
|
||||
<span class="lineno"> 161 </span> -> Bool
|
||||
<span class="lineno"> 162 </span> -> IO ()
|
||||
<span class="lineno"> 163 </span><span class="decl"><span class="nottickedoff">render ani target raster format width height fps partial = do</span>
|
||||
<span class="lineno"> 164 </span><span class="spaces"> </span><span class="nottickedoff">printf "Starting render of animation: %.1f\n" (duration ani)</span>
|
||||
<span class="lineno"> 165 </span><span class="spaces"> </span><span class="nottickedoff">ffmpeg <- requireExecutable "ffmpeg"</span>
|
||||
<span class="lineno"> 166 </span><span class="spaces"> </span><span class="nottickedoff">generateFrames raster ani width height fps partial $ \template -></span>
|
||||
<span class="lineno"> 167 </span><span class="spaces"> </span><span class="nottickedoff">withTempFile "txt" $ \progress -> do</span>
|
||||
<span class="lineno"> 168 </span><span class="spaces"> </span><span class="nottickedoff">writeFile progress ""</span>
|
||||
<span class="lineno"> 169 </span><span class="spaces"> </span><span class="nottickedoff">progressH <- openFile progress ReadMode</span>
|
||||
<span class="lineno"> 170 </span><span class="spaces"> </span><span class="nottickedoff">hSetBuffering progressH NoBuffering</span>
|
||||
<span class="lineno"> 171 </span><span class="spaces"> </span><span class="nottickedoff">allFinished <- newEmptyMVar</span>
|
||||
<span class="lineno"> 172 </span><span class="spaces"> </span><span class="nottickedoff">void $ forkIO $ do</span>
|
||||
<span class="lineno"> 173 </span><span class="spaces"> </span><span class="nottickedoff">progressPrinter "rendered" (animationFrameCount ani fps)</span>
|
||||
<span class="lineno"> 174 </span><span class="spaces"> </span><span class="nottickedoff">$ \done -> fix $ \loop -> do</span>
|
||||
<span class="lineno"> 175 </span><span class="spaces"> </span><span class="nottickedoff">eof <- hIsEOF progressH</span>
|
||||
<span class="lineno"> 176 </span><span class="spaces"> </span><span class="nottickedoff">if eof</span>
|
||||
<span class="lineno"> 177 </span><span class="spaces"> </span><span class="nottickedoff">then threadDelay 1000000 >> loop</span>
|
||||
<span class="lineno"> 178 </span><span class="spaces"> </span><span class="nottickedoff">else do</span>
|
||||
<span class="lineno"> 179 </span><span class="spaces"> </span><span class="nottickedoff">l <- try (hGetLine progressH)</span>
|
||||
<span class="lineno"> 180 </span><span class="spaces"> </span><span class="nottickedoff">case l of</span>
|
||||
<span class="lineno"> 181 </span><span class="spaces"> </span><span class="nottickedoff">Left SomeException{} -> return ()</span>
|
||||
<span class="lineno"> 182 </span><span class="spaces"> </span><span class="nottickedoff">Right str -></span>
|
||||
<span class="lineno"> 183 </span><span class="spaces"> </span><span class="nottickedoff">case take 6 str of</span>
|
||||
<span class="lineno"> 184 </span><span class="spaces"> </span><span class="nottickedoff">"frame=" -> do</span>
|
||||
<span class="lineno"> 185 </span><span class="spaces"> </span><span class="nottickedoff">void $ swapMVar done (read (drop 6 str))</span>
|
||||
<span class="lineno"> 186 </span><span class="spaces"> </span><span class="nottickedoff">loop</span>
|
||||
<span class="lineno"> 187 </span><span class="spaces"> </span><span class="nottickedoff">_ | str == "progress=end" -> return ()</span>
|
||||
<span class="lineno"> 188 </span><span class="spaces"> </span><span class="nottickedoff">_ -> loop</span>
|
||||
<span class="lineno"> 189 </span><span class="spaces"> </span><span class="nottickedoff">putMVar allFinished ()</span>
|
||||
<span class="lineno"> 190 </span><span class="spaces"> </span><span class="nottickedoff">case format of</span>
|
||||
<span class="lineno"> 191 </span><span class="spaces"> </span><span class="nottickedoff">RenderMp4 -> runCmd ffmpeg (mp4Arguments fps progress template target)</span>
|
||||
<span class="lineno"> 192 </span><span class="spaces"> </span><span class="nottickedoff">RenderGif -> withTempFile "png" $ \palette -> do</span>
|
||||
<span class="lineno"> 193 </span><span class="spaces"> </span><span class="nottickedoff">runCmd</span>
|
||||
<span class="lineno"> 194 </span><span class="spaces"> </span><span class="nottickedoff">ffmpeg</span>
|
||||
<span class="lineno"> 195 </span><span class="spaces"> </span><span class="nottickedoff">[ "-i"</span>
|
||||
<span class="lineno"> 196 </span><span class="spaces"> </span><span class="nottickedoff">, template</span>
|
||||
<span class="lineno"> 197 </span><span class="spaces"> </span><span class="nottickedoff">, "-y"</span>
|
||||
<span class="lineno"> 198 </span><span class="spaces"> </span><span class="nottickedoff">, "-vf"</span>
|
||||
<span class="lineno"> 199 </span><span class="spaces"> </span><span class="nottickedoff">, "fps="</span>
|
||||
<span class="lineno"> 200 </span><span class="spaces"> </span><span class="nottickedoff">++ show fps</span>
|
||||
<span class="lineno"> 201 </span><span class="spaces"> </span><span class="nottickedoff">++ ",scale="</span>
|
||||
<span class="lineno"> 202 </span><span class="spaces"> </span><span class="nottickedoff">++ show width</span>
|
||||
<span class="lineno"> 203 </span><span class="spaces"> </span><span class="nottickedoff">++ ":"</span>
|
||||
<span class="lineno"> 204 </span><span class="spaces"> </span><span class="nottickedoff">++ show height</span>
|
||||
<span class="lineno"> 205 </span><span class="spaces"> </span><span class="nottickedoff">++ ":flags=lanczos,palettegen"</span>
|
||||
<span class="lineno"> 206 </span><span class="spaces"> </span><span class="nottickedoff">, "-t"</span>
|
||||
<span class="lineno"> 207 </span><span class="spaces"> </span><span class="nottickedoff">, showFFloat Nothing (duration ani) ""</span>
|
||||
<span class="lineno"> 208 </span><span class="spaces"> </span><span class="nottickedoff">, palette</span>
|
||||
<span class="lineno"> 209 </span><span class="spaces"> </span><span class="nottickedoff">]</span>
|
||||
<span class="lineno"> 210 </span><span class="spaces"> </span><span class="nottickedoff">runCmd</span>
|
||||
<span class="lineno"> 211 </span><span class="spaces"> </span><span class="nottickedoff">ffmpeg</span>
|
||||
<span class="lineno"> 212 </span><span class="spaces"> </span><span class="nottickedoff">[ "-framerate"</span>
|
||||
<span class="lineno"> 213 </span><span class="spaces"> </span><span class="nottickedoff">, show fps</span>
|
||||
<span class="lineno"> 214 </span><span class="spaces"> </span><span class="nottickedoff">, "-i"</span>
|
||||
<span class="lineno"> 215 </span><span class="spaces"> </span><span class="nottickedoff">, template</span>
|
||||
<span class="lineno"> 216 </span><span class="spaces"> </span><span class="nottickedoff">, "-y"</span>
|
||||
<span class="lineno"> 217 </span><span class="spaces"> </span><span class="nottickedoff">, "-i"</span>
|
||||
<span class="lineno"> 218 </span><span class="spaces"> </span><span class="nottickedoff">, palette</span>
|
||||
<span class="lineno"> 219 </span><span class="spaces"> </span><span class="nottickedoff">, "-progress"</span>
|
||||
<span class="lineno"> 220 </span><span class="spaces"> </span><span class="nottickedoff">, progress</span>
|
||||
<span class="lineno"> 221 </span><span class="spaces"> </span><span class="nottickedoff">, "-filter_complex"</span>
|
||||
<span class="lineno"> 222 </span><span class="spaces"> </span><span class="nottickedoff">, "fps="</span>
|
||||
<span class="lineno"> 223 </span><span class="spaces"> </span><span class="nottickedoff">++ show fps</span>
|
||||
<span class="lineno"> 224 </span><span class="spaces"> </span><span class="nottickedoff">++ ",scale="</span>
|
||||
<span class="lineno"> 225 </span><span class="spaces"> </span><span class="nottickedoff">++ show width</span>
|
||||
<span class="lineno"> 226 </span><span class="spaces"> </span><span class="nottickedoff">++ ":"</span>
|
||||
<span class="lineno"> 227 </span><span class="spaces"> </span><span class="nottickedoff">++ show height</span>
|
||||
<span class="lineno"> 228 </span><span class="spaces"> </span><span class="nottickedoff">++ ":flags=lanczos[x];[x][1:v]paletteuse"</span>
|
||||
<span class="lineno"> 229 </span><span class="spaces"> </span><span class="nottickedoff">, "-t"</span>
|
||||
<span class="lineno"> 230 </span><span class="spaces"> </span><span class="nottickedoff">, showFFloat Nothing (duration ani) ""</span>
|
||||
<span class="lineno"> 231 </span><span class="spaces"> </span><span class="nottickedoff">, target</span>
|
||||
<span class="lineno"> 232 </span><span class="spaces"> </span><span class="nottickedoff">]</span>
|
||||
<span class="lineno"> 233 </span><span class="spaces"> </span><span class="nottickedoff">RenderWebm -> runCmd</span>
|
||||
<span class="lineno"> 234 </span><span class="spaces"> </span><span class="nottickedoff">ffmpeg</span>
|
||||
<span class="lineno"> 235 </span><span class="spaces"> </span><span class="nottickedoff">[ "-r"</span>
|
||||
<span class="lineno"> 236 </span><span class="spaces"> </span><span class="nottickedoff">, show fps</span>
|
||||
<span class="lineno"> 237 </span><span class="spaces"> </span><span class="nottickedoff">, "-i"</span>
|
||||
<span class="lineno"> 238 </span><span class="spaces"> </span><span class="nottickedoff">, template</span>
|
||||
<span class="lineno"> 239 </span><span class="spaces"> </span><span class="nottickedoff">, "-y"</span>
|
||||
<span class="lineno"> 240 </span><span class="spaces"> </span><span class="nottickedoff">, "-progress"</span>
|
||||
<span class="lineno"> 241 </span><span class="spaces"> </span><span class="nottickedoff">, progress</span>
|
||||
<span class="lineno"> 242 </span><span class="spaces"> </span><span class="nottickedoff">, "-c:v"</span>
|
||||
<span class="lineno"> 243 </span><span class="spaces"> </span><span class="nottickedoff">, "libvpx-vp9"</span>
|
||||
<span class="lineno"> 244 </span><span class="spaces"> </span><span class="nottickedoff">, "-vf"</span>
|
||||
<span class="lineno"> 245 </span><span class="spaces"> </span><span class="nottickedoff">, "fps=" ++ show fps</span>
|
||||
<span class="lineno"> 246 </span><span class="spaces"> </span><span class="nottickedoff">, target</span>
|
||||
<span class="lineno"> 247 </span><span class="spaces"> </span><span class="nottickedoff">]</span>
|
||||
<span class="lineno"> 248 </span><span class="spaces"> </span><span class="nottickedoff">takeMVar allFinished</span></span>
|
||||
<span class="lineno"> 249 </span>
|
||||
<span class="lineno"> 250 </span>---------------------------------------------------------------------------------
|
||||
<span class="lineno"> 251 </span>-- Helpers
|
||||
<span class="lineno"> 252 </span>
|
||||
<span class="lineno"> 253 </span>progressPrinter :: String -> Int -> (MVar Int -> IO ()) -> IO ()
|
||||
<span class="lineno"> 254 </span><span class="decl"><span class="nottickedoff">progressPrinter typeName maxCount action = do</span>
|
||||
<span class="lineno"> 255 </span><span class="spaces"> </span><span class="nottickedoff">printf "\rFrames %s: 0/%d" typeName maxCount</span>
|
||||
<span class="lineno"> 256 </span><span class="spaces"> </span><span class="nottickedoff">putStr $ clearFromCursorToLineEndCode ++ "\r"</span>
|
||||
<span class="lineno"> 257 </span><span class="spaces"> </span><span class="nottickedoff">done <- newMVar (0 :: Int)</span>
|
||||
<span class="lineno"> 258 </span><span class="spaces"> </span><span class="nottickedoff">start <- getCurrentTime</span>
|
||||
<span class="lineno"> 259 </span><span class="spaces"> </span><span class="nottickedoff">let bgThread = forever $ do</span>
|
||||
<span class="lineno"> 260 </span><span class="spaces"> </span><span class="nottickedoff">nDone <- readMVar done</span>
|
||||
<span class="lineno"> 261 </span><span class="spaces"> </span><span class="nottickedoff">now <- getCurrentTime</span>
|
||||
<span class="lineno"> 262 </span><span class="spaces"> </span><span class="nottickedoff">let spent = diffUTCTime now start</span>
|
||||
<span class="lineno"> 263 </span><span class="spaces"> </span><span class="nottickedoff">remaining =</span>
|
||||
<span class="lineno"> 264 </span><span class="spaces"> </span><span class="nottickedoff">(spent / (fromIntegral nDone / fromIntegral maxCount)) - spent</span>
|
||||
<span class="lineno"> 265 </span><span class="spaces"> </span><span class="nottickedoff">printf "\rFrames %s: %d/%d" typeName nDone maxCount</span>
|
||||
<span class="lineno"> 266 </span><span class="spaces"> </span><span class="nottickedoff">putStr $ ", time spent: " ++ ppDiff spent</span>
|
||||
<span class="lineno"> 267 </span><span class="spaces"> </span><span class="nottickedoff">unless (nDone == 0) $ do</span>
|
||||
<span class="lineno"> 268 </span><span class="spaces"> </span><span class="nottickedoff">putStr $ ", time remaining: " ++ ppDiff remaining</span>
|
||||
<span class="lineno"> 269 </span><span class="spaces"> </span><span class="nottickedoff">putStr $ ", total time: " ++ ppDiff (remaining + spent)</span>
|
||||
<span class="lineno"> 270 </span><span class="spaces"> </span><span class="nottickedoff">putStr $ clearFromCursorToLineEndCode ++ "\r"</span>
|
||||
<span class="lineno"> 271 </span><span class="spaces"> </span><span class="nottickedoff">hFlush stdout</span>
|
||||
<span class="lineno"> 272 </span><span class="spaces"> </span><span class="nottickedoff">threadDelay 1000000</span>
|
||||
<span class="lineno"> 273 </span><span class="spaces"> </span><span class="nottickedoff">withBackgroundThread bgThread $ action done</span>
|
||||
<span class="lineno"> 274 </span><span class="spaces"> </span><span class="nottickedoff">now <- getCurrentTime</span>
|
||||
<span class="lineno"> 275 </span><span class="spaces"> </span><span class="nottickedoff">let spent = diffUTCTime now start</span>
|
||||
<span class="lineno"> 276 </span><span class="spaces"> </span><span class="nottickedoff">printf "\rFrames %s: %d/%d" typeName maxCount maxCount</span>
|
||||
<span class="lineno"> 277 </span><span class="spaces"> </span><span class="nottickedoff">putStr $ ", time spent: " ++ ppDiff spent</span>
|
||||
<span class="lineno"> 278 </span><span class="spaces"> </span><span class="nottickedoff">putStr $ clearFromCursorToLineEndCode ++ "\n"</span></span>
|
||||
<span class="lineno"> 279 </span>
|
||||
<span class="lineno"> 280 </span>animationFrameCount :: Animation -> FPS -> Int
|
||||
<span class="lineno"> 281 </span><span class="decl"><span class="nottickedoff">animationFrameCount ani rate = round (duration ani * fromIntegral rate) :: Int</span></span>
|
||||
<span class="lineno"> 282 </span>
|
||||
<span class="lineno"> 283 </span>generateFrames
|
||||
<span class="lineno"> 284 </span> :: Raster -> Animation -> Width -> Height -> FPS -> Bool -> (FilePath -> IO a) -> IO a
|
||||
<span class="lineno"> 285 </span><span class="decl"><span class="nottickedoff">generateFrames raster ani width_ height_ rate partial action = withTempDir $ \tmp -> do</span>
|
||||
<span class="lineno"> 286 </span><span class="spaces"> </span><span class="nottickedoff">let frameName nth = tmp </> printf nameTemplate nth</span>
|
||||
<span class="lineno"> 287 </span><span class="spaces"> </span><span class="nottickedoff">setRootDirectory tmp</span>
|
||||
<span class="lineno"> 288 </span><span class="spaces"> </span><span class="nottickedoff">progressPrinter "generated" frameCount</span>
|
||||
<span class="lineno"> 289 </span><span class="spaces"> </span><span class="nottickedoff">$ \done -> handle h $ concurrentForM_ frames $ \n -> do</span>
|
||||
<span class="lineno"> 290 </span><span class="spaces"> </span><span class="nottickedoff">writeFile (frameName n) $ renderSvg width height $ nthFrame n</span>
|
||||
<span class="lineno"> 291 </span><span class="spaces"> </span><span class="nottickedoff">modifyMVar_ done $ \nDone -> return (nDone + 1)</span>
|
||||
<span class="lineno"> 292 </span><span class="spaces"></span><span class="nottickedoff"></span>
|
||||
<span class="lineno"> 293 </span><span class="spaces"> </span><span class="nottickedoff">when (isValidRaster raster)</span>
|
||||
<span class="lineno"> 294 </span><span class="spaces"> </span><span class="nottickedoff">$ progressPrinter "rastered" frameCount</span>
|
||||
<span class="lineno"> 295 </span><span class="spaces"> </span><span class="nottickedoff">$ \done -> handle h $ concurrentForM_ frames $ \n -> do</span>
|
||||
<span class="lineno"> 296 </span><span class="spaces"> </span><span class="nottickedoff">applyRaster raster (frameName n)</span>
|
||||
<span class="lineno"> 297 </span><span class="spaces"> </span><span class="nottickedoff">modifyMVar_ done $ \nDone -> return (nDone + 1)</span>
|
||||
<span class="lineno"> 298 </span><span class="spaces"></span><span class="nottickedoff"></span>
|
||||
<span class="lineno"> 299 </span><span class="spaces"> </span><span class="nottickedoff">action (tmp </> rasterTemplate raster)</span>
|
||||
<span class="lineno"> 300 </span><span class="spaces"> </span><span class="nottickedoff">where</span>
|
||||
<span class="lineno"> 301 </span><span class="spaces"> </span><span class="nottickedoff">isValidRaster RasterNone = False</span>
|
||||
<span class="lineno"> 302 </span><span class="spaces"> </span><span class="nottickedoff">isValidRaster RasterAuto = False</span>
|
||||
<span class="lineno"> 303 </span><span class="spaces"> </span><span class="nottickedoff">isValidRaster _ = True</span>
|
||||
<span class="lineno"> 304 </span><span class="spaces"></span><span class="nottickedoff"></span>
|
||||
<span class="lineno"> 305 </span><span class="spaces"> </span><span class="nottickedoff">width = Just $ Px $ fromIntegral width_</span>
|
||||
<span class="lineno"> 306 </span><span class="spaces"> </span><span class="nottickedoff">height = Just $ Px $ fromIntegral height_</span>
|
||||
<span class="lineno"> 307 </span><span class="spaces"> </span><span class="nottickedoff">h UserInterrupt | partial = do</span>
|
||||
<span class="lineno"> 308 </span><span class="spaces"> </span><span class="nottickedoff">hPutStrLn</span>
|
||||
<span class="lineno"> 309 </span><span class="spaces"> </span><span class="nottickedoff">stderr</span>
|
||||
<span class="lineno"> 310 </span><span class="spaces"> </span><span class="nottickedoff">"\nCtrl-C detected. Trying to generate video with available frames. \</span>
|
||||
<span class="lineno"> 311 </span><span class="spaces"> </span><span class="nottickedoff">\Hit ctrl-c again to abort."</span>
|
||||
<span class="lineno"> 312 </span><span class="spaces"> </span><span class="nottickedoff">return ()</span>
|
||||
<span class="lineno"> 313 </span><span class="spaces"> </span><span class="nottickedoff">h other = throwIO other</span>
|
||||
<span class="lineno"> 314 </span><span class="spaces"> </span><span class="nottickedoff">-- frames = [0..frameCount-1]</span>
|
||||
<span class="lineno"> 315 </span><span class="spaces"> </span><span class="nottickedoff">frames = frameOrder rate frameCount</span>
|
||||
<span class="lineno"> 316 </span><span class="spaces"> </span><span class="nottickedoff">nthFrame nth = frameAt (recip (fromIntegral rate) * fromIntegral nth) ani</span>
|
||||
<span class="lineno"> 317 </span><span class="spaces"> </span><span class="nottickedoff">frameCount = animationFrameCount ani rate</span>
|
||||
<span class="lineno"> 318 </span><span class="spaces"> </span><span class="nottickedoff">nameTemplate :: String</span>
|
||||
<span class="lineno"> 319 </span><span class="spaces"> </span><span class="nottickedoff">nameTemplate = "render-%05d.svg"</span></span>
|
||||
<span class="lineno"> 320 </span>
|
||||
<span class="lineno"> 321 </span>withBackgroundThread :: IO () -> IO a -> IO a
|
||||
<span class="lineno"> 322 </span><span class="decl"><span class="nottickedoff">withBackgroundThread t = bracket (forkIO t) killThread . const</span></span>
|
||||
<span class="lineno"> 323 </span>
|
||||
<span class="lineno"> 324 </span>ppDiff :: NominalDiffTime -> String
|
||||
<span class="lineno"> 325 </span><span class="decl"><span class="nottickedoff">ppDiff diff | hours == 0 && mins == 0 = show secs ++ "s"</span>
|
||||
<span class="lineno"> 326 </span><span class="spaces"> </span><span class="nottickedoff">| hours == 0 = printf "%.2d:%.2d" mins secs</span>
|
||||
<span class="lineno"> 327 </span><span class="spaces"> </span><span class="nottickedoff">| otherwise = printf "%.2d:%.2d:%.2d" hours mins secs</span>
|
||||
<span class="lineno"> 328 </span><span class="spaces"> </span><span class="nottickedoff">where</span>
|
||||
<span class="lineno"> 329 </span><span class="spaces"> </span><span class="nottickedoff">(osecs, secs) = round diff `divMod` (60 :: Int)</span>
|
||||
<span class="lineno"> 330 </span><span class="spaces"> </span><span class="nottickedoff">(hours, mins) = osecs `divMod` 60</span></span>
|
||||
<span class="lineno"> 331 </span>
|
||||
<span class="lineno"> 332 </span>rasterTemplate :: Raster -> String
|
||||
<span class="lineno"> 333 </span><span class="decl"><span class="nottickedoff">rasterTemplate RasterNone = "render-%05d.svg"</span>
|
||||
<span class="lineno"> 334 </span><span class="spaces"></span><span class="nottickedoff">rasterTemplate RasterAuto = "render-%05d.svg"</span>
|
||||
<span class="lineno"> 335 </span><span class="spaces"></span><span class="nottickedoff">rasterTemplate _ = "render-%05d.png"</span></span>
|
||||
<span class="lineno"> 336 </span>
|
||||
<span class="lineno"> 337 </span>requireRaster :: Raster -> IO Raster
|
||||
<span class="lineno"> 338 </span><span class="decl"><span class="nottickedoff">requireRaster raster = do</span>
|
||||
<span class="lineno"> 339 </span><span class="spaces"> </span><span class="nottickedoff">raster' <- selectRaster (if raster == RasterNone then RasterAuto else raster)</span>
|
||||
<span class="lineno"> 340 </span><span class="spaces"> </span><span class="nottickedoff">case raster' of</span>
|
||||
<span class="lineno"> 341 </span><span class="spaces"> </span><span class="nottickedoff">RasterNone -> do</span>
|
||||
<span class="lineno"> 342 </span><span class="spaces"> </span><span class="nottickedoff">hPutStrLn</span>
|
||||
<span class="lineno"> 343 </span><span class="spaces"> </span><span class="nottickedoff">stderr</span>
|
||||
<span class="lineno"> 344 </span><span class="spaces"> </span><span class="nottickedoff">"Raster required but none could be found. \</span>
|
||||
<span class="lineno"> 345 </span><span class="spaces"> </span><span class="nottickedoff">\Please install either inkscape, imagemagick, or rsvg-convert."</span>
|
||||
<span class="lineno"> 346 </span><span class="spaces"> </span><span class="nottickedoff">exitWith (ExitFailure 1)</span>
|
||||
<span class="lineno"> 347 </span><span class="spaces"> </span><span class="nottickedoff">_ -> pure raster'</span></span>
|
||||
<span class="lineno"> 348 </span>
|
||||
<span class="lineno"> 349 </span>selectRaster :: Raster -> IO Raster
|
||||
<span class="lineno"> 350 </span><span class="decl"><span class="nottickedoff">selectRaster RasterAuto = do</span>
|
||||
<span class="lineno"> 351 </span><span class="spaces"> </span><span class="nottickedoff">rsvg <- hasRSvg</span>
|
||||
<span class="lineno"> 352 </span><span class="spaces"> </span><span class="nottickedoff">ink <- hasInkscape</span>
|
||||
<span class="lineno"> 353 </span><span class="spaces"> </span><span class="nottickedoff">magick <- hasMagick</span>
|
||||
<span class="lineno"> 354 </span><span class="spaces"> </span><span class="nottickedoff">if</span>
|
||||
<span class="lineno"> 355 </span><span class="spaces"> </span><span class="nottickedoff">| isRight rsvg -> pure RasterRSvg</span>
|
||||
<span class="lineno"> 356 </span><span class="spaces"> </span><span class="nottickedoff">| isRight ink -> pure RasterInkscape</span>
|
||||
<span class="lineno"> 357 </span><span class="spaces"> </span><span class="nottickedoff">| isRight magick -> pure RasterMagick</span>
|
||||
<span class="lineno"> 358 </span><span class="spaces"> </span><span class="nottickedoff">| otherwise -> pure RasterNone</span>
|
||||
<span class="lineno"> 359 </span><span class="spaces"></span><span class="nottickedoff">selectRaster r = pure r</span></span>
|
||||
<span class="lineno"> 360 </span>
|
||||
<span class="lineno"> 361 </span>applyRaster :: Raster -> FilePath -> IO ()
|
||||
<span class="lineno"> 362 </span><span class="decl"><span class="nottickedoff">applyRaster RasterNone _ = return ()</span>
|
||||
<span class="lineno"> 363 </span><span class="spaces"></span><span class="nottickedoff">applyRaster RasterAuto _ = return ()</span>
|
||||
<span class="lineno"> 364 </span><span class="spaces"></span><span class="nottickedoff">applyRaster RasterInkscape path = runCmd</span>
|
||||
<span class="lineno"> 365 </span><span class="spaces"> </span><span class="nottickedoff">"inkscape"</span>
|
||||
<span class="lineno"> 366 </span><span class="spaces"> </span><span class="nottickedoff">[ "--without-gui"</span>
|
||||
<span class="lineno"> 367 </span><span class="spaces"> </span><span class="nottickedoff">, "--file=" ++ path</span>
|
||||
<span class="lineno"> 368 </span><span class="spaces"> </span><span class="nottickedoff">, "--export-png=" ++ replaceExtension path "png"</span>
|
||||
<span class="lineno"> 369 </span><span class="spaces"> </span><span class="nottickedoff">]</span>
|
||||
<span class="lineno"> 370 </span><span class="spaces"></span><span class="nottickedoff">applyRaster RasterRSvg path = runCmd</span>
|
||||
<span class="lineno"> 371 </span><span class="spaces"> </span><span class="nottickedoff">"rsvg-convert"</span>
|
||||
<span class="lineno"> 372 </span><span class="spaces"> </span><span class="nottickedoff">[path, "--unlimited", "--output", replaceExtension path "png"]</span>
|
||||
<span class="lineno"> 373 </span><span class="spaces"></span><span class="nottickedoff">applyRaster RasterMagick path =</span>
|
||||
<span class="lineno"> 374 </span><span class="spaces"> </span><span class="nottickedoff">runCmd magickCmd [path, replaceExtension path "png"]</span></span>
|
||||
<span class="lineno"> 375 </span>
|
||||
<span class="lineno"> 376 </span>concurrentForM_ :: [a] -> (a -> IO ()) -> IO ()
|
||||
<span class="lineno"> 377 </span><span class="decl"><span class="nottickedoff">concurrentForM_ lst action = do</span>
|
||||
<span class="lineno"> 378 </span><span class="spaces"> </span><span class="nottickedoff">n <- getNumCapabilities</span>
|
||||
<span class="lineno"> 379 </span><span class="spaces"> </span><span class="nottickedoff">sem <- newQSemN n</span>
|
||||
<span class="lineno"> 380 </span><span class="spaces"> </span><span class="nottickedoff">eVar <- newEmptyMVar</span>
|
||||
<span class="lineno"> 381 </span><span class="spaces"> </span><span class="nottickedoff">forM_ lst $ \elt -> do</span>
|
||||
<span class="lineno"> 382 </span><span class="spaces"> </span><span class="nottickedoff">waitQSemN sem 1</span>
|
||||
<span class="lineno"> 383 </span><span class="spaces"> </span><span class="nottickedoff">emp <- isEmptyMVar eVar</span>
|
||||
<span class="lineno"> 384 </span><span class="spaces"> </span><span class="nottickedoff">if emp</span>
|
||||
<span class="lineno"> 385 </span><span class="spaces"> </span><span class="nottickedoff">then</span>
|
||||
<span class="lineno"> 386 </span><span class="spaces"> </span><span class="nottickedoff">void</span>
|
||||
<span class="lineno"> 387 </span><span class="spaces"> </span><span class="nottickedoff">$ forkIO</span>
|
||||
<span class="lineno"> 388 </span><span class="spaces"> </span><span class="nottickedoff">( catch (action elt) (void . tryPutMVar eVar)</span>
|
||||
<span class="lineno"> 389 </span><span class="spaces"> </span><span class="nottickedoff">`finally` signalQSemN sem 1</span>
|
||||
<span class="lineno"> 390 </span><span class="spaces"> </span><span class="nottickedoff">)</span>
|
||||
<span class="lineno"> 391 </span><span class="spaces"> </span><span class="nottickedoff">else signalQSemN sem 1</span>
|
||||
<span class="lineno"> 392 </span><span class="spaces"> </span><span class="nottickedoff">waitQSemN sem n</span>
|
||||
<span class="lineno"> 393 </span><span class="spaces"> </span><span class="nottickedoff">mbE <- tryTakeMVar eVar</span>
|
||||
<span class="lineno"> 394 </span><span class="spaces"> </span><span class="nottickedoff">case mbE of</span>
|
||||
<span class="lineno"> 395 </span><span class="spaces"> </span><span class="nottickedoff">Nothing -> return ()</span>
|
||||
<span class="lineno"> 396 </span><span class="spaces"> </span><span class="nottickedoff">Just e -> throwIO (e :: SomeException)</span></span>
|
||||
|
||||
</pre>
|
||||
</body>
|
||||
|
|
|
|||
|
|
@ -17,69 +17,76 @@ span.spaces { background: white }
|
|||
<span class="decl"><span class="nottickedoff">never executed</span> <span class="tickonlytrue">always true</span> <span class="tickonlyfalse">always false</span></span>
|
||||
</pre>
|
||||
<pre>
|
||||
<span class="lineno"> 1 </span>module Reanimate.Svg.Unuse
|
||||
<span class="lineno"> 2 </span> ( replaceUses
|
||||
<span class="lineno"> 3 </span> , unbox
|
||||
<span class="lineno"> 4 </span> , embedDocument
|
||||
<span class="lineno"> 5 </span> ) where
|
||||
<span class="lineno"> 6 </span>
|
||||
<span class="lineno"> 7 </span>import Control.Lens ((%~), (&), (.~), (?~), (^.))
|
||||
<span class="lineno"> 8 </span>import qualified Data.Map as Map
|
||||
<span class="lineno"> 9 </span>import Data.Maybe
|
||||
<span class="lineno"> 10 </span>import Graphics.SvgTree hiding (line, path, use)
|
||||
<span class="lineno"> 11 </span>import Reanimate.Constants
|
||||
<span class="lineno"> 12 </span>import Reanimate.Svg.Constructors
|
||||
<span class="lineno"> 1 </span>{-|
|
||||
<span class="lineno"> 2 </span>Copyright : Written by David Himmelstrup
|
||||
<span class="lineno"> 3 </span>License : Unlicense
|
||||
<span class="lineno"> 4 </span>Maintainer : lemmih@gmail.com
|
||||
<span class="lineno"> 5 </span>Stability : experimental
|
||||
<span class="lineno"> 6 </span>Portability : POSIX
|
||||
<span class="lineno"> 7 </span>-}
|
||||
<span class="lineno"> 8 </span>module Reanimate.Svg.Unuse
|
||||
<span class="lineno"> 9 </span> ( replaceUses
|
||||
<span class="lineno"> 10 </span> , unbox
|
||||
<span class="lineno"> 11 </span> , embedDocument
|
||||
<span class="lineno"> 12 </span> ) where
|
||||
<span class="lineno"> 13 </span>
|
||||
<span class="lineno"> 14 </span>-- | Replace all @<use>@ nodes with their definition.
|
||||
<span class="lineno"> 15 </span>replaceUses :: Document -> Document
|
||||
<span class="lineno"> 16 </span><span class="decl"><span class="nottickedoff">replaceUses doc = doc & elements %~ map (mapTree replace)</span>
|
||||
<span class="lineno"> 17 </span><span class="spaces"> </span><span class="nottickedoff">where</span>
|
||||
<span class="lineno"> 18 </span><span class="spaces"> </span><span class="nottickedoff">replaceDefinition PathTree{} = None</span>
|
||||
<span class="lineno"> 19 </span><span class="spaces"> </span><span class="nottickedoff">replaceDefinition t = t</span>
|
||||
<span class="lineno"> 20 </span><span class="spaces"></span><span class="nottickedoff"></span>
|
||||
<span class="lineno"> 21 </span><span class="spaces"> </span><span class="nottickedoff">replace t@DefinitionTree{} = mapTree replaceDefinition t</span>
|
||||
<span class="lineno"> 22 </span><span class="spaces"> </span><span class="nottickedoff">replace (UseTree _ Just{}) = error "replaceUses: subtree in use?"</span>
|
||||
<span class="lineno"> 23 </span><span class="spaces"> </span><span class="nottickedoff">replace (UseTree use Nothing) =</span>
|
||||
<span class="lineno"> 24 </span><span class="spaces"> </span><span class="nottickedoff">case Map.lookup (use^.useName) idMap of</span>
|
||||
<span class="lineno"> 25 </span><span class="spaces"> </span><span class="nottickedoff">Nothing -> error $ "Unknown id: " ++ (use^.useName)</span>
|
||||
<span class="lineno"> 26 </span><span class="spaces"> </span><span class="nottickedoff">Just tree -> mapTree replace $</span>
|
||||
<span class="lineno"> 27 </span><span class="spaces"> </span><span class="nottickedoff">GroupTree $</span>
|
||||
<span class="lineno"> 28 </span><span class="spaces"> </span><span class="nottickedoff">defaultSvg & groupChildren .~ [tree]</span>
|
||||
<span class="lineno"> 29 </span><span class="spaces"> </span><span class="nottickedoff">& transform ?~</span>
|
||||
<span class="lineno"> 30 </span><span class="spaces"> </span><span class="nottickedoff">fromMaybe [] (use^.transform) ++</span>
|
||||
<span class="lineno"> 31 </span><span class="spaces"> </span><span class="nottickedoff">[baseToTransformation (use^.useBase)]</span>
|
||||
<span class="lineno"> 32 </span><span class="spaces"> </span><span class="nottickedoff">replace x = x</span>
|
||||
<span class="lineno"> 33 </span><span class="spaces"> </span><span class="nottickedoff">baseToTransformation (x,y) =</span>
|
||||
<span class="lineno"> 34 </span><span class="spaces"> </span><span class="nottickedoff">case (toUserUnit defaultDPI x, toUserUnit defaultDPI y) of</span>
|
||||
<span class="lineno"> 35 </span><span class="spaces"> </span><span class="nottickedoff">(Num a, Num b) -> Translate a b</span>
|
||||
<span class="lineno"> 36 </span><span class="spaces"> </span><span class="nottickedoff">_ -> TransformUnknown</span>
|
||||
<span class="lineno"> 37 </span><span class="spaces"> </span><span class="nottickedoff">docTree = mkGroup (doc^.elements)</span>
|
||||
<span class="lineno"> 38 </span><span class="spaces"> </span><span class="nottickedoff">idMap = foldTree updMap Map.empty docTree</span>
|
||||
<span class="lineno"> 39 </span><span class="spaces"> </span><span class="nottickedoff">updMap m tree =</span>
|
||||
<span class="lineno"> 40 </span><span class="spaces"> </span><span class="nottickedoff">case tree^.attrId of</span>
|
||||
<span class="lineno"> 41 </span><span class="spaces"> </span><span class="nottickedoff">Nothing -> m</span>
|
||||
<span class="lineno"> 42 </span><span class="spaces"> </span><span class="nottickedoff">Just tid -> Map.insert tid tree m</span></span>
|
||||
<span class="lineno"> 43 </span>
|
||||
<span class="lineno"> 44 </span>-- FIXME: the viewbox is ignored. Can we use the viewbox as a mask?
|
||||
<span class="lineno"> 45 </span>-- | Transform out viewbox. Definitions and CSS rules are discarded.
|
||||
<span class="lineno"> 46 </span>unbox :: Document -> Tree
|
||||
<span class="lineno"> 47 </span><span class="decl"><span class="nottickedoff">unbox doc@Document{_viewBox = Just (_minx, _minw, _width, _height)} =</span>
|
||||
<span class="lineno"> 48 </span><span class="spaces"> </span><span class="nottickedoff">GroupTree $ defaultSvg</span>
|
||||
<span class="lineno"> 49 </span><span class="spaces"> </span><span class="nottickedoff">& groupChildren .~ doc^.elements</span>
|
||||
<span class="lineno"> 50 </span><span class="spaces"></span><span class="nottickedoff">unbox doc =</span>
|
||||
<span class="lineno"> 51 </span><span class="spaces"> </span><span class="nottickedoff">GroupTree $ defaultSvg</span>
|
||||
<span class="lineno"> 52 </span><span class="spaces"> </span><span class="nottickedoff">& groupChildren .~ doc^.elements</span></span>
|
||||
<span class="lineno"> 53 </span>
|
||||
<span class="lineno"> 54 </span>-- | Embed 'Document'. This keeps the entire document intact but makes
|
||||
<span class="lineno"> 55 </span>-- it more difficult to use, say, `Reanimate.Svg.pathify` on it.
|
||||
<span class="lineno"> 56 </span>embedDocument :: Document -> Tree
|
||||
<span class="lineno"> 57 </span><span class="decl"><span class="istickedoff">embedDocument doc =</span>
|
||||
<span class="lineno"> 58 </span><span class="spaces"> </span><span class="istickedoff">translate (-screenWidth/2) (screenHeight/2) $</span>
|
||||
<span class="lineno"> 59 </span><span class="spaces"> </span><span class="istickedoff">withFillOpacity 1 $</span>
|
||||
<span class="lineno"> 60 </span><span class="spaces"> </span><span class="istickedoff">withStrokeWidth 0 $</span>
|
||||
<span class="lineno"> 61 </span><span class="spaces"> </span><span class="istickedoff">flipYAxis $</span>
|
||||
<span class="lineno"> 62 </span><span class="spaces"> </span><span class="istickedoff">SvgTree $ doc & width .~ Nothing</span>
|
||||
<span class="lineno"> 63 </span><span class="spaces"> </span><span class="istickedoff">& height .~ Nothing</span></span>
|
||||
<span class="lineno"> 14 </span>import Control.Lens ((%~), (&), (.~), (?~), (^.))
|
||||
<span class="lineno"> 15 </span>import qualified Data.Map as Map
|
||||
<span class="lineno"> 16 </span>import Data.Maybe
|
||||
<span class="lineno"> 17 </span>import Graphics.SvgTree hiding (line, path, use)
|
||||
<span class="lineno"> 18 </span>import Reanimate.Constants
|
||||
<span class="lineno"> 19 </span>import Reanimate.Svg.Constructors
|
||||
<span class="lineno"> 20 </span>
|
||||
<span class="lineno"> 21 </span>-- | Replace all @<use>@ nodes with their definition.
|
||||
<span class="lineno"> 22 </span>replaceUses :: Document -> Document
|
||||
<span class="lineno"> 23 </span><span class="decl"><span class="nottickedoff">replaceUses doc = doc & elements %~ map (mapTree replace)</span>
|
||||
<span class="lineno"> 24 </span><span class="spaces"> </span><span class="nottickedoff">where</span>
|
||||
<span class="lineno"> 25 </span><span class="spaces"> </span><span class="nottickedoff">replaceDefinition PathTree{} = None</span>
|
||||
<span class="lineno"> 26 </span><span class="spaces"> </span><span class="nottickedoff">replaceDefinition t = t</span>
|
||||
<span class="lineno"> 27 </span><span class="spaces"></span><span class="nottickedoff"></span>
|
||||
<span class="lineno"> 28 </span><span class="spaces"> </span><span class="nottickedoff">replace t@DefinitionTree{} = mapTree replaceDefinition t</span>
|
||||
<span class="lineno"> 29 </span><span class="spaces"> </span><span class="nottickedoff">replace (UseTree _ Just{}) = error "replaceUses: subtree in use?"</span>
|
||||
<span class="lineno"> 30 </span><span class="spaces"> </span><span class="nottickedoff">replace (UseTree use Nothing) =</span>
|
||||
<span class="lineno"> 31 </span><span class="spaces"> </span><span class="nottickedoff">case Map.lookup (use^.useName) idMap of</span>
|
||||
<span class="lineno"> 32 </span><span class="spaces"> </span><span class="nottickedoff">Nothing -> error $ "Unknown id: " ++ (use^.useName)</span>
|
||||
<span class="lineno"> 33 </span><span class="spaces"> </span><span class="nottickedoff">Just tree -> mapTree replace $</span>
|
||||
<span class="lineno"> 34 </span><span class="spaces"> </span><span class="nottickedoff">GroupTree $</span>
|
||||
<span class="lineno"> 35 </span><span class="spaces"> </span><span class="nottickedoff">defaultSvg & groupChildren .~ [tree]</span>
|
||||
<span class="lineno"> 36 </span><span class="spaces"> </span><span class="nottickedoff">& transform ?~</span>
|
||||
<span class="lineno"> 37 </span><span class="spaces"> </span><span class="nottickedoff">fromMaybe [] (use^.transform) ++</span>
|
||||
<span class="lineno"> 38 </span><span class="spaces"> </span><span class="nottickedoff">[baseToTransformation (use^.useBase)]</span>
|
||||
<span class="lineno"> 39 </span><span class="spaces"> </span><span class="nottickedoff">replace x = x</span>
|
||||
<span class="lineno"> 40 </span><span class="spaces"> </span><span class="nottickedoff">baseToTransformation (x,y) =</span>
|
||||
<span class="lineno"> 41 </span><span class="spaces"> </span><span class="nottickedoff">case (toUserUnit defaultDPI x, toUserUnit defaultDPI y) of</span>
|
||||
<span class="lineno"> 42 </span><span class="spaces"> </span><span class="nottickedoff">(Num a, Num b) -> Translate a b</span>
|
||||
<span class="lineno"> 43 </span><span class="spaces"> </span><span class="nottickedoff">_ -> TransformUnknown</span>
|
||||
<span class="lineno"> 44 </span><span class="spaces"> </span><span class="nottickedoff">docTree = mkGroup (doc^.elements)</span>
|
||||
<span class="lineno"> 45 </span><span class="spaces"> </span><span class="nottickedoff">idMap = foldTree updMap Map.empty docTree</span>
|
||||
<span class="lineno"> 46 </span><span class="spaces"> </span><span class="nottickedoff">updMap m tree =</span>
|
||||
<span class="lineno"> 47 </span><span class="spaces"> </span><span class="nottickedoff">case tree^.attrId of</span>
|
||||
<span class="lineno"> 48 </span><span class="spaces"> </span><span class="nottickedoff">Nothing -> m</span>
|
||||
<span class="lineno"> 49 </span><span class="spaces"> </span><span class="nottickedoff">Just tid -> Map.insert tid tree m</span></span>
|
||||
<span class="lineno"> 50 </span>
|
||||
<span class="lineno"> 51 </span>-- FIXME: the viewbox is ignored. Can we use the viewbox as a mask?
|
||||
<span class="lineno"> 52 </span>-- | Transform out viewbox. Definitions and CSS rules are discarded.
|
||||
<span class="lineno"> 53 </span>unbox :: Document -> Tree
|
||||
<span class="lineno"> 54 </span><span class="decl"><span class="nottickedoff">unbox doc@Document{_viewBox = Just (_minx, _minw, _width, _height)} =</span>
|
||||
<span class="lineno"> 55 </span><span class="spaces"> </span><span class="nottickedoff">GroupTree $ defaultSvg</span>
|
||||
<span class="lineno"> 56 </span><span class="spaces"> </span><span class="nottickedoff">& groupChildren .~ doc^.elements</span>
|
||||
<span class="lineno"> 57 </span><span class="spaces"></span><span class="nottickedoff">unbox doc =</span>
|
||||
<span class="lineno"> 58 </span><span class="spaces"> </span><span class="nottickedoff">GroupTree $ defaultSvg</span>
|
||||
<span class="lineno"> 59 </span><span class="spaces"> </span><span class="nottickedoff">& groupChildren .~ doc^.elements</span></span>
|
||||
<span class="lineno"> 60 </span>
|
||||
<span class="lineno"> 61 </span>-- | Embed 'Document'. This keeps the entire document intact but makes
|
||||
<span class="lineno"> 62 </span>-- it more difficult to use, say, `Reanimate.Svg.pathify` on it.
|
||||
<span class="lineno"> 63 </span>embedDocument :: Document -> Tree
|
||||
<span class="lineno"> 64 </span><span class="decl"><span class="istickedoff">embedDocument doc =</span>
|
||||
<span class="lineno"> 65 </span><span class="spaces"> </span><span class="istickedoff">translate (-screenWidth/2) (screenHeight/2) $</span>
|
||||
<span class="lineno"> 66 </span><span class="spaces"> </span><span class="istickedoff">withFillOpacity 1 $</span>
|
||||
<span class="lineno"> 67 </span><span class="spaces"> </span><span class="istickedoff">withStrokeWidth 0 $</span>
|
||||
<span class="lineno"> 68 </span><span class="spaces"> </span><span class="istickedoff">flipYAxis $</span>
|
||||
<span class="lineno"> 69 </span><span class="spaces"> </span><span class="istickedoff">SvgTree $ doc & width .~ Nothing</span>
|
||||
<span class="lineno"> 70 </span><span class="spaces"> </span><span class="istickedoff">& height .~ Nothing</span></span>
|
||||
|
||||
</pre>
|
||||
</body>
|
||||
|
|
|
|||
|
|
@ -18,333 +18,340 @@ span.spaces { background: white }
|
|||
</pre>
|
||||
<pre>
|
||||
<span class="lineno"> 1 </span>{-# LANGUAGE LambdaCase #-}
|
||||
<span class="lineno"> 2 </span>module Reanimate.Svg
|
||||
<span class="lineno"> 3 </span> ( module Reanimate.Svg
|
||||
<span class="lineno"> 4 </span> , module Reanimate.Svg.Constructors
|
||||
<span class="lineno"> 5 </span> , module Reanimate.Svg.LineCommand
|
||||
<span class="lineno"> 6 </span> , module Reanimate.Svg.BoundingBox
|
||||
<span class="lineno"> 7 </span> , module Reanimate.Svg.Unuse
|
||||
<span class="lineno"> 8 </span> ) where
|
||||
<span class="lineno"> 9 </span>
|
||||
<span class="lineno"> 10 </span>import Control.Lens ((%~), (&), (.~), (^.), (?~))
|
||||
<span class="lineno"> 11 </span>import Control.Monad.State
|
||||
<span class="lineno"> 12 </span>import Graphics.SvgTree hiding (height, line, path, use,
|
||||
<span class="lineno"> 13 </span> width)
|
||||
<span class="lineno"> 14 </span>import Linear.V2 hiding (angle)
|
||||
<span class="lineno"> 15 </span>import Reanimate.Constants
|
||||
<span class="lineno"> 16 </span>import Reanimate.Animation (SVG)
|
||||
<span class="lineno"> 17 </span>import Reanimate.Svg.Constructors
|
||||
<span class="lineno"> 18 </span>import Reanimate.Svg.LineCommand
|
||||
<span class="lineno"> 19 </span>import Reanimate.Svg.BoundingBox
|
||||
<span class="lineno"> 20 </span>import Reanimate.Svg.Unuse
|
||||
<span class="lineno"> 21 </span>import qualified Reanimate.Transform as Transform
|
||||
<span class="lineno"> 22 </span>
|
||||
<span class="lineno"> 23 </span>-- | Remove transformations (such as translations, rotations, scaling)
|
||||
<span class="lineno"> 24 </span>-- and apply them directly to the SVG nodes. Note, this function
|
||||
<span class="lineno"> 25 </span>-- may convert nodes (such as Circle or Rect) to paths. Also note
|
||||
<span class="lineno"> 26 </span>-- that /does/ change how the SVG is rendered. Particularly, stroke
|
||||
<span class="lineno"> 27 </span>-- width is affected by directly applying scaling.
|
||||
<span class="lineno"> 28 </span>--
|
||||
<span class="lineno"> 29 </span>-- @lowerTransformations (scale 2 (mkCircle 1)) = mkCircle 2@
|
||||
<span class="lineno"> 30 </span>lowerTransformations :: Tree -> Tree
|
||||
<span class="lineno"> 31 </span><span class="decl"><span class="istickedoff">lowerTransformations = worker <span class="nottickedoff">False</span> Transform.identity</span>
|
||||
<span class="lineno"> 32 </span><span class="spaces"> </span><span class="istickedoff">where</span>
|
||||
<span class="lineno"> 33 </span><span class="spaces"> </span><span class="istickedoff">updLineCmd m cmd =</span>
|
||||
<span class="lineno"> 34 </span><span class="spaces"> </span><span class="istickedoff">case cmd of</span>
|
||||
<span class="lineno"> 35 </span><span class="spaces"> </span><span class="istickedoff">LineMove p -> LineMove $ Transform.transformPoint m p</span>
|
||||
<span class="lineno"> 36 </span><span class="spaces"> </span><span class="istickedoff">-- LineDraw p -> LineDraw $ Transform.transformPoint m p</span>
|
||||
<span class="lineno"> 37 </span><span class="spaces"> </span><span class="istickedoff">LineBezier ps -> LineBezier $ map (Transform.transformPoint m) ps</span>
|
||||
<span class="lineno"> 38 </span><span class="spaces"> </span><span class="istickedoff">LineEnd p -> LineEnd $ <span class="nottickedoff">Transform.transformPoint m p</span></span>
|
||||
<span class="lineno"> 39 </span><span class="spaces"> </span><span class="istickedoff">updPath m = lineToPath . map (updLineCmd m) . toLineCommands</span>
|
||||
<span class="lineno"> 40 </span><span class="spaces"> </span><span class="istickedoff"><span class="nottickedoff">updPoint m (Num a,Num b) =</span></span>
|
||||
<span class="lineno"> 41 </span><span class="spaces"> </span><span class="istickedoff"><span class="nottickedoff">case Transform.transformPoint m (V2 a b) of</span></span>
|
||||
<span class="lineno"> 42 </span><span class="spaces"> </span><span class="istickedoff"><span class="nottickedoff">V2 x y -> (Num x, Num y)</span></span>
|
||||
<span class="lineno"> 43 </span><span class="spaces"> </span><span class="istickedoff"><span class="nottickedoff">updPoint _ other = other</span> -- XXX: Can we do better here?</span>
|
||||
<span class="lineno"> 44 </span><span class="spaces"> </span><span class="istickedoff">worker hasPathified m t =</span>
|
||||
<span class="lineno"> 45 </span><span class="spaces"> </span><span class="istickedoff">let m' = m * Transform.mkMatrix (t^.transform) in</span>
|
||||
<span class="lineno"> 46 </span><span class="spaces"> </span><span class="istickedoff">case t of</span>
|
||||
<span class="lineno"> 47 </span><span class="spaces"> </span><span class="istickedoff">PathTree path -> PathTree $</span>
|
||||
<span class="lineno"> 48 </span><span class="spaces"> </span><span class="istickedoff">path & pathDefinition %~ updPath m'</span>
|
||||
<span class="lineno"> 49 </span><span class="spaces"> </span><span class="istickedoff">& transform .~ Nothing</span>
|
||||
<span class="lineno"> 50 </span><span class="spaces"> </span><span class="istickedoff">GroupTree g -> <span class="nottickedoff">GroupTree $</span></span>
|
||||
<span class="lineno"> 51 </span><span class="spaces"> </span><span class="istickedoff"><span class="nottickedoff">g & groupChildren %~ map (worker hasPathified m')</span></span>
|
||||
<span class="lineno"> 52 </span><span class="spaces"> </span><span class="istickedoff"><span class="nottickedoff">& transform .~ Nothing</span></span>
|
||||
<span class="lineno"> 53 </span><span class="spaces"> </span><span class="istickedoff">LineTree line -></span>
|
||||
<span class="lineno"> 54 </span><span class="spaces"> </span><span class="istickedoff"><span class="nottickedoff">LineTree $</span></span>
|
||||
<span class="lineno"> 55 </span><span class="spaces"> </span><span class="istickedoff"><span class="nottickedoff">line & linePoint1 %~ updPoint m</span></span>
|
||||
<span class="lineno"> 56 </span><span class="spaces"> </span><span class="istickedoff"><span class="nottickedoff">& linePoint2 %~ updPoint m</span></span>
|
||||
<span class="lineno"> 57 </span><span class="spaces"> </span><span class="istickedoff">ClipPathTree{} -> <span class="nottickedoff">t</span></span>
|
||||
<span class="lineno"> 58 </span><span class="spaces"> </span><span class="istickedoff">-- If we encounter an unknown node and we've already tried to convert</span>
|
||||
<span class="lineno"> 59 </span><span class="spaces"> </span><span class="istickedoff">-- to paths, give up and insert an explicit transformation.</span>
|
||||
<span class="lineno"> 60 </span><span class="spaces"> </span><span class="istickedoff">_ | <span class="nottickedoff">hasPathified</span> -></span>
|
||||
<span class="lineno"> 61 </span><span class="spaces"> </span><span class="istickedoff"><span class="nottickedoff">mkGroup [t] & transform ?~ [ Transform.toTransformation m ]</span></span>
|
||||
<span class="lineno"> 62 </span><span class="spaces"> </span><span class="istickedoff">-- If we haven't tried to pathify, run pathify only once.</span>
|
||||
<span class="lineno"> 63 </span><span class="spaces"> </span><span class="istickedoff">_ -> <span class="nottickedoff">worker True m (pathify t)</span></span></span>
|
||||
<span class="lineno"> 64 </span>
|
||||
<span class="lineno"> 65 </span>-- | Remove all @id@ attributes.
|
||||
<span class="lineno"> 66 </span>lowerIds :: Tree -> Tree
|
||||
<span class="lineno"> 67 </span><span class="decl"><span class="nottickedoff">lowerIds = mapTree worker</span>
|
||||
<span class="lineno"> 68 </span><span class="spaces"> </span><span class="nottickedoff">where</span>
|
||||
<span class="lineno"> 69 </span><span class="spaces"> </span><span class="nottickedoff">worker t@GroupTree{} = t & attrId .~ Nothing</span>
|
||||
<span class="lineno"> 70 </span><span class="spaces"> </span><span class="nottickedoff">worker t@PathTree{} = t & attrId .~ Nothing</span>
|
||||
<span class="lineno"> 71 </span><span class="spaces"> </span><span class="nottickedoff">worker t = t</span></span>
|
||||
<span class="lineno"> 72 </span>
|
||||
<span class="lineno"> 73 </span>-- | Optimize SVG tree without affecting how it is rendered.
|
||||
<span class="lineno"> 74 </span>simplify :: Tree -> Tree
|
||||
<span class="lineno"> 75 </span><span class="decl"><span class="istickedoff">simplify root =</span>
|
||||
<span class="lineno"> 76 </span><span class="spaces"> </span><span class="istickedoff">case worker root of</span>
|
||||
<span class="lineno"> 77 </span><span class="spaces"> </span><span class="istickedoff">[] -> <span class="nottickedoff">None</span></span>
|
||||
<span class="lineno"> 78 </span><span class="spaces"> </span><span class="istickedoff">[x] -> x</span>
|
||||
<span class="lineno"> 79 </span><span class="spaces"> </span><span class="istickedoff">xs -> <span class="nottickedoff">mkGroup xs</span></span>
|
||||
<span class="lineno"> 80 </span><span class="spaces"> </span><span class="istickedoff">where</span>
|
||||
<span class="lineno"> 81 </span><span class="spaces"> </span><span class="istickedoff">worker None = <span class="nottickedoff">[]</span></span>
|
||||
<span class="lineno"> 82 </span><span class="spaces"> </span><span class="istickedoff">worker (DefinitionTree d) =</span>
|
||||
<span class="lineno"> 83 </span><span class="spaces"> </span><span class="istickedoff"><span class="nottickedoff">concatMap dropNulls</span></span>
|
||||
<span class="lineno"> 84 </span><span class="spaces"> </span><span class="istickedoff"><span class="nottickedoff">[DefinitionTree $ d & groupChildren %~ concatMap worker]</span></span>
|
||||
<span class="lineno"> 85 </span><span class="spaces"> </span><span class="istickedoff">worker (GroupTree g)</span>
|
||||
<span class="lineno"> 86 </span><span class="spaces"> </span><span class="istickedoff">| <span class="nottickedoff">g ^. drawAttributes == defaultSvg</span> =</span>
|
||||
<span class="lineno"> 87 </span><span class="spaces"> </span><span class="istickedoff"><span class="nottickedoff">concatMap dropNulls $</span></span>
|
||||
<span class="lineno"> 88 </span><span class="spaces"> </span><span class="istickedoff"><span class="nottickedoff">concatMap worker (g^.groupChildren)</span></span>
|
||||
<span class="lineno"> 89 </span><span class="spaces"> </span><span class="istickedoff">| <span class="nottickedoff">otherwise</span> =</span>
|
||||
<span class="lineno"> 90 </span><span class="spaces"> </span><span class="istickedoff"><span class="nottickedoff">dropNulls $</span></span>
|
||||
<span class="lineno"> 91 </span><span class="spaces"> </span><span class="istickedoff"><span class="nottickedoff">GroupTree $ g & groupChildren %~ concatMap worker</span></span>
|
||||
<span class="lineno"> 92 </span><span class="spaces"> </span><span class="istickedoff">worker t = dropNulls t</span>
|
||||
<span class="lineno"> 93 </span><span class="spaces"></span><span class="istickedoff"></span>
|
||||
<span class="lineno"> 94 </span><span class="spaces"> </span><span class="istickedoff">dropNulls None = <span class="nottickedoff">[]</span></span>
|
||||
<span class="lineno"> 95 </span><span class="spaces"> </span><span class="istickedoff">dropNulls (DefinitionTree d)</span>
|
||||
<span class="lineno"> 96 </span><span class="spaces"> </span><span class="istickedoff">| <span class="nottickedoff">null (d^.groupChildren)</span> = <span class="nottickedoff">[]</span></span>
|
||||
<span class="lineno"> 97 </span><span class="spaces"> </span><span class="istickedoff">dropNulls (GroupTree g)</span>
|
||||
<span class="lineno"> 98 </span><span class="spaces"> </span><span class="istickedoff">| <span class="nottickedoff">null (g^.groupChildren)</span> = <span class="nottickedoff">[]</span></span>
|
||||
<span class="lineno"> 99 </span><span class="spaces"> </span><span class="istickedoff">dropNulls t = [t]</span></span>
|
||||
<span class="lineno"> 100 </span>
|
||||
<span class="lineno"> 101 </span>-- | Separate grouped items. This is required by clip nodes.
|
||||
<span class="lineno"> 102 </span>--
|
||||
<span class="lineno"> 103 </span>-- @removeGroups (withFillColor "blue" $ mkGroup [mkCircle 1, mkRect 1 1])
|
||||
<span class="lineno"> 104 </span>-- = [ withFillColor "blue" $ mkCircle 1
|
||||
<span class="lineno"> 105 </span>-- , withFillColor "blue" $ mkRect 1 1 ]@
|
||||
<span class="lineno"> 106 </span>removeGroups :: Tree -> [Tree]
|
||||
<span class="lineno"> 107 </span><span class="decl"><span class="nottickedoff">removeGroups = worker defaultSvg</span>
|
||||
<span class="lineno"> 108 </span><span class="spaces"> </span><span class="nottickedoff">where</span>
|
||||
<span class="lineno"> 109 </span><span class="spaces"> </span><span class="nottickedoff">worker _attr None = []</span>
|
||||
<span class="lineno"> 110 </span><span class="spaces"> </span><span class="nottickedoff">worker _attr (DefinitionTree d) =</span>
|
||||
<span class="lineno"> 111 </span><span class="spaces"> </span><span class="nottickedoff">concatMap dropNulls</span>
|
||||
<span class="lineno"> 112 </span><span class="spaces"> </span><span class="nottickedoff">[DefinitionTree $ d & groupChildren %~ concatMap (worker defaultSvg)]</span>
|
||||
<span class="lineno"> 113 </span><span class="spaces"> </span><span class="nottickedoff">worker attr (GroupTree g)</span>
|
||||
<span class="lineno"> 114 </span><span class="spaces"> </span><span class="nottickedoff">| g ^. drawAttributes == defaultSvg =</span>
|
||||
<span class="lineno"> 115 </span><span class="spaces"> </span><span class="nottickedoff">concatMap dropNulls $</span>
|
||||
<span class="lineno"> 116 </span><span class="spaces"> </span><span class="nottickedoff">concatMap (worker attr) (g^.groupChildren)</span>
|
||||
<span class="lineno"> 117 </span><span class="spaces"> </span><span class="nottickedoff">| otherwise =</span>
|
||||
<span class="lineno"> 118 </span><span class="spaces"> </span><span class="nottickedoff">concatMap (worker (attr <> g ^. drawAttributes)) (g^.groupChildren)</span>
|
||||
<span class="lineno"> 119 </span><span class="spaces"> </span><span class="nottickedoff">worker attr t = dropNulls (t & drawAttributes .~ attr)</span>
|
||||
<span class="lineno"> 120 </span><span class="spaces"></span><span class="nottickedoff"></span>
|
||||
<span class="lineno"> 121 </span><span class="spaces"> </span><span class="nottickedoff">dropNulls None = []</span>
|
||||
<span class="lineno"> 122 </span><span class="spaces"> </span><span class="nottickedoff">dropNulls (DefinitionTree d)</span>
|
||||
<span class="lineno"> 123 </span><span class="spaces"> </span><span class="nottickedoff">| null (d^.groupChildren) = []</span>
|
||||
<span class="lineno"> 124 </span><span class="spaces"> </span><span class="nottickedoff">dropNulls (GroupTree g)</span>
|
||||
<span class="lineno"> 125 </span><span class="spaces"> </span><span class="nottickedoff">| null (g^.groupChildren) = []</span>
|
||||
<span class="lineno"> 126 </span><span class="spaces"> </span><span class="nottickedoff">dropNulls t = [t]</span></span>
|
||||
<span class="lineno"> 127 </span>
|
||||
<span class="lineno"> 128 </span>-- | Extract all path commands from a node (and its children) and concatenate them.
|
||||
<span class="lineno"> 129 </span>extractPath :: Tree -> [PathCommand]
|
||||
<span class="lineno"> 130 </span><span class="decl"><span class="istickedoff">extractPath = worker . simplify . lowerTransformations . pathify</span>
|
||||
<span class="lineno"> 131 </span><span class="spaces"> </span><span class="istickedoff">where</span>
|
||||
<span class="lineno"> 132 </span><span class="spaces"> </span><span class="istickedoff">worker (GroupTree g) = <span class="nottickedoff">concatMap worker (g^.groupChildren)</span></span>
|
||||
<span class="lineno"> 133 </span><span class="spaces"> </span><span class="istickedoff">worker (PathTree p) = p^.pathDefinition</span>
|
||||
<span class="lineno"> 134 </span><span class="spaces"> </span><span class="istickedoff">worker _ = <span class="nottickedoff">[]</span></span></span>
|
||||
<span class="lineno"> 135 </span>
|
||||
<span class="lineno"> 136 </span>withSubglyphs :: [Int] -> (Tree -> Tree) -> Tree -> Tree
|
||||
<span class="lineno"> 137 </span><span class="decl"><span class="nottickedoff">withSubglyphs target fn = \t -> evalState (worker t) 0</span>
|
||||
<span class="lineno"> 138 </span><span class="spaces"> </span><span class="nottickedoff">where</span>
|
||||
<span class="lineno"> 139 </span><span class="spaces"> </span><span class="nottickedoff">worker :: Tree -> State Int Tree</span>
|
||||
<span class="lineno"> 140 </span><span class="spaces"> </span><span class="nottickedoff">worker t =</span>
|
||||
<span class="lineno"> 141 </span><span class="spaces"> </span><span class="nottickedoff">case t of</span>
|
||||
<span class="lineno"> 142 </span><span class="spaces"> </span><span class="nottickedoff">GroupTree g -> do</span>
|
||||
<span class="lineno"> 143 </span><span class="spaces"> </span><span class="nottickedoff">cs <- mapM worker (g ^. groupChildren)</span>
|
||||
<span class="lineno"> 144 </span><span class="spaces"> </span><span class="nottickedoff">return $ GroupTree $ g & groupChildren .~ cs</span>
|
||||
<span class="lineno"> 145 </span><span class="spaces"> </span><span class="nottickedoff">PathTree{} -> handleGlyph t</span>
|
||||
<span class="lineno"> 146 </span><span class="spaces"> </span><span class="nottickedoff">CircleTree{} -> handleGlyph t</span>
|
||||
<span class="lineno"> 147 </span><span class="spaces"> </span><span class="nottickedoff">PolyLineTree{} -> handleGlyph t</span>
|
||||
<span class="lineno"> 148 </span><span class="spaces"> </span><span class="nottickedoff">PolygonTree{} -> handleGlyph t</span>
|
||||
<span class="lineno"> 149 </span><span class="spaces"> </span><span class="nottickedoff">EllipseTree{} -> handleGlyph t</span>
|
||||
<span class="lineno"> 150 </span><span class="spaces"> </span><span class="nottickedoff">LineTree{} -> handleGlyph t</span>
|
||||
<span class="lineno"> 151 </span><span class="spaces"> </span><span class="nottickedoff">RectangleTree{} -> handleGlyph t</span>
|
||||
<span class="lineno"> 152 </span><span class="spaces"> </span><span class="nottickedoff">_ -> return t</span>
|
||||
<span class="lineno"> 153 </span><span class="spaces"> </span><span class="nottickedoff">handleGlyph :: Tree -> State Int Tree</span>
|
||||
<span class="lineno"> 154 </span><span class="spaces"> </span><span class="nottickedoff">handleGlyph svg = do</span>
|
||||
<span class="lineno"> 155 </span><span class="spaces"> </span><span class="nottickedoff">n <- get <* modify (+1)</span>
|
||||
<span class="lineno"> 156 </span><span class="spaces"> </span><span class="nottickedoff">if n `elem` target</span>
|
||||
<span class="lineno"> 157 </span><span class="spaces"> </span><span class="nottickedoff">then return $ fn svg</span>
|
||||
<span class="lineno"> 158 </span><span class="spaces"> </span><span class="nottickedoff">else return svg</span></span>
|
||||
<span class="lineno"> 159 </span>
|
||||
<span class="lineno"> 160 </span>splitGlyphs :: [Int] -> Tree -> (Tree, Tree)
|
||||
<span class="lineno"> 161 </span><span class="decl"><span class="nottickedoff">splitGlyphs target = \t -></span>
|
||||
<span class="lineno"> 162 </span><span class="spaces"> </span><span class="nottickedoff">let (_, l, r) = execState (worker id t) (0, [], [])</span>
|
||||
<span class="lineno"> 163 </span><span class="spaces"> </span><span class="nottickedoff">in (mkGroup l, mkGroup r)</span>
|
||||
<span class="lineno"> 164 </span><span class="spaces"> </span><span class="nottickedoff">where</span>
|
||||
<span class="lineno"> 165 </span><span class="spaces"> </span><span class="nottickedoff">handleGlyph :: Tree -> State (Int, [Tree], [Tree]) ()</span>
|
||||
<span class="lineno"> 166 </span><span class="spaces"> </span><span class="nottickedoff">handleGlyph t = do</span>
|
||||
<span class="lineno"> 167 </span><span class="spaces"> </span><span class="nottickedoff">(n, l, r) <- get</span>
|
||||
<span class="lineno"> 168 </span><span class="spaces"> </span><span class="nottickedoff">if n `elem` target</span>
|
||||
<span class="lineno"> 169 </span><span class="spaces"> </span><span class="nottickedoff">then put (n+1, l, t:r)</span>
|
||||
<span class="lineno"> 170 </span><span class="spaces"> </span><span class="nottickedoff">else put (n+1, t:l, r)</span>
|
||||
<span class="lineno"> 171 </span><span class="spaces"> </span><span class="nottickedoff">worker :: (Tree -> Tree) -> Tree -> State (Int, [Tree], [Tree]) ()</span>
|
||||
<span class="lineno"> 172 </span><span class="spaces"> </span><span class="nottickedoff">worker acc t =</span>
|
||||
<span class="lineno"> 173 </span><span class="spaces"> </span><span class="nottickedoff">case t of</span>
|
||||
<span class="lineno"> 174 </span><span class="spaces"> </span><span class="nottickedoff">GroupTree g -> do</span>
|
||||
<span class="lineno"> 175 </span><span class="spaces"> </span><span class="nottickedoff">let acc' sub = acc (GroupTree $ g & groupChildren .~ [sub])</span>
|
||||
<span class="lineno"> 176 </span><span class="spaces"> </span><span class="nottickedoff">mapM_ (worker acc') (g ^. groupChildren)</span>
|
||||
<span class="lineno"> 177 </span><span class="spaces"> </span><span class="nottickedoff">PathTree{} -> handleGlyph $ acc t</span>
|
||||
<span class="lineno"> 178 </span><span class="spaces"> </span><span class="nottickedoff">CircleTree{} -> handleGlyph $ acc t</span>
|
||||
<span class="lineno"> 179 </span><span class="spaces"> </span><span class="nottickedoff">PolyLineTree{} -> handleGlyph $ acc t</span>
|
||||
<span class="lineno"> 180 </span><span class="spaces"> </span><span class="nottickedoff">PolygonTree{} -> handleGlyph $ acc t</span>
|
||||
<span class="lineno"> 181 </span><span class="spaces"> </span><span class="nottickedoff">EllipseTree{} -> handleGlyph $ acc t</span>
|
||||
<span class="lineno"> 182 </span><span class="spaces"> </span><span class="nottickedoff">LineTree{} -> handleGlyph $ acc t</span>
|
||||
<span class="lineno"> 183 </span><span class="spaces"> </span><span class="nottickedoff">RectangleTree{} -> handleGlyph $ acc t</span>
|
||||
<span class="lineno"> 184 </span><span class="spaces"> </span><span class="nottickedoff">DefinitionTree{} -> return ()</span>
|
||||
<span class="lineno"> 185 </span><span class="spaces"> </span><span class="nottickedoff">_ -></span>
|
||||
<span class="lineno"> 186 </span><span class="spaces"> </span><span class="nottickedoff">modify $ \(n, l, r) -> (n, acc t:l, r)</span></span>
|
||||
<span class="lineno"> 187 </span>{-
|
||||
<span class="lineno"> 188 </span><g transform="translate(10,10)">
|
||||
<span class="lineno"> 189 </span> <g transform="scale(2)">
|
||||
<span class="lineno"> 190 </span> <circle/>
|
||||
<span class="lineno"> 191 </span> </g>
|
||||
<span class="lineno"> 192 </span> <g transform="scale(0.5)">
|
||||
<span class="lineno"> 193 </span> <rect/>
|
||||
<span class="lineno"> 194 </span> </g>
|
||||
<span class="lineno"> 195 </span></g>
|
||||
<span class="lineno"> 196 </span>
|
||||
<span class="lineno"> 197 </span>[ (\svg -> <g transform="translate(10,10)"><g transform="scale(2)">svg</g></g>, <circle/>)
|
||||
<span class="lineno"> 198 </span>, (\svg -> <g transform="translate(10,10)"><g transform="scale(0.5)">svg</g></g>, <rect/>)]
|
||||
<span class="lineno"> 199 </span>-}
|
||||
<span class="lineno"> 200 </span>svgGlyphs :: Tree -> [(Tree -> Tree, DrawAttributes, Tree)]
|
||||
<span class="lineno"> 201 </span><span class="decl"><span class="istickedoff">svgGlyphs = worker <span class="nottickedoff">id</span> defaultSvg</span>
|
||||
<span class="lineno"> 202 </span><span class="spaces"> </span><span class="istickedoff">where</span>
|
||||
<span class="lineno"> 203 </span><span class="spaces"> </span><span class="istickedoff">worker acc attr =</span>
|
||||
<span class="lineno"> 204 </span><span class="spaces"> </span><span class="istickedoff">\case</span>
|
||||
<span class="lineno"> 205 </span><span class="spaces"> </span><span class="istickedoff">None -> <span class="nottickedoff">[]</span></span>
|
||||
<span class="lineno"> 206 </span><span class="spaces"> </span><span class="istickedoff">GroupTree g -></span>
|
||||
<span class="lineno"> 207 </span><span class="spaces"> </span><span class="istickedoff"><span class="nottickedoff">let acc' sub = acc (GroupTree $ g & groupChildren .~ [sub])</span></span>
|
||||
<span class="lineno"> 208 </span><span class="spaces"> </span><span class="istickedoff"><span class="nottickedoff">attr' = (g^.drawAttributes) `mappend` attr</span></span>
|
||||
<span class="lineno"> 209 </span><span class="spaces"> </span><span class="istickedoff"><span class="nottickedoff">in concatMap (worker acc' attr') (g ^. groupChildren)</span></span>
|
||||
<span class="lineno"> 210 </span><span class="spaces"> </span><span class="istickedoff">t -> [(<span class="nottickedoff">acc</span>, (t^.drawAttributes) `mappend` attr, t)]</span></span>
|
||||
<span class="lineno"> 211 </span>
|
||||
<span class="lineno"> 212 </span>{-| Convert primitive SVG shapes (like those created by 'mkCircle', 'mkRect', 'mkLine' or
|
||||
<span class="lineno"> 213 </span> 'mkEllipse') into SVG path. This can be useful for creating animations of these shapes being
|
||||
<span class="lineno"> 214 </span> drawn progressively with 'partialSvg'.
|
||||
<span class="lineno"> 215 </span>
|
||||
<span class="lineno"> 216 </span> Example:
|
||||
<span class="lineno"> 217 </span>
|
||||
<span class="lineno"> 218 </span> > pathifyExample :: Animation
|
||||
<span class="lineno"> 219 </span> > pathifyExample = animate $ \t -> gridLayout
|
||||
<span class="lineno"> 220 </span> > [ [ partialSvg t $ pathify $ mkCircle 1
|
||||
<span class="lineno"> 221 </span> > , partialSvg t $ pathify $ mkRect 2 2
|
||||
<span class="lineno"> 222 </span> > ]
|
||||
<span class="lineno"> 223 </span> > , [ partialSvg t $ pathify $ mkEllipse 1 0.5
|
||||
<span class="lineno"> 224 </span> > , partialSvg t $ pathify $ mkLine (-1, -1) (1, 1)
|
||||
<span class="lineno"> 225 </span> > ]
|
||||
<span class="lineno"> 226 </span> > ]
|
||||
<span class="lineno"> 227 </span>
|
||||
<span class="lineno"> 228 </span> <<docs/gifs/doc_pathify.gif>>
|
||||
<span class="lineno"> 229 </span> -}
|
||||
<span class="lineno"> 230 </span>pathify :: Tree -> Tree
|
||||
<span class="lineno"> 231 </span><span class="decl"><span class="istickedoff">pathify = mapTree worker</span>
|
||||
<span class="lineno"> 232 </span><span class="spaces"> </span><span class="istickedoff">where</span>
|
||||
<span class="lineno"> 233 </span><span class="spaces"> </span><span class="istickedoff">worker =</span>
|
||||
<span class="lineno"> 234 </span><span class="spaces"> </span><span class="istickedoff">\case</span>
|
||||
<span class="lineno"> 235 </span><span class="spaces"> </span><span class="istickedoff">RectangleTree rect | Just (x,y,w,h) <- unpackRect rect -></span>
|
||||
<span class="lineno"> 236 </span><span class="spaces"> </span><span class="istickedoff">PathTree $ defaultSvg</span>
|
||||
<span class="lineno"> 237 </span><span class="spaces"> </span><span class="istickedoff">& drawAttributes .~ rect ^. drawAttributes</span>
|
||||
<span class="lineno"> 238 </span><span class="spaces"> </span><span class="istickedoff">& strokeLineCap .~ pure CapSquare</span>
|
||||
<span class="lineno"> 239 </span><span class="spaces"> </span><span class="istickedoff">& pathDefinition .~</span>
|
||||
<span class="lineno"> 240 </span><span class="spaces"> </span><span class="istickedoff">[MoveTo OriginAbsolute [V2 x y]</span>
|
||||
<span class="lineno"> 241 </span><span class="spaces"> </span><span class="istickedoff">,HorizontalTo OriginRelative [w]</span>
|
||||
<span class="lineno"> 242 </span><span class="spaces"> </span><span class="istickedoff">,VerticalTo OriginRelative [h]</span>
|
||||
<span class="lineno"> 243 </span><span class="spaces"> </span><span class="istickedoff">,HorizontalTo OriginRelative [-w]</span>
|
||||
<span class="lineno"> 244 </span><span class="spaces"> </span><span class="istickedoff">,EndPath ]</span>
|
||||
<span class="lineno"> 245 </span><span class="spaces"> </span><span class="istickedoff">LineTree line | Just (x1,y1, x2, y2) <- unpackLine line -></span>
|
||||
<span class="lineno"> 246 </span><span class="spaces"> </span><span class="istickedoff">PathTree $ defaultSvg</span>
|
||||
<span class="lineno"> 247 </span><span class="spaces"> </span><span class="istickedoff">& drawAttributes .~ line ^. drawAttributes</span>
|
||||
<span class="lineno"> 248 </span><span class="spaces"> </span><span class="istickedoff">& pathDefinition .~</span>
|
||||
<span class="lineno"> 249 </span><span class="spaces"> </span><span class="istickedoff">[MoveTo OriginAbsolute [V2 x1 y1]</span>
|
||||
<span class="lineno"> 250 </span><span class="spaces"> </span><span class="istickedoff">,LineTo OriginAbsolute [V2 x2 y2] ]</span>
|
||||
<span class="lineno"> 251 </span><span class="spaces"> </span><span class="istickedoff">CircleTree circ | Just (x, y, r) <- unpackCircle circ -></span>
|
||||
<span class="lineno"> 252 </span><span class="spaces"> </span><span class="istickedoff">PathTree $ defaultSvg</span>
|
||||
<span class="lineno"> 253 </span><span class="spaces"> </span><span class="istickedoff">& drawAttributes .~ circ ^. drawAttributes</span>
|
||||
<span class="lineno"> 254 </span><span class="spaces"> </span><span class="istickedoff">& pathDefinition .~</span>
|
||||
<span class="lineno"> 255 </span><span class="spaces"> </span><span class="istickedoff">[MoveTo OriginAbsolute [V2 (x-r) y]</span>
|
||||
<span class="lineno"> 256 </span><span class="spaces"> </span><span class="istickedoff">,EllipticalArc OriginRelative [(r, r, 0,True,False,V2 (r*2) 0)</span>
|
||||
<span class="lineno"> 257 </span><span class="spaces"> </span><span class="istickedoff">,(r, r, 0,True,False,V2 (-r*2) 0)]]</span>
|
||||
<span class="lineno"> 258 </span><span class="spaces"> </span><span class="istickedoff">PolyLineTree pl -></span>
|
||||
<span class="lineno"> 259 </span><span class="spaces"> </span><span class="istickedoff"><span class="nottickedoff">let points = pl ^. polyLinePoints</span></span>
|
||||
<span class="lineno"> 260 </span><span class="spaces"> </span><span class="istickedoff"><span class="nottickedoff">in PathTree $ defaultSvg</span></span>
|
||||
<span class="lineno"> 261 </span><span class="spaces"> </span><span class="istickedoff"><span class="nottickedoff">& drawAttributes .~ pl ^. drawAttributes</span></span>
|
||||
<span class="lineno"> 262 </span><span class="spaces"> </span><span class="istickedoff"><span class="nottickedoff">& pathDefinition .~ pointsToPathCommands points</span></span>
|
||||
<span class="lineno"> 263 </span><span class="spaces"> </span><span class="istickedoff">PolygonTree pg -></span>
|
||||
<span class="lineno"> 264 </span><span class="spaces"> </span><span class="istickedoff"><span class="nottickedoff">let points = pg ^. polygonPoints</span></span>
|
||||
<span class="lineno"> 265 </span><span class="spaces"> </span><span class="istickedoff"><span class="nottickedoff">in PathTree $ defaultSvg</span></span>
|
||||
<span class="lineno"> 266 </span><span class="spaces"> </span><span class="istickedoff"><span class="nottickedoff">& drawAttributes .~ pg ^. drawAttributes</span></span>
|
||||
<span class="lineno"> 267 </span><span class="spaces"> </span><span class="istickedoff"><span class="nottickedoff">-- Polygon automatically connects the last point to the first. For path we must do</span></span>
|
||||
<span class="lineno"> 268 </span><span class="spaces"> </span><span class="istickedoff"><span class="nottickedoff">-- it explicitly</span></span>
|
||||
<span class="lineno"> 269 </span><span class="spaces"> </span><span class="istickedoff"><span class="nottickedoff">& pathDefinition .~ (pointsToPathCommands points ++ [EndPath])</span></span>
|
||||
<span class="lineno"> 270 </span><span class="spaces"> </span><span class="istickedoff">EllipseTree elip | Just (cx,cy,rx,ry) <- unpackEllipse elip -></span>
|
||||
<span class="lineno"> 271 </span><span class="spaces"> </span><span class="istickedoff">PathTree $ defaultSvg</span>
|
||||
<span class="lineno"> 272 </span><span class="spaces"> </span><span class="istickedoff">& drawAttributes .~ elip ^. drawAttributes</span>
|
||||
<span class="lineno"> 273 </span><span class="spaces"> </span><span class="istickedoff">& pathDefinition .~</span>
|
||||
<span class="lineno"> 274 </span><span class="spaces"> </span><span class="istickedoff">[ MoveTo OriginAbsolute [V2 (cx-rx) cy]</span>
|
||||
<span class="lineno"> 275 </span><span class="spaces"> </span><span class="istickedoff">, EllipticalArc OriginRelative [(rx, ry, 0,True,False,V2 (rx*2) 0)</span>
|
||||
<span class="lineno"> 276 </span><span class="spaces"> </span><span class="istickedoff">,(rx, ry, 0,True,False,V2 (-rx*2) 0)]]</span>
|
||||
<span class="lineno"> 277 </span><span class="spaces"> </span><span class="istickedoff">t -> t</span>
|
||||
<span class="lineno"> 278 </span><span class="spaces"> </span><span class="istickedoff">unpackCircle circ = do</span>
|
||||
<span class="lineno"> 279 </span><span class="spaces"> </span><span class="istickedoff">let (x,y) = circ ^. circleCenter</span>
|
||||
<span class="lineno"> 280 </span><span class="spaces"> </span><span class="istickedoff">liftM3 (,,) (unpackNumber x) (unpackNumber y) (unpackNumber $ circ ^. circleRadius)</span>
|
||||
<span class="lineno"> 281 </span><span class="spaces"> </span><span class="istickedoff">unpackEllipse elip = do</span>
|
||||
<span class="lineno"> 282 </span><span class="spaces"> </span><span class="istickedoff">let (x,y) = elip ^. ellipseCenter</span>
|
||||
<span class="lineno"> 283 </span><span class="spaces"> </span><span class="istickedoff">liftM4 (,,,) (unpackNumber x) (unpackNumber y) (unpackNumber $ elip ^. ellipseXRadius)</span>
|
||||
<span class="lineno"> 284 </span><span class="spaces"> </span><span class="istickedoff">(unpackNumber $ elip ^. ellipseYRadius)</span>
|
||||
<span class="lineno"> 285 </span><span class="spaces"> </span><span class="istickedoff">unpackLine line = do</span>
|
||||
<span class="lineno"> 286 </span><span class="spaces"> </span><span class="istickedoff">let (x1,y1) = line ^. linePoint1</span>
|
||||
<span class="lineno"> 287 </span><span class="spaces"> </span><span class="istickedoff">(x2,y2) = line ^. linePoint2</span>
|
||||
<span class="lineno"> 288 </span><span class="spaces"> </span><span class="istickedoff">liftM4 (,,,) (unpackNumber x1) (unpackNumber y1) (unpackNumber x2) (unpackNumber y2)</span>
|
||||
<span class="lineno"> 289 </span><span class="spaces"> </span><span class="istickedoff">unpackRect rect = do</span>
|
||||
<span class="lineno"> 290 </span><span class="spaces"> </span><span class="istickedoff">let (x', y') = rect ^. rectUpperLeftCorner</span>
|
||||
<span class="lineno"> 291 </span><span class="spaces"> </span><span class="istickedoff">x <- unpackNumber x'</span>
|
||||
<span class="lineno"> 292 </span><span class="spaces"> </span><span class="istickedoff">y <- unpackNumber y'</span>
|
||||
<span class="lineno"> 293 </span><span class="spaces"> </span><span class="istickedoff">w <- unpackNumber =<< rect ^. rectWidth</span>
|
||||
<span class="lineno"> 294 </span><span class="spaces"> </span><span class="istickedoff">h <- unpackNumber =<< rect ^. rectHeight</span>
|
||||
<span class="lineno"> 295 </span><span class="spaces"> </span><span class="istickedoff">return (x,y,w,h)</span>
|
||||
<span class="lineno"> 296 </span><span class="spaces"> </span><span class="istickedoff"><span class="nottickedoff">pointsToPathCommands points = case points of</span></span>
|
||||
<span class="lineno"> 297 </span><span class="spaces"> </span><span class="istickedoff"><span class="nottickedoff">[] -> []</span></span>
|
||||
<span class="lineno"> 298 </span><span class="spaces"> </span><span class="istickedoff"><span class="nottickedoff">(p:ps) -> [ MoveTo OriginAbsolute [p]</span></span>
|
||||
<span class="lineno"> 299 </span><span class="spaces"> </span><span class="istickedoff"><span class="nottickedoff">, LineTo OriginAbsolute ps ]</span></span>
|
||||
<span class="lineno"> 300 </span><span class="spaces"> </span><span class="istickedoff">unpackNumber n =</span>
|
||||
<span class="lineno"> 301 </span><span class="spaces"> </span><span class="istickedoff">case toUserUnit <span class="nottickedoff">defaultDPI</span> n of</span>
|
||||
<span class="lineno"> 302 </span><span class="spaces"> </span><span class="istickedoff">Num d -> Just d</span>
|
||||
<span class="lineno"> 303 </span><span class="spaces"> </span><span class="istickedoff">_ -> <span class="nottickedoff">Nothing</span></span></span>
|
||||
<span class="lineno"> 304 </span>
|
||||
<span class="lineno"> 305 </span>mapSvgPaths :: ([PathCommand] -> [PathCommand]) -> SVG -> SVG
|
||||
<span class="lineno"> 306 </span><span class="decl"><span class="nottickedoff">mapSvgPaths fn = mapTree worker</span>
|
||||
<span class="lineno"> 307 </span><span class="spaces"> </span><span class="nottickedoff">where</span>
|
||||
<span class="lineno"> 308 </span><span class="spaces"> </span><span class="nottickedoff">worker =</span>
|
||||
<span class="lineno"> 309 </span><span class="spaces"> </span><span class="nottickedoff">\case</span>
|
||||
<span class="lineno"> 310 </span><span class="spaces"> </span><span class="nottickedoff">PathTree path -> PathTree $</span>
|
||||
<span class="lineno"> 311 </span><span class="spaces"> </span><span class="nottickedoff">path & pathDefinition %~ fn</span>
|
||||
<span class="lineno"> 312 </span><span class="spaces"> </span><span class="nottickedoff">t -> t</span></span>
|
||||
<span class="lineno"> 313 </span>
|
||||
<span class="lineno"> 314 </span>mapSvgLines :: ([LineCommand] -> [LineCommand]) -> SVG -> SVG
|
||||
<span class="lineno"> 315 </span><span class="decl"><span class="nottickedoff">mapSvgLines fn = mapSvgPaths (lineToPath . fn . toLineCommands)</span></span>
|
||||
<span class="lineno"> 316 </span>
|
||||
<span class="lineno"> 317 </span>-- Only maps points in paths
|
||||
<span class="lineno"> 318 </span>mapSvgPoints :: (RPoint -> RPoint) -> SVG -> SVG
|
||||
<span class="lineno"> 319 </span><span class="decl"><span class="nottickedoff">mapSvgPoints fn = mapSvgLines (map worker)</span>
|
||||
<span class="lineno"> 320 </span><span class="spaces"> </span><span class="nottickedoff">where</span>
|
||||
<span class="lineno"> 321 </span><span class="spaces"> </span><span class="nottickedoff">worker (LineMove p) = LineMove (fn p)</span>
|
||||
<span class="lineno"> 322 </span><span class="spaces"> </span><span class="nottickedoff">worker (LineBezier ps) = LineBezier (map fn ps)</span>
|
||||
<span class="lineno"> 323 </span><span class="spaces"> </span><span class="nottickedoff">worker (LineEnd p) = LineEnd (fn p)</span></span>
|
||||
<span class="lineno"> 324 </span>
|
||||
<span class="lineno"> 325 </span>svgPointsToRadians :: SVG -> SVG
|
||||
<span class="lineno"> 326 </span><span class="decl"><span class="nottickedoff">svgPointsToRadians = mapSvgPoints worker</span>
|
||||
<span class="lineno"> 2 </span>{-|
|
||||
<span class="lineno"> 3 </span>Copyright : Written by David Himmelstrup
|
||||
<span class="lineno"> 4 </span>License : Unlicense
|
||||
<span class="lineno"> 5 </span>Maintainer : lemmih@gmail.com
|
||||
<span class="lineno"> 6 </span>Stability : experimental
|
||||
<span class="lineno"> 7 </span>Portability : POSIX
|
||||
<span class="lineno"> 8 </span>-}
|
||||
<span class="lineno"> 9 </span>module Reanimate.Svg
|
||||
<span class="lineno"> 10 </span> ( module Reanimate.Svg
|
||||
<span class="lineno"> 11 </span> , module Reanimate.Svg.Constructors
|
||||
<span class="lineno"> 12 </span> , module Reanimate.Svg.LineCommand
|
||||
<span class="lineno"> 13 </span> , module Reanimate.Svg.BoundingBox
|
||||
<span class="lineno"> 14 </span> , module Reanimate.Svg.Unuse
|
||||
<span class="lineno"> 15 </span> ) where
|
||||
<span class="lineno"> 16 </span>
|
||||
<span class="lineno"> 17 </span>import Control.Lens ((%~), (&), (.~), (^.), (?~))
|
||||
<span class="lineno"> 18 </span>import Control.Monad.State
|
||||
<span class="lineno"> 19 </span>import Graphics.SvgTree hiding (height, line, path, use,
|
||||
<span class="lineno"> 20 </span> width)
|
||||
<span class="lineno"> 21 </span>import Linear.V2 hiding (angle)
|
||||
<span class="lineno"> 22 </span>import Reanimate.Constants
|
||||
<span class="lineno"> 23 </span>import Reanimate.Animation (SVG)
|
||||
<span class="lineno"> 24 </span>import Reanimate.Svg.Constructors
|
||||
<span class="lineno"> 25 </span>import Reanimate.Svg.LineCommand
|
||||
<span class="lineno"> 26 </span>import Reanimate.Svg.BoundingBox
|
||||
<span class="lineno"> 27 </span>import Reanimate.Svg.Unuse
|
||||
<span class="lineno"> 28 </span>import qualified Reanimate.Transform as Transform
|
||||
<span class="lineno"> 29 </span>
|
||||
<span class="lineno"> 30 </span>-- | Remove transformations (such as translations, rotations, scaling)
|
||||
<span class="lineno"> 31 </span>-- and apply them directly to the SVG nodes. Note, this function
|
||||
<span class="lineno"> 32 </span>-- may convert nodes (such as Circle or Rect) to paths. Also note
|
||||
<span class="lineno"> 33 </span>-- that /does/ change how the SVG is rendered. Particularly, stroke
|
||||
<span class="lineno"> 34 </span>-- width is affected by directly applying scaling.
|
||||
<span class="lineno"> 35 </span>--
|
||||
<span class="lineno"> 36 </span>-- @lowerTransformations (scale 2 (mkCircle 1)) = mkCircle 2@
|
||||
<span class="lineno"> 37 </span>lowerTransformations :: Tree -> Tree
|
||||
<span class="lineno"> 38 </span><span class="decl"><span class="istickedoff">lowerTransformations = worker <span class="nottickedoff">False</span> Transform.identity</span>
|
||||
<span class="lineno"> 39 </span><span class="spaces"> </span><span class="istickedoff">where</span>
|
||||
<span class="lineno"> 40 </span><span class="spaces"> </span><span class="istickedoff">updLineCmd m cmd =</span>
|
||||
<span class="lineno"> 41 </span><span class="spaces"> </span><span class="istickedoff">case cmd of</span>
|
||||
<span class="lineno"> 42 </span><span class="spaces"> </span><span class="istickedoff">LineMove p -> LineMove $ Transform.transformPoint m p</span>
|
||||
<span class="lineno"> 43 </span><span class="spaces"> </span><span class="istickedoff">-- LineDraw p -> LineDraw $ Transform.transformPoint m p</span>
|
||||
<span class="lineno"> 44 </span><span class="spaces"> </span><span class="istickedoff">LineBezier ps -> LineBezier $ map (Transform.transformPoint m) ps</span>
|
||||
<span class="lineno"> 45 </span><span class="spaces"> </span><span class="istickedoff">LineEnd p -> LineEnd $ <span class="nottickedoff">Transform.transformPoint m p</span></span>
|
||||
<span class="lineno"> 46 </span><span class="spaces"> </span><span class="istickedoff">updPath m = lineToPath . map (updLineCmd m) . toLineCommands</span>
|
||||
<span class="lineno"> 47 </span><span class="spaces"> </span><span class="istickedoff"><span class="nottickedoff">updPoint m (Num a,Num b) =</span></span>
|
||||
<span class="lineno"> 48 </span><span class="spaces"> </span><span class="istickedoff"><span class="nottickedoff">case Transform.transformPoint m (V2 a b) of</span></span>
|
||||
<span class="lineno"> 49 </span><span class="spaces"> </span><span class="istickedoff"><span class="nottickedoff">V2 x y -> (Num x, Num y)</span></span>
|
||||
<span class="lineno"> 50 </span><span class="spaces"> </span><span class="istickedoff"><span class="nottickedoff">updPoint _ other = other</span> -- XXX: Can we do better here?</span>
|
||||
<span class="lineno"> 51 </span><span class="spaces"> </span><span class="istickedoff">worker hasPathified m t =</span>
|
||||
<span class="lineno"> 52 </span><span class="spaces"> </span><span class="istickedoff">let m' = m * Transform.mkMatrix (t^.transform) in</span>
|
||||
<span class="lineno"> 53 </span><span class="spaces"> </span><span class="istickedoff">case t of</span>
|
||||
<span class="lineno"> 54 </span><span class="spaces"> </span><span class="istickedoff">PathTree path -> PathTree $</span>
|
||||
<span class="lineno"> 55 </span><span class="spaces"> </span><span class="istickedoff">path & pathDefinition %~ updPath m'</span>
|
||||
<span class="lineno"> 56 </span><span class="spaces"> </span><span class="istickedoff">& transform .~ Nothing</span>
|
||||
<span class="lineno"> 57 </span><span class="spaces"> </span><span class="istickedoff">GroupTree g -> <span class="nottickedoff">GroupTree $</span></span>
|
||||
<span class="lineno"> 58 </span><span class="spaces"> </span><span class="istickedoff"><span class="nottickedoff">g & groupChildren %~ map (worker hasPathified m')</span></span>
|
||||
<span class="lineno"> 59 </span><span class="spaces"> </span><span class="istickedoff"><span class="nottickedoff">& transform .~ Nothing</span></span>
|
||||
<span class="lineno"> 60 </span><span class="spaces"> </span><span class="istickedoff">LineTree line -></span>
|
||||
<span class="lineno"> 61 </span><span class="spaces"> </span><span class="istickedoff"><span class="nottickedoff">LineTree $</span></span>
|
||||
<span class="lineno"> 62 </span><span class="spaces"> </span><span class="istickedoff"><span class="nottickedoff">line & linePoint1 %~ updPoint m</span></span>
|
||||
<span class="lineno"> 63 </span><span class="spaces"> </span><span class="istickedoff"><span class="nottickedoff">& linePoint2 %~ updPoint m</span></span>
|
||||
<span class="lineno"> 64 </span><span class="spaces"> </span><span class="istickedoff">ClipPathTree{} -> <span class="nottickedoff">t</span></span>
|
||||
<span class="lineno"> 65 </span><span class="spaces"> </span><span class="istickedoff">-- If we encounter an unknown node and we've already tried to convert</span>
|
||||
<span class="lineno"> 66 </span><span class="spaces"> </span><span class="istickedoff">-- to paths, give up and insert an explicit transformation.</span>
|
||||
<span class="lineno"> 67 </span><span class="spaces"> </span><span class="istickedoff">_ | <span class="nottickedoff">hasPathified</span> -></span>
|
||||
<span class="lineno"> 68 </span><span class="spaces"> </span><span class="istickedoff"><span class="nottickedoff">mkGroup [t] & transform ?~ [ Transform.toTransformation m ]</span></span>
|
||||
<span class="lineno"> 69 </span><span class="spaces"> </span><span class="istickedoff">-- If we haven't tried to pathify, run pathify only once.</span>
|
||||
<span class="lineno"> 70 </span><span class="spaces"> </span><span class="istickedoff">_ -> <span class="nottickedoff">worker True m (pathify t)</span></span></span>
|
||||
<span class="lineno"> 71 </span>
|
||||
<span class="lineno"> 72 </span>-- | Remove all @id@ attributes.
|
||||
<span class="lineno"> 73 </span>lowerIds :: Tree -> Tree
|
||||
<span class="lineno"> 74 </span><span class="decl"><span class="nottickedoff">lowerIds = mapTree worker</span>
|
||||
<span class="lineno"> 75 </span><span class="spaces"> </span><span class="nottickedoff">where</span>
|
||||
<span class="lineno"> 76 </span><span class="spaces"> </span><span class="nottickedoff">worker t@GroupTree{} = t & attrId .~ Nothing</span>
|
||||
<span class="lineno"> 77 </span><span class="spaces"> </span><span class="nottickedoff">worker t@PathTree{} = t & attrId .~ Nothing</span>
|
||||
<span class="lineno"> 78 </span><span class="spaces"> </span><span class="nottickedoff">worker t = t</span></span>
|
||||
<span class="lineno"> 79 </span>
|
||||
<span class="lineno"> 80 </span>-- | Optimize SVG tree without affecting how it is rendered.
|
||||
<span class="lineno"> 81 </span>simplify :: Tree -> Tree
|
||||
<span class="lineno"> 82 </span><span class="decl"><span class="istickedoff">simplify root =</span>
|
||||
<span class="lineno"> 83 </span><span class="spaces"> </span><span class="istickedoff">case worker root of</span>
|
||||
<span class="lineno"> 84 </span><span class="spaces"> </span><span class="istickedoff">[] -> <span class="nottickedoff">None</span></span>
|
||||
<span class="lineno"> 85 </span><span class="spaces"> </span><span class="istickedoff">[x] -> x</span>
|
||||
<span class="lineno"> 86 </span><span class="spaces"> </span><span class="istickedoff">xs -> <span class="nottickedoff">mkGroup xs</span></span>
|
||||
<span class="lineno"> 87 </span><span class="spaces"> </span><span class="istickedoff">where</span>
|
||||
<span class="lineno"> 88 </span><span class="spaces"> </span><span class="istickedoff">worker None = <span class="nottickedoff">[]</span></span>
|
||||
<span class="lineno"> 89 </span><span class="spaces"> </span><span class="istickedoff">worker (DefinitionTree d) =</span>
|
||||
<span class="lineno"> 90 </span><span class="spaces"> </span><span class="istickedoff"><span class="nottickedoff">concatMap dropNulls</span></span>
|
||||
<span class="lineno"> 91 </span><span class="spaces"> </span><span class="istickedoff"><span class="nottickedoff">[DefinitionTree $ d & groupChildren %~ concatMap worker]</span></span>
|
||||
<span class="lineno"> 92 </span><span class="spaces"> </span><span class="istickedoff">worker (GroupTree g)</span>
|
||||
<span class="lineno"> 93 </span><span class="spaces"> </span><span class="istickedoff">| <span class="nottickedoff">g ^. drawAttributes == defaultSvg</span> =</span>
|
||||
<span class="lineno"> 94 </span><span class="spaces"> </span><span class="istickedoff"><span class="nottickedoff">concatMap dropNulls $</span></span>
|
||||
<span class="lineno"> 95 </span><span class="spaces"> </span><span class="istickedoff"><span class="nottickedoff">concatMap worker (g^.groupChildren)</span></span>
|
||||
<span class="lineno"> 96 </span><span class="spaces"> </span><span class="istickedoff">| <span class="nottickedoff">otherwise</span> =</span>
|
||||
<span class="lineno"> 97 </span><span class="spaces"> </span><span class="istickedoff"><span class="nottickedoff">dropNulls $</span></span>
|
||||
<span class="lineno"> 98 </span><span class="spaces"> </span><span class="istickedoff"><span class="nottickedoff">GroupTree $ g & groupChildren %~ concatMap worker</span></span>
|
||||
<span class="lineno"> 99 </span><span class="spaces"> </span><span class="istickedoff">worker t = dropNulls t</span>
|
||||
<span class="lineno"> 100 </span><span class="spaces"></span><span class="istickedoff"></span>
|
||||
<span class="lineno"> 101 </span><span class="spaces"> </span><span class="istickedoff">dropNulls None = <span class="nottickedoff">[]</span></span>
|
||||
<span class="lineno"> 102 </span><span class="spaces"> </span><span class="istickedoff">dropNulls (DefinitionTree d)</span>
|
||||
<span class="lineno"> 103 </span><span class="spaces"> </span><span class="istickedoff">| <span class="nottickedoff">null (d^.groupChildren)</span> = <span class="nottickedoff">[]</span></span>
|
||||
<span class="lineno"> 104 </span><span class="spaces"> </span><span class="istickedoff">dropNulls (GroupTree g)</span>
|
||||
<span class="lineno"> 105 </span><span class="spaces"> </span><span class="istickedoff">| <span class="nottickedoff">null (g^.groupChildren)</span> = <span class="nottickedoff">[]</span></span>
|
||||
<span class="lineno"> 106 </span><span class="spaces"> </span><span class="istickedoff">dropNulls t = [t]</span></span>
|
||||
<span class="lineno"> 107 </span>
|
||||
<span class="lineno"> 108 </span>-- | Separate grouped items. This is required by clip nodes.
|
||||
<span class="lineno"> 109 </span>--
|
||||
<span class="lineno"> 110 </span>-- @removeGroups (withFillColor "blue" $ mkGroup [mkCircle 1, mkRect 1 1])
|
||||
<span class="lineno"> 111 </span>-- = [ withFillColor "blue" $ mkCircle 1
|
||||
<span class="lineno"> 112 </span>-- , withFillColor "blue" $ mkRect 1 1 ]@
|
||||
<span class="lineno"> 113 </span>removeGroups :: Tree -> [Tree]
|
||||
<span class="lineno"> 114 </span><span class="decl"><span class="nottickedoff">removeGroups = worker defaultSvg</span>
|
||||
<span class="lineno"> 115 </span><span class="spaces"> </span><span class="nottickedoff">where</span>
|
||||
<span class="lineno"> 116 </span><span class="spaces"> </span><span class="nottickedoff">worker _attr None = []</span>
|
||||
<span class="lineno"> 117 </span><span class="spaces"> </span><span class="nottickedoff">worker _attr (DefinitionTree d) =</span>
|
||||
<span class="lineno"> 118 </span><span class="spaces"> </span><span class="nottickedoff">concatMap dropNulls</span>
|
||||
<span class="lineno"> 119 </span><span class="spaces"> </span><span class="nottickedoff">[DefinitionTree $ d & groupChildren %~ concatMap (worker defaultSvg)]</span>
|
||||
<span class="lineno"> 120 </span><span class="spaces"> </span><span class="nottickedoff">worker attr (GroupTree g)</span>
|
||||
<span class="lineno"> 121 </span><span class="spaces"> </span><span class="nottickedoff">| g ^. drawAttributes == defaultSvg =</span>
|
||||
<span class="lineno"> 122 </span><span class="spaces"> </span><span class="nottickedoff">concatMap dropNulls $</span>
|
||||
<span class="lineno"> 123 </span><span class="spaces"> </span><span class="nottickedoff">concatMap (worker attr) (g^.groupChildren)</span>
|
||||
<span class="lineno"> 124 </span><span class="spaces"> </span><span class="nottickedoff">| otherwise =</span>
|
||||
<span class="lineno"> 125 </span><span class="spaces"> </span><span class="nottickedoff">concatMap (worker (attr <> g ^. drawAttributes)) (g^.groupChildren)</span>
|
||||
<span class="lineno"> 126 </span><span class="spaces"> </span><span class="nottickedoff">worker attr t = dropNulls (t & drawAttributes .~ attr)</span>
|
||||
<span class="lineno"> 127 </span><span class="spaces"></span><span class="nottickedoff"></span>
|
||||
<span class="lineno"> 128 </span><span class="spaces"> </span><span class="nottickedoff">dropNulls None = []</span>
|
||||
<span class="lineno"> 129 </span><span class="spaces"> </span><span class="nottickedoff">dropNulls (DefinitionTree d)</span>
|
||||
<span class="lineno"> 130 </span><span class="spaces"> </span><span class="nottickedoff">| null (d^.groupChildren) = []</span>
|
||||
<span class="lineno"> 131 </span><span class="spaces"> </span><span class="nottickedoff">dropNulls (GroupTree g)</span>
|
||||
<span class="lineno"> 132 </span><span class="spaces"> </span><span class="nottickedoff">| null (g^.groupChildren) = []</span>
|
||||
<span class="lineno"> 133 </span><span class="spaces"> </span><span class="nottickedoff">dropNulls t = [t]</span></span>
|
||||
<span class="lineno"> 134 </span>
|
||||
<span class="lineno"> 135 </span>-- | Extract all path commands from a node (and its children) and concatenate them.
|
||||
<span class="lineno"> 136 </span>extractPath :: Tree -> [PathCommand]
|
||||
<span class="lineno"> 137 </span><span class="decl"><span class="istickedoff">extractPath = worker . simplify . lowerTransformations . pathify</span>
|
||||
<span class="lineno"> 138 </span><span class="spaces"> </span><span class="istickedoff">where</span>
|
||||
<span class="lineno"> 139 </span><span class="spaces"> </span><span class="istickedoff">worker (GroupTree g) = <span class="nottickedoff">concatMap worker (g^.groupChildren)</span></span>
|
||||
<span class="lineno"> 140 </span><span class="spaces"> </span><span class="istickedoff">worker (PathTree p) = p^.pathDefinition</span>
|
||||
<span class="lineno"> 141 </span><span class="spaces"> </span><span class="istickedoff">worker _ = <span class="nottickedoff">[]</span></span></span>
|
||||
<span class="lineno"> 142 </span>
|
||||
<span class="lineno"> 143 </span>withSubglyphs :: [Int] -> (Tree -> Tree) -> Tree -> Tree
|
||||
<span class="lineno"> 144 </span><span class="decl"><span class="nottickedoff">withSubglyphs target fn = \t -> evalState (worker t) 0</span>
|
||||
<span class="lineno"> 145 </span><span class="spaces"> </span><span class="nottickedoff">where</span>
|
||||
<span class="lineno"> 146 </span><span class="spaces"> </span><span class="nottickedoff">worker :: Tree -> State Int Tree</span>
|
||||
<span class="lineno"> 147 </span><span class="spaces"> </span><span class="nottickedoff">worker t =</span>
|
||||
<span class="lineno"> 148 </span><span class="spaces"> </span><span class="nottickedoff">case t of</span>
|
||||
<span class="lineno"> 149 </span><span class="spaces"> </span><span class="nottickedoff">GroupTree g -> do</span>
|
||||
<span class="lineno"> 150 </span><span class="spaces"> </span><span class="nottickedoff">cs <- mapM worker (g ^. groupChildren)</span>
|
||||
<span class="lineno"> 151 </span><span class="spaces"> </span><span class="nottickedoff">return $ GroupTree $ g & groupChildren .~ cs</span>
|
||||
<span class="lineno"> 152 </span><span class="spaces"> </span><span class="nottickedoff">PathTree{} -> handleGlyph t</span>
|
||||
<span class="lineno"> 153 </span><span class="spaces"> </span><span class="nottickedoff">CircleTree{} -> handleGlyph t</span>
|
||||
<span class="lineno"> 154 </span><span class="spaces"> </span><span class="nottickedoff">PolyLineTree{} -> handleGlyph t</span>
|
||||
<span class="lineno"> 155 </span><span class="spaces"> </span><span class="nottickedoff">PolygonTree{} -> handleGlyph t</span>
|
||||
<span class="lineno"> 156 </span><span class="spaces"> </span><span class="nottickedoff">EllipseTree{} -> handleGlyph t</span>
|
||||
<span class="lineno"> 157 </span><span class="spaces"> </span><span class="nottickedoff">LineTree{} -> handleGlyph t</span>
|
||||
<span class="lineno"> 158 </span><span class="spaces"> </span><span class="nottickedoff">RectangleTree{} -> handleGlyph t</span>
|
||||
<span class="lineno"> 159 </span><span class="spaces"> </span><span class="nottickedoff">_ -> return t</span>
|
||||
<span class="lineno"> 160 </span><span class="spaces"> </span><span class="nottickedoff">handleGlyph :: Tree -> State Int Tree</span>
|
||||
<span class="lineno"> 161 </span><span class="spaces"> </span><span class="nottickedoff">handleGlyph svg = do</span>
|
||||
<span class="lineno"> 162 </span><span class="spaces"> </span><span class="nottickedoff">n <- get <* modify (+1)</span>
|
||||
<span class="lineno"> 163 </span><span class="spaces"> </span><span class="nottickedoff">if n `elem` target</span>
|
||||
<span class="lineno"> 164 </span><span class="spaces"> </span><span class="nottickedoff">then return $ fn svg</span>
|
||||
<span class="lineno"> 165 </span><span class="spaces"> </span><span class="nottickedoff">else return svg</span></span>
|
||||
<span class="lineno"> 166 </span>
|
||||
<span class="lineno"> 167 </span>splitGlyphs :: [Int] -> Tree -> (Tree, Tree)
|
||||
<span class="lineno"> 168 </span><span class="decl"><span class="nottickedoff">splitGlyphs target = \t -></span>
|
||||
<span class="lineno"> 169 </span><span class="spaces"> </span><span class="nottickedoff">let (_, l, r) = execState (worker id t) (0, [], [])</span>
|
||||
<span class="lineno"> 170 </span><span class="spaces"> </span><span class="nottickedoff">in (mkGroup l, mkGroup r)</span>
|
||||
<span class="lineno"> 171 </span><span class="spaces"> </span><span class="nottickedoff">where</span>
|
||||
<span class="lineno"> 172 </span><span class="spaces"> </span><span class="nottickedoff">handleGlyph :: Tree -> State (Int, [Tree], [Tree]) ()</span>
|
||||
<span class="lineno"> 173 </span><span class="spaces"> </span><span class="nottickedoff">handleGlyph t = do</span>
|
||||
<span class="lineno"> 174 </span><span class="spaces"> </span><span class="nottickedoff">(n, l, r) <- get</span>
|
||||
<span class="lineno"> 175 </span><span class="spaces"> </span><span class="nottickedoff">if n `elem` target</span>
|
||||
<span class="lineno"> 176 </span><span class="spaces"> </span><span class="nottickedoff">then put (n+1, l, t:r)</span>
|
||||
<span class="lineno"> 177 </span><span class="spaces"> </span><span class="nottickedoff">else put (n+1, t:l, r)</span>
|
||||
<span class="lineno"> 178 </span><span class="spaces"> </span><span class="nottickedoff">worker :: (Tree -> Tree) -> Tree -> State (Int, [Tree], [Tree]) ()</span>
|
||||
<span class="lineno"> 179 </span><span class="spaces"> </span><span class="nottickedoff">worker acc t =</span>
|
||||
<span class="lineno"> 180 </span><span class="spaces"> </span><span class="nottickedoff">case t of</span>
|
||||
<span class="lineno"> 181 </span><span class="spaces"> </span><span class="nottickedoff">GroupTree g -> do</span>
|
||||
<span class="lineno"> 182 </span><span class="spaces"> </span><span class="nottickedoff">let acc' sub = acc (GroupTree $ g & groupChildren .~ [sub])</span>
|
||||
<span class="lineno"> 183 </span><span class="spaces"> </span><span class="nottickedoff">mapM_ (worker acc') (g ^. groupChildren)</span>
|
||||
<span class="lineno"> 184 </span><span class="spaces"> </span><span class="nottickedoff">PathTree{} -> handleGlyph $ acc t</span>
|
||||
<span class="lineno"> 185 </span><span class="spaces"> </span><span class="nottickedoff">CircleTree{} -> handleGlyph $ acc t</span>
|
||||
<span class="lineno"> 186 </span><span class="spaces"> </span><span class="nottickedoff">PolyLineTree{} -> handleGlyph $ acc t</span>
|
||||
<span class="lineno"> 187 </span><span class="spaces"> </span><span class="nottickedoff">PolygonTree{} -> handleGlyph $ acc t</span>
|
||||
<span class="lineno"> 188 </span><span class="spaces"> </span><span class="nottickedoff">EllipseTree{} -> handleGlyph $ acc t</span>
|
||||
<span class="lineno"> 189 </span><span class="spaces"> </span><span class="nottickedoff">LineTree{} -> handleGlyph $ acc t</span>
|
||||
<span class="lineno"> 190 </span><span class="spaces"> </span><span class="nottickedoff">RectangleTree{} -> handleGlyph $ acc t</span>
|
||||
<span class="lineno"> 191 </span><span class="spaces"> </span><span class="nottickedoff">DefinitionTree{} -> return ()</span>
|
||||
<span class="lineno"> 192 </span><span class="spaces"> </span><span class="nottickedoff">_ -></span>
|
||||
<span class="lineno"> 193 </span><span class="spaces"> </span><span class="nottickedoff">modify $ \(n, l, r) -> (n, acc t:l, r)</span></span>
|
||||
<span class="lineno"> 194 </span>{-
|
||||
<span class="lineno"> 195 </span><g transform="translate(10,10)">
|
||||
<span class="lineno"> 196 </span> <g transform="scale(2)">
|
||||
<span class="lineno"> 197 </span> <circle/>
|
||||
<span class="lineno"> 198 </span> </g>
|
||||
<span class="lineno"> 199 </span> <g transform="scale(0.5)">
|
||||
<span class="lineno"> 200 </span> <rect/>
|
||||
<span class="lineno"> 201 </span> </g>
|
||||
<span class="lineno"> 202 </span></g>
|
||||
<span class="lineno"> 203 </span>
|
||||
<span class="lineno"> 204 </span>[ (\svg -> <g transform="translate(10,10)"><g transform="scale(2)">svg</g></g>, <circle/>)
|
||||
<span class="lineno"> 205 </span>, (\svg -> <g transform="translate(10,10)"><g transform="scale(0.5)">svg</g></g>, <rect/>)]
|
||||
<span class="lineno"> 206 </span>-}
|
||||
<span class="lineno"> 207 </span>svgGlyphs :: Tree -> [(Tree -> Tree, DrawAttributes, Tree)]
|
||||
<span class="lineno"> 208 </span><span class="decl"><span class="istickedoff">svgGlyphs = worker <span class="nottickedoff">id</span> defaultSvg</span>
|
||||
<span class="lineno"> 209 </span><span class="spaces"> </span><span class="istickedoff">where</span>
|
||||
<span class="lineno"> 210 </span><span class="spaces"> </span><span class="istickedoff">worker acc attr =</span>
|
||||
<span class="lineno"> 211 </span><span class="spaces"> </span><span class="istickedoff">\case</span>
|
||||
<span class="lineno"> 212 </span><span class="spaces"> </span><span class="istickedoff">None -> <span class="nottickedoff">[]</span></span>
|
||||
<span class="lineno"> 213 </span><span class="spaces"> </span><span class="istickedoff">GroupTree g -></span>
|
||||
<span class="lineno"> 214 </span><span class="spaces"> </span><span class="istickedoff"><span class="nottickedoff">let acc' sub = acc (GroupTree $ g & groupChildren .~ [sub])</span></span>
|
||||
<span class="lineno"> 215 </span><span class="spaces"> </span><span class="istickedoff"><span class="nottickedoff">attr' = (g^.drawAttributes) `mappend` attr</span></span>
|
||||
<span class="lineno"> 216 </span><span class="spaces"> </span><span class="istickedoff"><span class="nottickedoff">in concatMap (worker acc' attr') (g ^. groupChildren)</span></span>
|
||||
<span class="lineno"> 217 </span><span class="spaces"> </span><span class="istickedoff">t -> [(<span class="nottickedoff">acc</span>, (t^.drawAttributes) `mappend` attr, t)]</span></span>
|
||||
<span class="lineno"> 218 </span>
|
||||
<span class="lineno"> 219 </span>{-| Convert primitive SVG shapes (like those created by 'mkCircle', 'mkRect', 'mkLine' or
|
||||
<span class="lineno"> 220 </span> 'mkEllipse') into SVG path. This can be useful for creating animations of these shapes being
|
||||
<span class="lineno"> 221 </span> drawn progressively with 'partialSvg'.
|
||||
<span class="lineno"> 222 </span>
|
||||
<span class="lineno"> 223 </span> Example:
|
||||
<span class="lineno"> 224 </span>
|
||||
<span class="lineno"> 225 </span> > pathifyExample :: Animation
|
||||
<span class="lineno"> 226 </span> > pathifyExample = animate $ \t -> gridLayout
|
||||
<span class="lineno"> 227 </span> > [ [ partialSvg t $ pathify $ mkCircle 1
|
||||
<span class="lineno"> 228 </span> > , partialSvg t $ pathify $ mkRect 2 2
|
||||
<span class="lineno"> 229 </span> > ]
|
||||
<span class="lineno"> 230 </span> > , [ partialSvg t $ pathify $ mkEllipse 1 0.5
|
||||
<span class="lineno"> 231 </span> > , partialSvg t $ pathify $ mkLine (-1, -1) (1, 1)
|
||||
<span class="lineno"> 232 </span> > ]
|
||||
<span class="lineno"> 233 </span> > ]
|
||||
<span class="lineno"> 234 </span>
|
||||
<span class="lineno"> 235 </span> <<docs/gifs/doc_pathify.gif>>
|
||||
<span class="lineno"> 236 </span> -}
|
||||
<span class="lineno"> 237 </span>pathify :: Tree -> Tree
|
||||
<span class="lineno"> 238 </span><span class="decl"><span class="istickedoff">pathify = mapTree worker</span>
|
||||
<span class="lineno"> 239 </span><span class="spaces"> </span><span class="istickedoff">where</span>
|
||||
<span class="lineno"> 240 </span><span class="spaces"> </span><span class="istickedoff">worker =</span>
|
||||
<span class="lineno"> 241 </span><span class="spaces"> </span><span class="istickedoff">\case</span>
|
||||
<span class="lineno"> 242 </span><span class="spaces"> </span><span class="istickedoff">RectangleTree rect | Just (x,y,w,h) <- unpackRect rect -></span>
|
||||
<span class="lineno"> 243 </span><span class="spaces"> </span><span class="istickedoff">PathTree $ defaultSvg</span>
|
||||
<span class="lineno"> 244 </span><span class="spaces"> </span><span class="istickedoff">& drawAttributes .~ rect ^. drawAttributes</span>
|
||||
<span class="lineno"> 245 </span><span class="spaces"> </span><span class="istickedoff">& strokeLineCap .~ pure CapSquare</span>
|
||||
<span class="lineno"> 246 </span><span class="spaces"> </span><span class="istickedoff">& pathDefinition .~</span>
|
||||
<span class="lineno"> 247 </span><span class="spaces"> </span><span class="istickedoff">[MoveTo OriginAbsolute [V2 x y]</span>
|
||||
<span class="lineno"> 248 </span><span class="spaces"> </span><span class="istickedoff">,HorizontalTo OriginRelative [w]</span>
|
||||
<span class="lineno"> 249 </span><span class="spaces"> </span><span class="istickedoff">,VerticalTo OriginRelative [h]</span>
|
||||
<span class="lineno"> 250 </span><span class="spaces"> </span><span class="istickedoff">,HorizontalTo OriginRelative [-w]</span>
|
||||
<span class="lineno"> 251 </span><span class="spaces"> </span><span class="istickedoff">,EndPath ]</span>
|
||||
<span class="lineno"> 252 </span><span class="spaces"> </span><span class="istickedoff">LineTree line | Just (x1,y1, x2, y2) <- unpackLine line -></span>
|
||||
<span class="lineno"> 253 </span><span class="spaces"> </span><span class="istickedoff">PathTree $ defaultSvg</span>
|
||||
<span class="lineno"> 254 </span><span class="spaces"> </span><span class="istickedoff">& drawAttributes .~ line ^. drawAttributes</span>
|
||||
<span class="lineno"> 255 </span><span class="spaces"> </span><span class="istickedoff">& pathDefinition .~</span>
|
||||
<span class="lineno"> 256 </span><span class="spaces"> </span><span class="istickedoff">[MoveTo OriginAbsolute [V2 x1 y1]</span>
|
||||
<span class="lineno"> 257 </span><span class="spaces"> </span><span class="istickedoff">,LineTo OriginAbsolute [V2 x2 y2] ]</span>
|
||||
<span class="lineno"> 258 </span><span class="spaces"> </span><span class="istickedoff">CircleTree circ | Just (x, y, r) <- unpackCircle circ -></span>
|
||||
<span class="lineno"> 259 </span><span class="spaces"> </span><span class="istickedoff">PathTree $ defaultSvg</span>
|
||||
<span class="lineno"> 260 </span><span class="spaces"> </span><span class="istickedoff">& drawAttributes .~ circ ^. drawAttributes</span>
|
||||
<span class="lineno"> 261 </span><span class="spaces"> </span><span class="istickedoff">& pathDefinition .~</span>
|
||||
<span class="lineno"> 262 </span><span class="spaces"> </span><span class="istickedoff">[MoveTo OriginAbsolute [V2 (x-r) y]</span>
|
||||
<span class="lineno"> 263 </span><span class="spaces"> </span><span class="istickedoff">,EllipticalArc OriginRelative [(r, r, 0,True,False,V2 (r*2) 0)</span>
|
||||
<span class="lineno"> 264 </span><span class="spaces"> </span><span class="istickedoff">,(r, r, 0,True,False,V2 (-r*2) 0)]]</span>
|
||||
<span class="lineno"> 265 </span><span class="spaces"> </span><span class="istickedoff">PolyLineTree pl -></span>
|
||||
<span class="lineno"> 266 </span><span class="spaces"> </span><span class="istickedoff"><span class="nottickedoff">let points = pl ^. polyLinePoints</span></span>
|
||||
<span class="lineno"> 267 </span><span class="spaces"> </span><span class="istickedoff"><span class="nottickedoff">in PathTree $ defaultSvg</span></span>
|
||||
<span class="lineno"> 268 </span><span class="spaces"> </span><span class="istickedoff"><span class="nottickedoff">& drawAttributes .~ pl ^. drawAttributes</span></span>
|
||||
<span class="lineno"> 269 </span><span class="spaces"> </span><span class="istickedoff"><span class="nottickedoff">& pathDefinition .~ pointsToPathCommands points</span></span>
|
||||
<span class="lineno"> 270 </span><span class="spaces"> </span><span class="istickedoff">PolygonTree pg -></span>
|
||||
<span class="lineno"> 271 </span><span class="spaces"> </span><span class="istickedoff"><span class="nottickedoff">let points = pg ^. polygonPoints</span></span>
|
||||
<span class="lineno"> 272 </span><span class="spaces"> </span><span class="istickedoff"><span class="nottickedoff">in PathTree $ defaultSvg</span></span>
|
||||
<span class="lineno"> 273 </span><span class="spaces"> </span><span class="istickedoff"><span class="nottickedoff">& drawAttributes .~ pg ^. drawAttributes</span></span>
|
||||
<span class="lineno"> 274 </span><span class="spaces"> </span><span class="istickedoff"><span class="nottickedoff">-- Polygon automatically connects the last point to the first. For path we must do</span></span>
|
||||
<span class="lineno"> 275 </span><span class="spaces"> </span><span class="istickedoff"><span class="nottickedoff">-- it explicitly</span></span>
|
||||
<span class="lineno"> 276 </span><span class="spaces"> </span><span class="istickedoff"><span class="nottickedoff">& pathDefinition .~ (pointsToPathCommands points ++ [EndPath])</span></span>
|
||||
<span class="lineno"> 277 </span><span class="spaces"> </span><span class="istickedoff">EllipseTree elip | Just (cx,cy,rx,ry) <- unpackEllipse elip -></span>
|
||||
<span class="lineno"> 278 </span><span class="spaces"> </span><span class="istickedoff">PathTree $ defaultSvg</span>
|
||||
<span class="lineno"> 279 </span><span class="spaces"> </span><span class="istickedoff">& drawAttributes .~ elip ^. drawAttributes</span>
|
||||
<span class="lineno"> 280 </span><span class="spaces"> </span><span class="istickedoff">& pathDefinition .~</span>
|
||||
<span class="lineno"> 281 </span><span class="spaces"> </span><span class="istickedoff">[ MoveTo OriginAbsolute [V2 (cx-rx) cy]</span>
|
||||
<span class="lineno"> 282 </span><span class="spaces"> </span><span class="istickedoff">, EllipticalArc OriginRelative [(rx, ry, 0,True,False,V2 (rx*2) 0)</span>
|
||||
<span class="lineno"> 283 </span><span class="spaces"> </span><span class="istickedoff">,(rx, ry, 0,True,False,V2 (-rx*2) 0)]]</span>
|
||||
<span class="lineno"> 284 </span><span class="spaces"> </span><span class="istickedoff">t -> t</span>
|
||||
<span class="lineno"> 285 </span><span class="spaces"> </span><span class="istickedoff">unpackCircle circ = do</span>
|
||||
<span class="lineno"> 286 </span><span class="spaces"> </span><span class="istickedoff">let (x,y) = circ ^. circleCenter</span>
|
||||
<span class="lineno"> 287 </span><span class="spaces"> </span><span class="istickedoff">liftM3 (,,) (unpackNumber x) (unpackNumber y) (unpackNumber $ circ ^. circleRadius)</span>
|
||||
<span class="lineno"> 288 </span><span class="spaces"> </span><span class="istickedoff">unpackEllipse elip = do</span>
|
||||
<span class="lineno"> 289 </span><span class="spaces"> </span><span class="istickedoff">let (x,y) = elip ^. ellipseCenter</span>
|
||||
<span class="lineno"> 290 </span><span class="spaces"> </span><span class="istickedoff">liftM4 (,,,) (unpackNumber x) (unpackNumber y) (unpackNumber $ elip ^. ellipseXRadius)</span>
|
||||
<span class="lineno"> 291 </span><span class="spaces"> </span><span class="istickedoff">(unpackNumber $ elip ^. ellipseYRadius)</span>
|
||||
<span class="lineno"> 292 </span><span class="spaces"> </span><span class="istickedoff">unpackLine line = do</span>
|
||||
<span class="lineno"> 293 </span><span class="spaces"> </span><span class="istickedoff">let (x1,y1) = line ^. linePoint1</span>
|
||||
<span class="lineno"> 294 </span><span class="spaces"> </span><span class="istickedoff">(x2,y2) = line ^. linePoint2</span>
|
||||
<span class="lineno"> 295 </span><span class="spaces"> </span><span class="istickedoff">liftM4 (,,,) (unpackNumber x1) (unpackNumber y1) (unpackNumber x2) (unpackNumber y2)</span>
|
||||
<span class="lineno"> 296 </span><span class="spaces"> </span><span class="istickedoff">unpackRect rect = do</span>
|
||||
<span class="lineno"> 297 </span><span class="spaces"> </span><span class="istickedoff">let (x', y') = rect ^. rectUpperLeftCorner</span>
|
||||
<span class="lineno"> 298 </span><span class="spaces"> </span><span class="istickedoff">x <- unpackNumber x'</span>
|
||||
<span class="lineno"> 299 </span><span class="spaces"> </span><span class="istickedoff">y <- unpackNumber y'</span>
|
||||
<span class="lineno"> 300 </span><span class="spaces"> </span><span class="istickedoff">w <- unpackNumber =<< rect ^. rectWidth</span>
|
||||
<span class="lineno"> 301 </span><span class="spaces"> </span><span class="istickedoff">h <- unpackNumber =<< rect ^. rectHeight</span>
|
||||
<span class="lineno"> 302 </span><span class="spaces"> </span><span class="istickedoff">return (x,y,w,h)</span>
|
||||
<span class="lineno"> 303 </span><span class="spaces"> </span><span class="istickedoff"><span class="nottickedoff">pointsToPathCommands points = case points of</span></span>
|
||||
<span class="lineno"> 304 </span><span class="spaces"> </span><span class="istickedoff"><span class="nottickedoff">[] -> []</span></span>
|
||||
<span class="lineno"> 305 </span><span class="spaces"> </span><span class="istickedoff"><span class="nottickedoff">(p:ps) -> [ MoveTo OriginAbsolute [p]</span></span>
|
||||
<span class="lineno"> 306 </span><span class="spaces"> </span><span class="istickedoff"><span class="nottickedoff">, LineTo OriginAbsolute ps ]</span></span>
|
||||
<span class="lineno"> 307 </span><span class="spaces"> </span><span class="istickedoff">unpackNumber n =</span>
|
||||
<span class="lineno"> 308 </span><span class="spaces"> </span><span class="istickedoff">case toUserUnit <span class="nottickedoff">defaultDPI</span> n of</span>
|
||||
<span class="lineno"> 309 </span><span class="spaces"> </span><span class="istickedoff">Num d -> Just d</span>
|
||||
<span class="lineno"> 310 </span><span class="spaces"> </span><span class="istickedoff">_ -> <span class="nottickedoff">Nothing</span></span></span>
|
||||
<span class="lineno"> 311 </span>
|
||||
<span class="lineno"> 312 </span>mapSvgPaths :: ([PathCommand] -> [PathCommand]) -> SVG -> SVG
|
||||
<span class="lineno"> 313 </span><span class="decl"><span class="nottickedoff">mapSvgPaths fn = mapTree worker</span>
|
||||
<span class="lineno"> 314 </span><span class="spaces"> </span><span class="nottickedoff">where</span>
|
||||
<span class="lineno"> 315 </span><span class="spaces"> </span><span class="nottickedoff">worker =</span>
|
||||
<span class="lineno"> 316 </span><span class="spaces"> </span><span class="nottickedoff">\case</span>
|
||||
<span class="lineno"> 317 </span><span class="spaces"> </span><span class="nottickedoff">PathTree path -> PathTree $</span>
|
||||
<span class="lineno"> 318 </span><span class="spaces"> </span><span class="nottickedoff">path & pathDefinition %~ fn</span>
|
||||
<span class="lineno"> 319 </span><span class="spaces"> </span><span class="nottickedoff">t -> t</span></span>
|
||||
<span class="lineno"> 320 </span>
|
||||
<span class="lineno"> 321 </span>mapSvgLines :: ([LineCommand] -> [LineCommand]) -> SVG -> SVG
|
||||
<span class="lineno"> 322 </span><span class="decl"><span class="nottickedoff">mapSvgLines fn = mapSvgPaths (lineToPath . fn . toLineCommands)</span></span>
|
||||
<span class="lineno"> 323 </span>
|
||||
<span class="lineno"> 324 </span>-- Only maps points in paths
|
||||
<span class="lineno"> 325 </span>mapSvgPoints :: (RPoint -> RPoint) -> SVG -> SVG
|
||||
<span class="lineno"> 326 </span><span class="decl"><span class="nottickedoff">mapSvgPoints fn = mapSvgLines (map worker)</span>
|
||||
<span class="lineno"> 327 </span><span class="spaces"> </span><span class="nottickedoff">where</span>
|
||||
<span class="lineno"> 328 </span><span class="spaces"> </span><span class="nottickedoff">worker (V2 x y) = V2 (x/180*pi) (y/180*pi)</span></span>
|
||||
<span class="lineno"> 328 </span><span class="spaces"> </span><span class="nottickedoff">worker (LineMove p) = LineMove (fn p)</span>
|
||||
<span class="lineno"> 329 </span><span class="spaces"> </span><span class="nottickedoff">worker (LineBezier ps) = LineBezier (map fn ps)</span>
|
||||
<span class="lineno"> 330 </span><span class="spaces"> </span><span class="nottickedoff">worker (LineEnd p) = LineEnd (fn p)</span></span>
|
||||
<span class="lineno"> 331 </span>
|
||||
<span class="lineno"> 332 </span>svgPointsToRadians :: SVG -> SVG
|
||||
<span class="lineno"> 333 </span><span class="decl"><span class="nottickedoff">svgPointsToRadians = mapSvgPoints worker</span>
|
||||
<span class="lineno"> 334 </span><span class="spaces"> </span><span class="nottickedoff">where</span>
|
||||
<span class="lineno"> 335 </span><span class="spaces"> </span><span class="nottickedoff">worker (V2 x y) = V2 (x/180*pi) (y/180*pi)</span></span>
|
||||
|
||||
</pre>
|
||||
</body>
|
||||
|
|
|
|||
|
|
@ -17,75 +17,82 @@ span.spaces { background: white }
|
|||
<span class="decl"><span class="nottickedoff">never executed</span> <span class="tickonlytrue">always true</span> <span class="tickonlyfalse">always false</span></span>
|
||||
</pre>
|
||||
<pre>
|
||||
<span class="lineno"> 1 </span>module Reanimate.Transition
|
||||
<span class="lineno"> 2 </span> ( Transition
|
||||
<span class="lineno"> 3 </span> , signalT
|
||||
<span class="lineno"> 4 </span> , mapT
|
||||
<span class="lineno"> 5 </span> , overlapT
|
||||
<span class="lineno"> 6 </span> , chainT
|
||||
<span class="lineno"> 7 </span> , effectT
|
||||
<span class="lineno"> 8 </span> , fadeT
|
||||
<span class="lineno"> 9 </span> ) where
|
||||
<span class="lineno"> 10 </span>
|
||||
<span class="lineno"> 11 </span>import Reanimate.Animation
|
||||
<span class="lineno"> 12 </span>import Reanimate.Ease
|
||||
<span class="lineno"> 13 </span>import Reanimate.Effect
|
||||
<span class="lineno"> 14 </span>
|
||||
<span class="lineno"> 15 </span>-- | A transition transforms one animation into another.
|
||||
<span class="lineno"> 16 </span>type Transition = Animation -> Animation -> Animation
|
||||
<span class="lineno"> 1 </span>{-|
|
||||
<span class="lineno"> 2 </span>Copyright : Written by David Himmelstrup
|
||||
<span class="lineno"> 3 </span>License : Unlicense
|
||||
<span class="lineno"> 4 </span>Maintainer : lemmih@gmail.com
|
||||
<span class="lineno"> 5 </span>Stability : experimental
|
||||
<span class="lineno"> 6 </span>Portability : POSIX
|
||||
<span class="lineno"> 7 </span>-}
|
||||
<span class="lineno"> 8 </span>module Reanimate.Transition
|
||||
<span class="lineno"> 9 </span> ( Transition
|
||||
<span class="lineno"> 10 </span> , signalT
|
||||
<span class="lineno"> 11 </span> , mapT
|
||||
<span class="lineno"> 12 </span> , overlapT
|
||||
<span class="lineno"> 13 </span> , chainT
|
||||
<span class="lineno"> 14 </span> , effectT
|
||||
<span class="lineno"> 15 </span> , fadeT
|
||||
<span class="lineno"> 16 </span> ) where
|
||||
<span class="lineno"> 17 </span>
|
||||
<span class="lineno"> 18 </span>-- | Apply a signal to the timing of a transition.
|
||||
<span class="lineno"> 19 </span>signalT :: Signal -> Transition -> Transition
|
||||
<span class="lineno"> 20 </span><span class="decl"><span class="istickedoff">signalT = mapT . signalA</span></span>
|
||||
<span class="lineno"> 18 </span>import Reanimate.Animation
|
||||
<span class="lineno"> 19 </span>import Reanimate.Ease
|
||||
<span class="lineno"> 20 </span>import Reanimate.Effect
|
||||
<span class="lineno"> 21 </span>
|
||||
<span class="lineno"> 22 </span>-- | Map the result of a transition.
|
||||
<span class="lineno"> 23 </span>mapT :: (Animation -> Animation) -> Transition -> Transition
|
||||
<span class="lineno"> 24 </span><span class="decl"><span class="istickedoff">mapT fn t a b = fn (t a b)</span></span>
|
||||
<span class="lineno"> 25 </span>
|
||||
<span class="lineno"> 26 </span>-- | Apply transition only to @N@ seconds of the first
|
||||
<span class="lineno"> 27 </span>-- animation and to the last @N@ seconds of the second animation.
|
||||
<span class="lineno"> 28 </span>--
|
||||
<span class="lineno"> 29 </span>-- Example:
|
||||
<span class="lineno"> 30 </span>--
|
||||
<span class="lineno"> 31 </span>-- > overlapT 0.5 fadeT drawBox drawCircle
|
||||
<span class="lineno"> 32 </span>--
|
||||
<span class="lineno"> 33 </span>-- <<docs/gifs/doc_overlapT.gif>>
|
||||
<span class="lineno"> 34 </span>overlapT :: Double -> Transition -> Transition
|
||||
<span class="lineno"> 35 </span><span class="decl"><span class="istickedoff">overlapT overlap t a b =</span>
|
||||
<span class="lineno"> 36 </span><span class="spaces"> </span><span class="istickedoff">aBefore `seqA` t aOverlap bOverlap `seqA` bAfter</span>
|
||||
<span class="lineno"> 37 </span><span class="spaces"> </span><span class="istickedoff">where</span>
|
||||
<span class="lineno"> 38 </span><span class="spaces"> </span><span class="istickedoff">aBefore = takeA (duration a - overlap) a</span>
|
||||
<span class="lineno"> 39 </span><span class="spaces"> </span><span class="istickedoff">aOverlap = lastA overlap a</span>
|
||||
<span class="lineno"> 40 </span><span class="spaces"> </span><span class="istickedoff">bOverlap = takeA overlap b</span>
|
||||
<span class="lineno"> 41 </span><span class="spaces"> </span><span class="istickedoff">bAfter = dropA overlap b</span></span>
|
||||
<span class="lineno"> 42 </span>
|
||||
<span class="lineno"> 43 </span>
|
||||
<span class="lineno"> 44 </span>-- | Create a transition between two animations by applying an effect to each respective animation.
|
||||
<span class="lineno"> 45 </span>effectT :: Effect -- ^ Effect to be applied to the first animation.
|
||||
<span class="lineno"> 46 </span> -> Effect -- ^ Effect to be applied to the second animation.
|
||||
<span class="lineno"> 47 </span> -> Transition
|
||||
<span class="lineno"> 48 </span><span class="decl"><span class="istickedoff">effectT eA eB a b = applyE eA a `parA` applyE eB b</span></span>
|
||||
<span class="lineno"> 22 </span>-- | A transition transforms one animation into another.
|
||||
<span class="lineno"> 23 </span>type Transition = Animation -> Animation -> Animation
|
||||
<span class="lineno"> 24 </span>
|
||||
<span class="lineno"> 25 </span>-- | Apply a signal to the timing of a transition.
|
||||
<span class="lineno"> 26 </span>signalT :: Signal -> Transition -> Transition
|
||||
<span class="lineno"> 27 </span><span class="decl"><span class="istickedoff">signalT = mapT . signalA</span></span>
|
||||
<span class="lineno"> 28 </span>
|
||||
<span class="lineno"> 29 </span>-- | Map the result of a transition.
|
||||
<span class="lineno"> 30 </span>mapT :: (Animation -> Animation) -> Transition -> Transition
|
||||
<span class="lineno"> 31 </span><span class="decl"><span class="istickedoff">mapT fn t a b = fn (t a b)</span></span>
|
||||
<span class="lineno"> 32 </span>
|
||||
<span class="lineno"> 33 </span>-- | Apply transition only to @N@ seconds of the first
|
||||
<span class="lineno"> 34 </span>-- animation and to the last @N@ seconds of the second animation.
|
||||
<span class="lineno"> 35 </span>--
|
||||
<span class="lineno"> 36 </span>-- Example:
|
||||
<span class="lineno"> 37 </span>--
|
||||
<span class="lineno"> 38 </span>-- > overlapT 0.5 fadeT drawBox drawCircle
|
||||
<span class="lineno"> 39 </span>--
|
||||
<span class="lineno"> 40 </span>-- <<docs/gifs/doc_overlapT.gif>>
|
||||
<span class="lineno"> 41 </span>overlapT :: Double -> Transition -> Transition
|
||||
<span class="lineno"> 42 </span><span class="decl"><span class="istickedoff">overlapT overlap t a b =</span>
|
||||
<span class="lineno"> 43 </span><span class="spaces"> </span><span class="istickedoff">aBefore `seqA` t aOverlap bOverlap `seqA` bAfter</span>
|
||||
<span class="lineno"> 44 </span><span class="spaces"> </span><span class="istickedoff">where</span>
|
||||
<span class="lineno"> 45 </span><span class="spaces"> </span><span class="istickedoff">aBefore = takeA (duration a - overlap) a</span>
|
||||
<span class="lineno"> 46 </span><span class="spaces"> </span><span class="istickedoff">aOverlap = lastA overlap a</span>
|
||||
<span class="lineno"> 47 </span><span class="spaces"> </span><span class="istickedoff">bOverlap = takeA overlap b</span>
|
||||
<span class="lineno"> 48 </span><span class="spaces"> </span><span class="istickedoff">bAfter = dropA overlap b</span></span>
|
||||
<span class="lineno"> 49 </span>
|
||||
<span class="lineno"> 50 </span>-- | Combine a list of animations using a given transition.
|
||||
<span class="lineno"> 51 </span>--
|
||||
<span class="lineno"> 52 </span>-- Example:
|
||||
<span class="lineno"> 53 </span>--
|
||||
<span class="lineno"> 54 </span>-- > chainT (overlapT 0.5 fadeT) [drawBox, drawCircle, drawProgress]
|
||||
<span class="lineno"> 55 </span>--
|
||||
<span class="lineno"> 56 </span>-- <<docs/gifs/doc_chainT.gif>>
|
||||
<span class="lineno"> 57 </span>chainT :: Transition -> [Animation] -> Animation
|
||||
<span class="lineno"> 58 </span><span class="decl"><span class="istickedoff">chainT _ [] = <span class="nottickedoff">pause 0</span></span>
|
||||
<span class="lineno"> 59 </span><span class="spaces"></span><span class="istickedoff">chainT t (x:xs) = foldl t x xs</span></span>
|
||||
<span class="lineno"> 60 </span>
|
||||
<span class="lineno"> 61 </span>-- | Fade out left-hand-side animation while fading in right-hand-side animation.
|
||||
<span class="lineno"> 50 </span>
|
||||
<span class="lineno"> 51 </span>-- | Create a transition between two animations by applying an effect to each respective animation.
|
||||
<span class="lineno"> 52 </span>effectT :: Effect -- ^ Effect to be applied to the first animation.
|
||||
<span class="lineno"> 53 </span> -> Effect -- ^ Effect to be applied to the second animation.
|
||||
<span class="lineno"> 54 </span> -> Transition
|
||||
<span class="lineno"> 55 </span><span class="decl"><span class="istickedoff">effectT eA eB a b = applyE eA a `parA` applyE eB b</span></span>
|
||||
<span class="lineno"> 56 </span>
|
||||
<span class="lineno"> 57 </span>-- | Combine a list of animations using a given transition.
|
||||
<span class="lineno"> 58 </span>--
|
||||
<span class="lineno"> 59 </span>-- Example:
|
||||
<span class="lineno"> 60 </span>--
|
||||
<span class="lineno"> 61 </span>-- > chainT (overlapT 0.5 fadeT) [drawBox, drawCircle, drawProgress]
|
||||
<span class="lineno"> 62 </span>--
|
||||
<span class="lineno"> 63 </span>-- Example:
|
||||
<span class="lineno"> 64 </span>--
|
||||
<span class="lineno"> 65 </span>-- > drawBox `fadeT` drawCircle
|
||||
<span class="lineno"> 66 </span>--
|
||||
<span class="lineno"> 67 </span>-- <<docs/gifs/doc_fadeT.gif>>
|
||||
<span class="lineno"> 68 </span>fadeT :: Transition
|
||||
<span class="lineno"> 69 </span><span class="decl"><span class="istickedoff">fadeT = effectT fadeOutE fadeInE</span></span>
|
||||
<span class="lineno"> 63 </span>-- <<docs/gifs/doc_chainT.gif>>
|
||||
<span class="lineno"> 64 </span>chainT :: Transition -> [Animation] -> Animation
|
||||
<span class="lineno"> 65 </span><span class="decl"><span class="istickedoff">chainT _ [] = <span class="nottickedoff">pause 0</span></span>
|
||||
<span class="lineno"> 66 </span><span class="spaces"></span><span class="istickedoff">chainT t (x:xs) = foldl t x xs</span></span>
|
||||
<span class="lineno"> 67 </span>
|
||||
<span class="lineno"> 68 </span>-- | Fade out left-hand-side animation while fading in right-hand-side animation.
|
||||
<span class="lineno"> 69 </span>--
|
||||
<span class="lineno"> 70 </span>-- Example:
|
||||
<span class="lineno"> 71 </span>--
|
||||
<span class="lineno"> 72 </span>-- > drawBox `fadeT` drawCircle
|
||||
<span class="lineno"> 73 </span>--
|
||||
<span class="lineno"> 74 </span>-- <<docs/gifs/doc_fadeT.gif>>
|
||||
<span class="lineno"> 75 </span>fadeT :: Transition
|
||||
<span class="lineno"> 76 </span><span class="decl"><span class="istickedoff">fadeT = effectT fadeOutE fadeInE</span></span>
|
||||
|
||||
</pre>
|
||||
</body>
|
||||
|
|
|
|||
Loading…
Reference in a new issue