diff --git a/haddock.txt b/haddock.txt index 1fcc378..485f69f 100644 --- a/haddock.txt +++ b/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' diff --git a/haddock_badge.json b/haddock_badge.json index ea97d81..c0a8d2c 100644 --- a/haddock_badge.json +++ b/haddock_badge.json @@ -1 +1 @@ - { "schemaVersion": 1, "label": "api docs", "message": "69%", "color": "success" } + { "schemaVersion": 1, "label": "api docs", "message": "86%", "color": "success" } diff --git a/playground/snippets.js b/playground/snippets.js index 84e78b7..156ba99 100644 --- a/playground/snippets.js +++ b/playground/snippets.js @@ -9,4 +9,4 @@ const snippets = [{"title": "Hello World","url": "https://reanimate.clozecards.c ,{"title": "Object Positions","url": "https://reanimate.clozecards.com/IAQhjO0Ke7h/195.svg","code": "env =\n addStatic (mkBackground \"white\") .\n mapA (withStrokeColor \"black\")\n\nanimation :: Animation\nanimation = env $\n sceneAnimation $ do\n -- Configure objects\n txt <- newText \"Center\"\n top <- newText \"Top\"\n oModifyS top $ \n oTopY .= screenTop\n topR <- newText \"Top right\"\n oModifyS topR $ do\n oTopY .= screenTop\n oRightX .= screenRight\n botR <- newText \"Bottom right\"\n oModifyS botR $ do\n oBottomY .= screenBottom\n oRightX .= screenRight\n botL <- newText \"Bottom left\"\n oModifyS botL $ do\n oBottomY .= screenBottom\n oLeftX .= screenLeft\n topL <- newText \"Top left\"\n oModifyS topL $ do\n oTopY .= screenTop\n oLeftX .= screenLeft\n -- Show objects\n oShow txt\n wait 1\n switchTo txt top\n switchTo top topR\n switchTo topR botR\n switchTo botR botL\n switchTo botL topL\n switchTo topL txt\n\nswitchTo src dst = do\n fork $ oFadeOut src 1\n oModify dst $ oOpacity .~ 1\n oFadeIn dst 1\n wait 1\n\nnewText txt =\n newObject $ scale 1.5 $ center $ latex txt\n"} ,{"title": "Camera","url": "https://reanimate.clozecards.com/CD5Bg7AwVkF/150.svg","code": "animation :: Animation\nanimation = docEnv $ mapA (withFillOpacity 1) $ sceneAnimation $ do\n cam <- newObject Camera\n\n txt <- newObject $ center $ latex \"Fixed (non-cam)\"\n oModifyS txt $ do\n oTopY .= screenTop \n oZIndex .= 2\n\n circle <- newObject $ Circle 1\n cameraAttach cam circle\n oModify circle $ oContext .~ withFillColor \"blue\"\n circleRight <- oRead circle oRightX\n\n box <- newObject $ Rectangle 2 2\n cameraAttach cam box\n oModify box $ oContext .~ withFillColor \"green\"\n oModify box $ oLeftX .~ circleRight\n boxCenter <- oRead box oCenterXY\n\n small <- newObject $ center $ latex \"This text is very small\"\n cameraAttach cam small\n oModifyS small $ do\n oCenterXY .= boxCenter\n oScale .= 0.1\n \n oShow txt\n oShow small\n oShow circle\n oShow box\n\n wait 1\n\n cameraFocus cam boxCenter\n waitOn $ do\n fork $ cameraPan cam 3 boxCenter\n fork $ cameraZoom cam 3 15\n \n wait 2\n cameraZoom cam 3 1\n cameraPan cam 1 (0,0)\n"} ]; -const playgroundVersion = "2020-08-26 (ce105)"; +const playgroundVersion = "2020-08-27 (dc549)"; diff --git a/reanimate-0.4.1.0-inplace/Reanimate.Builtin.Slide.hs.html b/reanimate-0.4.1.0-inplace/Reanimate.Builtin.Slide.hs.html index 1f18540..682f0f3 100644 --- a/reanimate-0.4.1.0-inplace/Reanimate.Builtin.Slide.hs.html +++ b/reanimate-0.4.1.0-inplace/Reanimate.Builtin.Slide.hs.html @@ -17,34 +17,41 @@ span.spaces { background: white } never executed always true always false 
-    1 module Reanimate.Builtin.Slide where
-    2 
-    3 import Reanimate.Transition
-    4 import Reanimate.Constants
-    5 import Reanimate.Svg
-    6 import Reanimate.Effect
-    7 
-    8 -- | <<docs/gifs/doc_slideLeftT.gif>>
-    9 slideLeftT :: Transition
-   10 slideLeftT = effectT slideLeft (andE slideLeft moveRight)
-   11   where
-   12     slideLeft = translateE (-screenWidth) 0
-   13     moveRight = constE (translate screenWidth 0)
-   14     andE a b d t = a d t . b d t
-   15 
-   16 slideDownT :: Transition
-   17 slideDownT = effectT slideDown (andE slideDown moveUp)
-   18   where
-   19     slideDown = translateE 0 (-screenHeight)
-   20     moveUp = constE (translate 0 screenHeight)
-   21     andE a b d t = a d t . b d t
+    1 {-|
+    2 Copyright   : Written by David Himmelstrup
+    3 License     : Unlicense
+    4 Maintainer  : lemmih@gmail.com
+    5 Stability   : experimental
+    6 Portability : POSIX
+    7 -}
+    8 module Reanimate.Builtin.Slide where
+    9 
+   10 import Reanimate.Transition
+   11 import Reanimate.Constants
+   12 import Reanimate.Svg
+   13 import Reanimate.Effect
+   14 
+   15 -- | <<docs/gifs/doc_slideLeftT.gif>>
+   16 slideLeftT :: Transition
+   17 slideLeftT = effectT slideLeft (andE slideLeft moveRight)
+   18   where
+   19     slideLeft = translateE (-screenWidth) 0
+   20     moveRight = constE (translate screenWidth 0)
+   21     andE a b d t = a d t . b d t
    22 
-   23 slideUpT :: Transition
-   24 slideUpT = effectT slideUp (andE slideUp moveDown)
+   23 slideDownT :: Transition
+   24 slideDownT = effectT slideDown (andE slideDown moveUp)
    25   where
-   26     slideUp = translateE 0 screenHeight
-   27     moveDown = constE (translate 0 (-screenHeight))
+   26     slideDown = translateE 0 (-screenHeight)
+   27     moveUp = constE (translate 0 screenHeight)
    28     andE a b d t = a d t . b d t
+   29 
+   30 slideUpT :: Transition
+   31 slideUpT = effectT slideUp (andE slideUp moveDown)
+   32   where
+   33     slideUp = translateE 0 screenHeight
+   34     moveDown = constE (translate 0 (-screenHeight))
+   35     andE a b d t = a d t . b d t
diff --git a/reanimate-0.4.1.0-inplace/Reanimate.Driver.Magick.hs.html b/reanimate-0.4.1.0-inplace/Reanimate.Driver.Magick.hs.html index b96e488..e675f72 100644 --- a/reanimate-0.4.1.0-inplace/Reanimate.Driver.Magick.hs.html +++ b/reanimate-0.4.1.0-inplace/Reanimate.Driver.Magick.hs.html @@ -25,12 +25,12 @@ span.spaces { background: white } 6 import System.Directory (findExecutable) 7 8 -- |The name of the ImageMagick command. On Unix-like operating systems, the - 9 -- command 'convert' does not conflict with the name of other commands. On - 10 -- Windows, ImageMagick version 7 is readily available, the command 'magick' - 11 -- should be present, and is preferred over 'convert'. If it is not present, - 12 -- 'convert' is assumed to be the relevant command. + 9 -- command \'convert\' does not conflict with the name of other commands. On + 10 -- Windows, ImageMagick version 7 is readily available, the command \'magick\' + 11 -- should be present, and is preferred over \'convert\'. If it is not present, + 12 -- \'convert\' is assumed to be the relevant command. 13 magickCmd :: String - 14 -- The use of 'unsafeperformIO' is justified on the basis that if 'magick' is + 14 -- The use of 'unsafeperformIO' is justified on the basis that if \'magick\' is 15 -- found once, it will always be present. 16 magickCmd = unsafePerformIO $ do 17 mPath <- findExecutable "magick" diff --git a/reanimate-0.4.1.0-inplace/Reanimate.Driver.hs.html b/reanimate-0.4.1.0-inplace/Reanimate.Driver.hs.html index 49042aa..f369f3e 100644 --- a/reanimate-0.4.1.0-inplace/Reanimate.Driver.hs.html +++ b/reanimate-0.4.1.0-inplace/Reanimate.Driver.hs.html @@ -106,7 +106,7 @@ span.spaces { background: white } 87 > view Play animation in browser window. 88 > render Render animation to file. 89 - 90 Neither the 'check' nor the 'view' command take any additional arguments. + 90 Neither the \'check\' nor the \'view\' command take any additional arguments. 91 Rendering animation can be controlled with these arguments: 92 93 > Usage: PROG render [-o|--target FILE] [--fps FPS] [-w|--width PIXELS] diff --git a/reanimate-0.4.1.0-inplace/Reanimate.Ease.hs.html b/reanimate-0.4.1.0-inplace/Reanimate.Ease.hs.html index 88dcaa4..c2dcb40 100644 --- a/reanimate-0.4.1.0-inplace/Reanimate.Ease.hs.html +++ b/reanimate-0.4.1.0-inplace/Reanimate.Ease.hs.html @@ -114,7 +114,7 @@ span.spaces { background: white } 95 bellS steepness = curveS steepness . oscillateS 96 97 -- | Cubic Bezier signal. Gives you a fair amount of control over how the - 98 -- signal will 'curve'. + 98 -- signal will curve. 99 -- 100 -- Example: 101 -- diff --git a/reanimate-0.4.1.0-inplace/Reanimate.LaTeX.hs.html b/reanimate-0.4.1.0-inplace/Reanimate.LaTeX.hs.html index 9a7f468..ad2867c 100644 --- a/reanimate-0.4.1.0-inplace/Reanimate.LaTeX.hs.html +++ b/reanimate-0.4.1.0-inplace/Reanimate.LaTeX.hs.html @@ -19,175 +19,182 @@ span.spaces { background: white } 
     1 {-# LANGUAGE OverloadedStrings   #-}
     2 {-# LANGUAGE ScopedTypeVariables #-}
-    3 module Reanimate.LaTeX
-    4   ( latex
-    5   , latexWithHeaders
-    6   , latexChunks
-    7   , xelatex
-    8   , xelatexWithHeaders
-    9   , ctex
-   10   , ctexWithHeaders
-   11   , latexAlign
-   12   )
-   13 where
-   14 
-   15 import qualified Data.ByteString               as B
-   16 import           Data.Text                                ( Text )
-   17 import qualified Data.Text                     as T
-   18 import qualified Data.Text.Encoding            as T
-   19 import           Graphics.SvgTree                         ( Tree(..)
-   20                                                           , parseSvgFile
-   21                                                           )
-   22 import           Reanimate.Cache
-   23 import           Reanimate.Misc
-   24 import           Reanimate.Svg
-   25 import           Reanimate.Parameters
-   26 import           System.FilePath                          ( replaceExtension
-   27                                                           , takeFileName
-   28                                                           , (</>)
-   29                                                           )
-   30 import           System.IO.Unsafe                         ( unsafePerformIO )
-   31 
-   32 -- | Invoke latex and import the result as an SVG object. SVG objects are
-   33 --   cached to improve performance.
-   34 --
-   35 --   Example:
-   36 --
-   37 --   > latex "$e^{i\\pi}+1=0$"
-   38 --
-   39 --   <<docs/gifs/doc_latex.gif>>
-   40 latex :: T.Text -> Tree
-   41 latex = latexWithHeaders []
-   42 
-   43 latexWithHeaders :: [T.Text] -> T.Text -> Tree
-   44 latexWithHeaders = someTexWithHeaders "latex" "dvi" []
-   45 
-   46 someTexWithHeaders :: String -> String -> [String] -> [T.Text] -> T.Text -> Tree
-   47 someTexWithHeaders _exec _dvi _args _headers tex | pNoExternals = mkText tex
-   48 someTexWithHeaders exec dvi args headers tex =
-   49   (unsafePerformIO . (cacheMem . cacheDiskSvg) (latexToSVG dvi exec args))
-   50     script
-   51  where
-   52   script = mkTexScript exec args headers tex
-   53 
-   54 latexChunks :: [T.Text] -> [Tree]
-   55 latexChunks chunks | pNoExternals = map mkText chunks
-   56 latexChunks chunks                = worker (svgGlyphs $ latex $ T.concat chunks) chunks
-   57  where
-   58   merge lst = mkGroup [ fmt svg | (fmt, _, svg) <- lst ]
-   59   worker [] [] = []
-   60   worker _ [] = error "latex chunk mismatch"
-   61   worker everything (x : xs) =
-   62     let width = length $ svgGlyphs (latex x)
-   63     in merge (take width everything) : worker (drop width everything) xs
-   64 
-   65 -- | Invoke xelatex and import the result as an SVG object. SVG objects are
-   66 --   cached to improve performance. Xelatex has support for non-western scripts.
-   67 xelatex :: Text -> Tree
-   68 xelatex = xelatexWithHeaders []
-   69 
-   70 xelatexWithHeaders :: [T.Text] -> T.Text -> Tree
-   71 xelatexWithHeaders = someTexWithHeaders "xelatex" "xdv" ["-no-pdf"]
-   72 
-   73 -- | Invoke xelatex with "\usepackage[UTF8]{ctex}" and import the result as an
-   74 --   SVG object. SVG objects are cached to improve performance. Xelatex has
-   75 --   support for non-western scripts.
-   76 --
-   77 --   Example:
-   78 --
-   79 --   > ctex "中文"
-   80 --
-   81 --   <<docs/gifs/doc_ctex.gif>>
-   82 ctex :: T.Text -> Tree
-   83 ctex = ctexWithHeaders []
-   84 
-   85 ctexWithHeaders :: [T.Text] -> T.Text -> Tree
-   86 ctexWithHeaders headers = xelatexWithHeaders ("\\usepackage[UTF8]{ctex}" : headers)
-   87 
-   88 -- | Invoke latex and import the result as an SVG object. SVG objects are
-   89 --   cached to improve performance. This wraps the TeX code in an 'align*'
-   90 --   context.
-   91 --
-   92 --   Example:
-   93 --
-   94 --   > latexAlign "R = \\frac{{\\Delta x}}{{kA}}"
-   95 --
-   96 --   <<docs/gifs/doc_latexAlign.gif>>
-   97 latexAlign :: Text -> Tree
-   98 latexAlign tex = latex $ T.unlines ["\\begin{align*}", tex, "\\end{align*}"]
-   99 
-  100 postprocess :: Tree -> Tree
-  101 postprocess = simplify
-  102 
-  103 -- executable, arguments, header, tex
-  104 latexToSVG :: String -> String -> [String] -> Text -> IO Tree
-  105 latexToSVG dviExt latexExec latexArgs tex = do
-  106   latexBin <- requireExecutable latexExec
-  107   dvisvgm  <- requireExecutable "dvisvgm"
-  108   withTempDir $ \tmp_dir -> withTempFile "tex" $ \tex_file ->
-  109     withTempFile "svg" $ \svg_file -> do
-  110       let dvi_file =
-  111             tmp_dir </> replaceExtension (takeFileName tex_file) dviExt
-  112       B.writeFile tex_file (T.encodeUtf8 tex)
-  113       runCmd
-  114         latexBin
-  115         (  latexArgs
-  116         ++ [ "-interaction=nonstopmode"
-  117            , "-halt-on-error"
-  118            , "-output-directory=" ++ tmp_dir
-  119            , tex_file
-  120            ]
-  121         )
-  122       runCmd
-  123         dvisvgm
-  124         [ dvi_file
-  125         , "--precision=5"
-  126         , "--exact"    -- better bboxes.
-  127         , "--no-fonts" -- use glyphs instead of fonts.
-  128         , "--scale=0.1,-0.1"
-  129         , "--verbosity=0"
-  130         , "-o"
-  131         , svg_file
-  132         ]
-  133       svg_data <- B.readFile svg_file
-  134       case parseSvgFile svg_file svg_data of
-  135         Nothing  -> error "Malformed svg"
-  136         Just svg -> return $ postprocess $ unbox $ replaceUses svg
-  137 
-  138 mkTexScript :: String -> [String] -> [Text] -> Text -> Text
-  139 mkTexScript latexExec latexArgs texHeaders tex =
-  140   T.unlines
-  141     $  [ "% " <> T.pack (unwords (latexExec : latexArgs))
-  142        , "\\documentclass[preview]{standalone}"
-  143        , "\\usepackage{amsmath}"
-  144        , "\\usepackage{gensymb}"
-  145        ]
-  146     ++ texHeaders
-  147     ++ [ "\\usepackage[english]{babel}"
-  148        , "\\linespread{1}"
-  149        , "\\begin{document}"
-  150        , tex
-  151        , "\\end{document}"
-  152        ]
-  153 
-  154 {- Packages used by manim.
-  155 
-  156 \\\usepackage{amsmath}\n\
-  157 \\\usepackage{amssymb}\n\
-  158 \\\usepackage{dsfont}\n\
-  159 \\\usepackage{setspace}\n\
-  160 \\\usepackage{relsize}\n\
-  161 \\\usepackage{textcomp}\n\
-  162 \\\usepackage{mathrsfs}\n\
-  163 \\\usepackage{calligra}\n\
-  164 \\\usepackage{wasysym}\n\
-  165 \\\usepackage{ragged2e}\n\
-  166 \\\usepackage{physics}\n\
-  167 \\\usepackage{xcolor}\n\
+    3 {-|
+    4 Copyright   : Written by David Himmelstrup
+    5 License     : Unlicense
+    6 Maintainer  : lemmih@gmail.com
+    7 Stability   : experimental
+    8 Portability : POSIX
+    9 -}
+   10 module Reanimate.LaTeX
+   11   ( latex
+   12   , latexWithHeaders
+   13   , latexChunks
+   14   , xelatex
+   15   , xelatexWithHeaders
+   16   , ctex
+   17   , ctexWithHeaders
+   18   , latexAlign
+   19   )
+   20 where
+   21 
+   22 import qualified Data.ByteString               as B
+   23 import           Data.Text                                ( Text )
+   24 import qualified Data.Text                     as T
+   25 import qualified Data.Text.Encoding            as T
+   26 import           Graphics.SvgTree                         ( Tree(..)
+   27                                                           , parseSvgFile
+   28                                                           )
+   29 import           Reanimate.Cache
+   30 import           Reanimate.Misc
+   31 import           Reanimate.Svg
+   32 import           Reanimate.Parameters
+   33 import           System.FilePath                          ( replaceExtension
+   34                                                           , takeFileName
+   35                                                           , (</>)
+   36                                                           )
+   37 import           System.IO.Unsafe                         ( unsafePerformIO )
+   38 
+   39 -- | Invoke latex and import the result as an SVG object. SVG objects are
+   40 --   cached to improve performance.
+   41 --
+   42 --   Example:
+   43 --
+   44 --   > latex "$e^{i\\pi}+1=0$"
+   45 --
+   46 --   <<docs/gifs/doc_latex.gif>>
+   47 latex :: T.Text -> Tree
+   48 latex = latexWithHeaders []
+   49 
+   50 latexWithHeaders :: [T.Text] -> T.Text -> Tree
+   51 latexWithHeaders = someTexWithHeaders "latex" "dvi" []
+   52 
+   53 someTexWithHeaders :: String -> String -> [String] -> [T.Text] -> T.Text -> Tree
+   54 someTexWithHeaders _exec _dvi _args _headers tex | pNoExternals = mkText tex
+   55 someTexWithHeaders exec dvi args headers tex =
+   56   (unsafePerformIO . (cacheMem . cacheDiskSvg) (latexToSVG dvi exec args))
+   57     script
+   58  where
+   59   script = mkTexScript exec args headers tex
+   60 
+   61 latexChunks :: [T.Text] -> [Tree]
+   62 latexChunks chunks | pNoExternals = map mkText chunks
+   63 latexChunks chunks                = worker (svgGlyphs $ latex $ T.concat chunks) chunks
+   64  where
+   65   merge lst = mkGroup [ fmt svg | (fmt, _, svg) <- lst ]
+   66   worker [] [] = []
+   67   worker _ [] = error "latex chunk mismatch"
+   68   worker everything (x : xs) =
+   69     let width = length $ svgGlyphs (latex x)
+   70     in merge (take width everything) : worker (drop width everything) xs
+   71 
+   72 -- | Invoke xelatex and import the result as an SVG object. SVG objects are
+   73 --   cached to improve performance. Xelatex has support for non-western scripts.
+   74 xelatex :: Text -> Tree
+   75 xelatex = xelatexWithHeaders []
+   76 
+   77 xelatexWithHeaders :: [T.Text] -> T.Text -> Tree
+   78 xelatexWithHeaders = someTexWithHeaders "xelatex" "xdv" ["-no-pdf"]
+   79 
+   80 -- | Invoke xelatex with "\usepackage[UTF8]{ctex}" and import the result as an
+   81 --   SVG object. SVG objects are cached to improve performance. Xelatex has
+   82 --   support for non-western scripts.
+   83 --
+   84 --   Example:
+   85 --
+   86 --   > ctex "中文"
+   87 --
+   88 --   <<docs/gifs/doc_ctex.gif>>
+   89 ctex :: T.Text -> Tree
+   90 ctex = ctexWithHeaders []
+   91 
+   92 ctexWithHeaders :: [T.Text] -> T.Text -> Tree
+   93 ctexWithHeaders headers = xelatexWithHeaders ("\\usepackage[UTF8]{ctex}" : headers)
+   94 
+   95 -- | Invoke latex and import the result as an SVG object. SVG objects are
+   96 --   cached to improve performance. This wraps the TeX code in an 'align*'
+   97 --   context.
+   98 --
+   99 --   Example:
+  100 --
+  101 --   > latexAlign "R = \\frac{{\\Delta x}}{{kA}}"
+  102 --
+  103 --   <<docs/gifs/doc_latexAlign.gif>>
+  104 latexAlign :: Text -> Tree
+  105 latexAlign tex = latex $ T.unlines ["\\begin{align*}", tex, "\\end{align*}"]
+  106 
+  107 postprocess :: Tree -> Tree
+  108 postprocess = simplify
+  109 
+  110 -- executable, arguments, header, tex
+  111 latexToSVG :: String -> String -> [String] -> Text -> IO Tree
+  112 latexToSVG dviExt latexExec latexArgs tex = do
+  113   latexBin <- requireExecutable latexExec
+  114   dvisvgm  <- requireExecutable "dvisvgm"
+  115   withTempDir $ \tmp_dir -> withTempFile "tex" $ \tex_file ->
+  116     withTempFile "svg" $ \svg_file -> do
+  117       let dvi_file =
+  118             tmp_dir </> replaceExtension (takeFileName tex_file) dviExt
+  119       B.writeFile tex_file (T.encodeUtf8 tex)
+  120       runCmd
+  121         latexBin
+  122         (  latexArgs
+  123         ++ [ "-interaction=nonstopmode"
+  124            , "-halt-on-error"
+  125            , "-output-directory=" ++ tmp_dir
+  126            , tex_file
+  127            ]
+  128         )
+  129       runCmd
+  130         dvisvgm
+  131         [ dvi_file
+  132         , "--precision=5"
+  133         , "--exact"    -- better bboxes.
+  134         , "--no-fonts" -- use glyphs instead of fonts.
+  135         , "--scale=0.1,-0.1"
+  136         , "--verbosity=0"
+  137         , "-o"
+  138         , svg_file
+  139         ]
+  140       svg_data <- B.readFile svg_file
+  141       case parseSvgFile svg_file svg_data of
+  142         Nothing  -> error "Malformed svg"
+  143         Just svg -> return $ postprocess $ unbox $ replaceUses svg
+  144 
+  145 mkTexScript :: String -> [String] -> [Text] -> Text -> Text
+  146 mkTexScript latexExec latexArgs texHeaders tex =
+  147   T.unlines
+  148     $  [ "% " <> T.pack (unwords (latexExec : latexArgs))
+  149        , "\\documentclass[preview]{standalone}"
+  150        , "\\usepackage{amsmath}"
+  151        , "\\usepackage{gensymb}"
+  152        ]
+  153     ++ texHeaders
+  154     ++ [ "\\usepackage[english]{babel}"
+  155        , "\\linespread{1}"
+  156        , "\\begin{document}"
+  157        , tex
+  158        , "\\end{document}"
+  159        ]
+  160 
+  161 {- Packages used by manim.
+  162 
+  163 \\\usepackage{amsmath}\n\
+  164 \\\usepackage{amssymb}\n\
+  165 \\\usepackage{dsfont}\n\
+  166 \\\usepackage{setspace}\n\
+  167 \\\usepackage{relsize}\n\
   168 \\\usepackage{textcomp}\n\
-  169 \\\usepackage{xfrac}\n\
-  170 \\\usepackage{microtype}\n\
-  171 -}
+  169 \\\usepackage{mathrsfs}\n\
+  170 \\\usepackage{calligra}\n\
+  171 \\\usepackage{wasysym}\n\
+  172 \\\usepackage{ragged2e}\n\
+  173 \\\usepackage{physics}\n\
+  174 \\\usepackage{xcolor}\n\
+  175 \\\usepackage{textcomp}\n\
+  176 \\\usepackage{xfrac}\n\
+  177 \\\usepackage{microtype}\n\
+  178 -}
diff --git a/reanimate-0.4.1.0-inplace/Reanimate.Math.Polygon.hs.html b/reanimate-0.4.1.0-inplace/Reanimate.Math.Polygon.hs.html index 2c67a11..f3b5449 100644 --- a/reanimate-0.4.1.0-inplace/Reanimate.Math.Polygon.hs.html +++ b/reanimate-0.4.1.0-inplace/Reanimate.Math.Polygon.hs.html @@ -19,804 +19,805 @@ span.spaces { background: white } 
     1 {-# LANGUAGE BangPatterns    #-}
     2 {-# LANGUAGE ConstraintKinds #-}
-    3 module Reanimate.Math.Polygon
-    4   ( APolygon(..)
-    5   , Polygon
-    6   , FPolygon
-    7   , P
-    8   , mkPolygon     -- :: (Fractional a, Ord a) => V.Vector (V2 a) -> APolygon a
-    9   , mkPolygonFromRing -- :: (Fractional a, Ord a) => Ring a -> APolygon a
-   10   , castPolygon   -- :: (Real a, Fractional b, Ord a) => APolygon a -> APolygon b
-   11   , pParent       -- :: Polygon -> Int -> Int -> Int
-   12   , pSetOffset    -- :: APolygon a -> Int -> APolygon a
-   13   , pAdjustOffset -- :: APolygon a -> Int -> APolygon a
-   14   , pSize         -- :: APolygon a -> Int
-   15   , pNull         -- :: APolygon a -> Bool
-   16   , pNext         -- :: APolygon a -> Int -> Int
-   17   , pPrev         -- :: APolygon a -> Int -> Int
-   18   , pIsSimple     -- :: Polygon -> Bool
-   19   , pIsConvex     -- :: Polygon -> Bool
-   20   , pIsCCW        -- :: Polygon -> Bool
-   21   , pScale        -- :: Rational -> Polygon -> Polygon
-   22   , pAtCentroid   -- :: Polygon -> Polygon
-   23   , pAtCenter     -- :: Polygon -> Polygon
-   24   , pTranslate    -- :: V2 Rational -> Polygon -> Polygon
-   25   , pCenter       -- :: Polygon -> V2 Rational
-   26   , pBoundingBox  -- :: Polygon -> (Rational, Rational, Rational, Rational)
-   27   , pIsInside     -- :: Polygon -> V2 Rational -> Bool
-   28   , pAccess       -- :: APolygon a -> Int -> V2 a
-   29   , pMkWinding    -- :: Int -> Polygon
-   30   , pDeoverlap    -- :: Polygon -> Polygon
-   31   , pCycles       -- :: Polygon -> [Polygon]
-   32   , pCycle        -- :: (Real a, Fractional a, Ord a) => APolygon a -> Double -> APolygon a
-   33   , pCentroid     -- :: Polygon -> V2 Rational
-   34   , pMapEdges     -- :: (V2 Rational -> V2 Rational -> a) -> Polygon -> V.Vector a
-   35   , pArea         -- :: Polygon -> Rational
-   36   , pCircumference   -- :: (Real a, Fractional a) => APolygon a -> a
-   37   , pCircumference'  -- :: (Real a, Fractional a) => APolygon a -> Double
-   38   , pAddPoints       -- :: Int -> Polygon -> Polygon
-   39   , pAddPointsRestricted -- :: [Int] -> Int -> Polygon -> Polygon
-   40   , pAddPointsBetween -- :: (Fractional a, Ord a, Real a) => (Int, Int) -> Int -> APolygon a -> APolygon a
-   41   , pRayIntersect    -- :: Polygon -> (Int, Int) -> (Int,Int) -> Maybe (V2 Rational)
-   42   , pOverlap         -- :: Polygon -> Polygon -> Polygon
-   43   , pCuts         -- :: Polygon -> [(Polygon,Polygon)]
-   44   , pCutEqual     -- :: Polygon -> (Polygon, Polygon)
-   45   -- * Triangulation
-   46   , isValidTriangulation     -- :: Polygon -> Triangulation -> Bool
-   47   , triangulationsToPolygons -- :: Polygon -> Triangulation -> [Polygon]
-   48   -- * Single-Source-Shortest-Path
-   49   , ssspVisibility -- :: Polygon -> Polygon
-   50   , ssspWindows -- :: Polygon -> [(V2 Rational, V2 Rational)]
-   51   -- * Duals
-   52   , pdualPolygons -- :: Polygon -> PDual -> [Polygon]
-   53   -- * Built-in shapes for testing
-   54   , triangle  -- :: Polygon
-   55   , triangle' -- :: [P]
-   56   , shape1  -- :: Polygon
-   57   , shape2  -- :: Polygon
-   58   , shape3  -- :: Polygon
-   59   , shape4  -- :: Polygon
-   60   , shape5  -- :: Polygon
-   61   , shape6  -- :: Polygon
-   62   , shape7  -- :: Polygon
-   63   , shape8  -- :: Polygon
-   64   , shape9  -- :: Polygon
-   65   , shape10 -- :: Polygon
-   66   , shape11 -- :: Polygon
-   67   , shape12 -- :: Polygon
-   68   , shape13 -- :: Polygon
-   69   , shape14 -- :: Polygon
-   70   , shape15 -- :: Polygon
-   71   , shape16 -- :: Polygon
-   72   , shape17 -- :: Polygon
-   73   , shape18 -- :: Polygon
-   74   , shape19 -- :: Polygon
-   75   , shape20 -- :: Polygon
-   76   , shape21 -- :: Polygon
-   77   , shape22 -- :: Polygon
-   78   , shape23 -- :: Polygon
-   79   , concave -- :: Polygon
-   80   -- * Internals
-   81   , pRing       -- :: APolygon a -> Ring a
-   82   , pUnsafeMap  -- :: (Ring a -> Ring a) -> APolygon a -> APolygon a
-   83   , pCopy       -- :: Polygon -> Polygon
-   84   , pGenerate   -- :: [(Double, Double)] -> Polygon
-   85   , pUnGenerate -- :: Polygon -> [(Double, Double)]
-   86   , Epsilon
-   87   ) where
-   88 
-   89 -- import           Control.Exception
-   90 import           Data.Hashable
-   91 import           Data.List                  (intersect, maximumBy, sort, sortOn,
-   92                                              tails)
-   93 import           Data.Maybe
-   94 import           Data.Ratio
-   95 import           Data.Serialize
-   96 import           Data.Vector                (Vector)
-   97 import qualified Data.Vector                as V
-   98 import           Linear.V2
-   99 import           Linear.Vector
-  100 import           Reanimate.Math.Common
-  101 -- import           Reanimate.Math.EarClip
-  102 import           Reanimate.Math.SSSP
-  103 import           Reanimate.Math.Triangulate
-  104 
-  105 -- import Debug.Trace
-  106 
-  107 -- Generate random polygons, options:
-  108 --   1. put corners around a circle. Vary the radius.
-  109 --   2. close a hilbert curve
-  110 type FPolygon = APolygon Double
-  111 -- Optimize representation?
-  112 --   Polygon = (Vector XNumerator, Vector XDenominator
-  113 --             ,Vector YNumerator, Vector YDenominator)
-  114 data APolygon a = Polygon
-  115   { polygonPoints        :: Vector (V2 a)
-  116   , polygonOffset        :: Int
-  117   , polygonTriangulation :: Triangulation
-  118   , polygonSSSP          :: Vector SSSP
-  119   }
-  120 type Polygon = APolygon Rational
-  121 type P = V2 Double
-  122 
-  123 instance Show a => Show (APolygon a) where
-  124   show = show . V.toList . polygonPoints
-  125 
-  126 instance Hashable a => Hashable (APolygon a) where
-  127   hashWithSalt s p = V.foldl' hashWithSalt s (polygonPoints p)
-  128 
-  129 instance (PolyCtx a, Serialize a) => Serialize (APolygon a) where
-  130   put = put . V.toList . polygonPoints
-  131   get = mkPolygon . V.fromList <$> get
-  132 
-  133 pRing :: APolygon a -> Ring a
-  134 pRing = ringPack . polygonPoints
-  135 
-  136 type PolyCtx a = (Real a, Fractional a, Epsilon a)
-  137 
-  138 mkPolygon :: PolyCtx a => V.Vector (V2 a) -> APolygon a
-  139 mkPolygon points = Polygon
-  140     { polygonPoints = points
-  141     , polygonOffset = 0
-  142     , polygonTriangulation = trig
-  143     , polygonSSSP = V.generate n $ \i -> sssp ring (dual i trig)
-  144     }
-  145   where
-  146     n = length points
-  147     ring = ringPack points
-  148     trig = triangulate ring
-  149       -- earClip ring
-  150 
-  151 castPolygon :: (PolyCtx a, PolyCtx b) => APolygon a -> APolygon b
-  152 castPolygon = mkPolygon . V.map (fmap realToFrac) . polygonPoints
-  153 
-  154 mkPolygonFromRing :: PolyCtx a => Ring a -> APolygon a
-  155 mkPolygonFromRing = mkPolygon . ringUnpack
-  156 
-  157 pUnsafeMap :: (Ring a -> Ring a) -> APolygon a -> APolygon a
-  158 pUnsafeMap fn p = p{ polygonPoints = ringUnpack (fn (pRing p)) }
-  159 
-  160 -- pParent p i j = shortest-path parent from j to i
-  161 pParent :: APolygon a -> Int -> Int -> Int
-  162 pParent p i j =
-  163     (sTree V.! mod (j + polygonOffset p) n - polygonOffset p) `mod` n
-  164   where
-  165     sTree = polygonSSSP p V.! mod (i + polygonOffset p) n
-  166     n = pSize p
-  167 
-  168 pCopy :: Polygon -> Polygon
-  169 pCopy p = mkPolygon $ V.generate (pSize p) $ pAccess p
-  170 
-  171 pSetOffset :: APolygon a -> Int -> APolygon a
-  172 pSetOffset p offset =
-  173   p { polygonOffset = offset `mod` pSize p }
-  174 
-  175 pAdjustOffset :: APolygon a -> Int -> APolygon a
-  176 pAdjustOffset p offset =
-  177   p { polygonOffset = (polygonOffset p + offset) `mod` pSize p }
-  178 
-  179 {-# INLINE pSize #-}
-  180 pSize :: APolygon a -> Int
-  181 pSize = length . polygonPoints
-  182 
-  183 pNull :: APolygon a -> Bool
-  184 pNull = V.null . polygonPoints
-  185 
-  186 pNext :: APolygon a -> Int -> Int
-  187 pNext p i = (i+1) `mod` pSize p
-  188 
-  189 pPrev :: APolygon a -> Int -> Int
-  190 pPrev p i = (i-1) `mod` pSize p
-  191 
-  192 -- When is a polygon valid/simple?
-  193 --   It is counter-clockwise.
-  194 --   No edges intersect.
-  195 -- O(n^2)
-  196 -- 'checkEdge' takes 90% of the time.
-  197 pIsSimple :: Polygon -> Bool
-  198 pIsSimple p | pSize p < 3 = False
-  199 pIsSimple p = pIsCCW p && noDups && checkEdge 0 2
-  200   where
-  201     noDups = checkForDups (sort (V.toList (polygonPoints p)))
-  202     checkForDups (x:y:xs)
-  203       = x /= y && checkForDups (y:xs)
-  204     checkForDups _ = True
-  205     len = pSize p
-  206     -- check i,i+1 against j,j+1
-  207     -- j > i+1
-  208     checkEdge i j
-  209       | j >= len = (i > len-3) || checkEdge (i+1) (i+3)
-  210       | otherwise =
-  211         case lineIntersect (pAccess p i, pAccess p $ i+1)
-  212                            (pAccess p j, pAccess p $ j+1) of
-  213           Just u | u /= pAccess p i -> False
-  214           _nothing                  -> checkEdge i (j+1)
-  215 
-  216 pScale :: Rational -> Polygon -> Polygon
-  217 pScale s = pUnsafeMap (ringMap (^* s))
-  218 
-  219 pAtCentroid :: Polygon -> Polygon
-  220 pAtCentroid p = pTranslate (negate c) p
-  221   where c = pCentroid p ^/ 2
-  222 
-  223 pAtCenter :: Polygon -> Polygon
-  224 pAtCenter p = pTranslate (negate $ pCenter p) p
-  225 
-  226 pTranslate :: V2 Rational -> Polygon -> Polygon
-  227 pTranslate v = pUnsafeMap (ringMap (+v))
-  228 
-  229 pCenter :: Polygon -> V2 Rational
-  230 pCenter p = V2 (x+w/2) (y+h/2)
-  231   where
-  232     (x,y,w,h) = pBoundingBox p
-  233 
-  234 -- Returns (min-x, min-y, width, height)
-  235 pBoundingBox :: Polygon -> (Rational, Rational, Rational, Rational)
-  236 pBoundingBox = \p ->
-  237     let V2 x y = pAccess p 0 in
-  238     case V.foldl' worker (x, y, 0, 0) (polygonPoints p) of
-  239       (xMin, yMin, xMax, yMax) ->
-  240         (xMin, yMin, xMax-xMin, yMax-yMin)
-  241   where
-  242     worker (xMin,yMin,xMax,yMax) (V2 thisX thisY) =
-  243       (min xMin thisX, min yMin thisY
-  244       ,max xMax thisX, max yMax thisY)
-  245 
-  246 -- Place n points on a circle, use one parameter to slide the points back and forth.
-  247 -- Use second parameter to move points closer to center circle.
-  248 pGenerate :: [(Double, Double)] -> Polygon
-  249 pGenerate points
-  250   | len < 4 = error "pGenerate: require at least four points"
-  251   | otherwise = mkPolygon $ V.fromList
-  252   [ V2 (realToFrac $ cos ang * rMod)
-  253        (realToFrac $ sin ang * rMod)
-  254   | (i,(angMod,rMod))  <- zip [0..] points
-  255   , let minAngle = tau / len * i - pi
-  256         maxAngle = tau / len * (i+1) - pi
-  257         ang = minAngle + (maxAngle-minAngle)*angMod
-  258   ]
-  259   where
-  260     tau = 2*pi
-  261     len = fromIntegral (length points)
-  262 
-  263 pUnGenerate :: Polygon -> [(Double, Double)]
-  264 pUnGenerate p =
-  265     [ worker i (fmap realToFrac e)
-  266     | (i,e) <- zip [0..] (V.toList $ polygonPoints p) ]
-  267   where
-  268     len = fromIntegral (pSize p)
-  269     worker i (V2 x y) =
-  270       let ang = atan2 y x
-  271           minAngle = tau / len * i - pi
-  272           maxAngle = tau / len * (i+1) - pi
-  273       in ((ang-minAngle)/(maxAngle-minAngle), sqrt (x*x+y*y))
-  274     tau = 2*pi
-  275 
-  276 -- When is a triangulation valid?
-  277 --   Intersection: No internal edges intersect.
-  278 --   Completeness: All edge neighbours share a single internal edge.
-  279 isValidTriangulation :: Polygon -> Triangulation -> Bool
-  280 isValidTriangulation p t = isComplete && intersectionFree
-  281   where
-  282     o = polygonOffset p
-  283     isComplete = all isProper [0 .. pSize p-1]
-  284     isProper i =
-  285       let j = pNext p i in
-  286       length ((pPrev p i : (t V.! i)) `intersect` (pNext p j : t V.! j)) == 1
-  287     intersectionFree = and
-  288       [ case lineIntersect (pAccess p (a-o), pAccess p (b-o)) (pAccess p (c-o), pAccess p (d-o)) of
-  289           Nothing -> True
-  290           Just u  -> u == pAccess p (a-o) || u == pAccess p (b-o) ||
-  291                      u == pAccess p (c-o) || u == pAccess p (d-o)
-  292       | ((a,b),(c,d)) <- edgePairs ]
-  293     edgePairs = [ (e1, e2) | (e1, rest) <- zip edges (drop 1 $ tails edges), e2 <- rest]
-  294     edges =
-  295       [ (n, i)
-  296       | (n, lst) <- zip [0..] (V.toList t)
-  297       , i <- lst
-  298       , n < i
-  299       ]
-  300 
-  301 triangulationsToPolygons :: Polygon -> Triangulation -> [Polygon]
-  302 triangulationsToPolygons p t =
-  303   [ mkPolygon $ V.fromList
-  304     [ pAccess p g, pAccess p i, pAccess p j ]
-  305   | i <- [0 .. pSize p-1]
-  306   , let js = filter (i<) $ t V.! i
-  307   , (g, j) <- zip (i-1:js) js
-  308   ]
-  309 
-  310 pIsInside :: Polygon -> V2 Rational -> Bool
-  311 pIsInside p point = or
-  312   [ isInside (rawAccess g) (rawAccess i) (rawAccess j) point
-  313   | i <- [0 .. pSize p-1]
-  314   , let js = filter (i<) $ polygonTriangulation p V.! i
-  315   , (g, j) <- zip (i-1:js) js
-  316   ]
-  317   where
-  318     rawAccess x = polygonPoints p V.! x
-  319 
-  320 -- reducePolygons :: Int -> [Polygon] -> [Polygon]
-  321 -- reducePolygons n ps
-  322 --   | length ps <= n = ps
-  323 --   | otherwise =
-  324 --     let p = findSmallest ps
-  325 --         es = edges p
-  326 --         e = findSmallest es
-  327 --     in reducePolygons n (merge p e : delete p (delete e ps))
-  328 --   where
-  329 --     findSmallest = minimumBy (comparing area2X)
-  330 --     shareEdge p1 p2 =
-  331 
-  332 {-# INLINE pAccess #-}
-  333 pAccess :: APolygon a -> Int -> V2 a
-  334 pAccess p i = -- polygonPoints p V.! ((polygonOffset p + i) `mod` pSize p)
-  335   polygonPoints p `V.unsafeIndex` ((polygonOffset p + i) `mod` pSize p)
-  336 
-  337 triangle :: Polygon
-  338 triangle = mkPolygon $ V.fromList [V2 1 1, V2 0 0, V2 2 0]
-  339 
-  340 triangle' :: [P]
-  341 triangle' = reverse [V2 1 1, V2 0 0, V2 2 0]
-  342 
-  343 shape1 :: Polygon
-  344 shape1 = mkPolygon $ V.fromList
-  345   [ V2 0 0, V2 2 0
-  346   , V2 2 1, V2 2 2, V2 2 3, V2 2 4, V2 2 5, V2 2 6
-  347   , V2 1 1, V2 0 1 ]
-  348 
-  349 shape2 :: Polygon
-  350 shape2 = mkPolygon $ V.fromList
-  351   [ V2 0 0, V2 1 0, V2 1 1, V2 2 1, V2 2 (-1), V2 0 (-1), V2 0 (-2)
-  352   , V2 3 (-2), V2 3 2, V2 0 2]
-  353 
-  354 shape3 :: Polygon
-  355 shape3 = mkPolygon $ V.fromList
-  356   [ V2 0 0, V2 1 0, V2 1 1, V2 2 1, V2 2 2, V2 0 2]
-  357 
-  358 shape4 :: Polygon
-  359 shape4 = mkPolygon $ V.fromList
-  360   [ V2 0 0, V2 1 0, V2 1 1, V2 2 1, V2 2 (-1), V2 3 (-1),V2 3 2, V2 0 2]
-  361 
-  362 shape5 :: Polygon
-  363 shape5 = pCycles shape4 !! 2
-  364 
-  365 -- square
-  366 shape6 :: Polygon
-  367 shape6 = mkPolygon $ V.fromList [ V2 0 0, V2 1 0, V2 1 1, V2 0 1 ]
-  368 
-  369 shape7 :: Polygon
-  370 shape7 = pScale 6 $ mkPolygon $ V.fromList
-  371         [V2 ((-1567171105775771) % 144115188075855872) ((-7758063241391039) % 1152921504606846976)
-  372         ,V2 ((-2711114907999263) % 18014398509481984) ((-3561889280168807) % 18014398509481984)
-  373         ,V2 ((-6897139157863177) % 72057594037927936) ((-1632144794297397) % 4503599627370496)
-  374         ,V2 (5592137945106423 % 36028797018963968) ((-71351641856107) % 281474976710656)
-  375         ,V2 (2568147525079071 % 4503599627370496) ((-4312925637247687) % 18014398509481984)
-  376         ,V2 (1291079014395023 % 2251799813685248) (321513444515769 % 2251799813685248)
-  377         ,V2 (2071709221627247 % 4503599627370496) (4019115966736491 % 9007199254740992)
-  378         ,V2 ((-1589087869859839) % 144115188075855872) (4904023654354179 % 9007199254740992)
-  379         ,V2 ((-2328090886101149) % 36028797018963968) (2587887893460759 % 36028797018963968)
-  380         ,V2 ((-7990199074159871) % 18014398509481984) (1301850651537745 % 4503599627370496)]
-  381 
-  382 shape8 :: Polygon
-  383 shape8 = pScale 10 $ pGenerate
-  384           [(0.36,0.4),(0.7,1.8e-2),(0.7,0.2),(0.1,0.4),(0.2,0.2),(0.7,0.1),(0.4,8.0e-2)]
-  385 
-  386 shape9 :: Polygon
-  387 shape9 = pScale 5 $ pGenerate
-  388   [(0.5,0.2),(0.7,0.6),(0.4,0.3),(0.1,0.7),(0.3,1.0e-2),(0.5,0.3),(0.2,0.8),(0.1,0.8),(0.7,6.0e-2),(0.1,0.6)]
-  389 
-  390 shape10 :: Polygon
-  391 shape10 = pGenerate
-  392   [(0.4,0.7),(0.2,0.2),(0.3,0.9),(5.0e-2,0.1),(0.7,1.0e-2),(0.7,0.9),(0.2,0.1),(0.5,6.0e-2),(0.6,9.0e-2)]
-  393 
-  394 shape11 :: Polygon
-  395 shape11 = pGenerate
-  396   [(0.1,0.8),(0.7,0.6),(0.7,0.4),(0.3,0.5),(0.8,0.9),(0.8,6.0e-2),(1.0e-2,4.0e-2),(0.8,0.1)]
-  397 
-  398 shape12 :: Polygon
-  399 shape12 = mkPolygon $ V.fromList
-  400   [ V2 0 0, V2 0.5 1.5, V2 2 2, V2 (-2) 2, V2 (-0.5) 1.5 ]
-  401 
-  402 -- F shape
-  403 shape13 :: Polygon
-  404 shape13 = pCycles (mkPolygon $ V.reverse (V.fromList
-  405   [ V2 0 0, V2 0 2
-  406   , V2 1 2, V2 1 1.7, V2 0.3 1.7, V2 0.3 1
-  407   , V2 1 1, V2 1 0.7
-  408   , V2 0.3 0.7, V2 0.3 0 ])) !! 7
-  409 
-  410 -- E shape
-  411 shape14 :: Polygon
-  412 shape14 = pCycles (mkPolygon $ V.reverse $ V.fromList
-  413   [ V2 0 0, V2 0 2 -- up
-  414   , V2 1 2, V2 1 1.7, V2 0.3 1.7, V2 0.3 1 -- first prong
-  415   , V2 1 1, V2 1 0.7, V2 0.3 0.7, V2 0.3 0.3 -- second prong
-  416   , V2 1 0.3, V2 1 0 -- last prong
-  417   ]) !! 9
-  418 
-  419 --
-  420 shape15 :: Polygon
-  421 shape15 = mkPolygon $ V.fromList
-  422   [ V2 0 0, V2 2 0
-  423   , V2 2 2, V2 1 2
-  424   , V2 1 1, V2 0 1]
-  425 
-  426 shape16 :: Polygon
-  427 shape16 = mkPolygon $ V.fromList
-  428   [ V2 0 0, V2 2 0
-  429   , V2 2 1, V2 1 1
-  430   , V2 1 2, V2 0 2]
-  431 
-  432 shape17 :: Polygon
-  433 shape17 = mkPolygon $ V.fromList
-  434   [ V2 2 0, V2 2 1
-  435   , V2 1 1, V2 1 2
-  436   , V2 0 2, V2 0 1, V2 0 0 ]
-  437 
-  438 shape18 :: Polygon
-  439 shape18 = mkPolygon $ V.fromList
-  440   [ V2 2 0, V2 2 1, V2 2 2
-  441   , V2 1 2, V2 1 1
-  442   , V2 0 1, V2 0 0 ]
-  443 
-  444 shape19 :: Polygon
-  445 shape19 = mkPolygon $ V.fromList
-  446   [ V2 (-3) (-3), V2 0 (-1)
-  447   , V2 3 (-3), V2 1 0
-  448   , V2 3 3, V2 0 1
-  449   , V2 (-3) 3, V2 (-1) 0 ]
-  450 
-  451 shape20 :: Polygon
-  452 shape20 = mkPolygon $ V.fromList
-  453   [ V2 (-3) (-3)
-  454   , V2 0 (-1)
-  455   , V2 3 (-3)
-  456   , V2 5 0
-  457   , V2 2.5 (-2)
-  458   , V2 1 0
-  459   , V2 3 3
-  460   , V2 0 1
-  461   , V2 (-3) 3
-  462   , V2 (-1) 0 ]
-  463 
-  464 shape21 :: Polygon
-  465 shape21 = mkPolygon $ V.fromList
-  466   [V2 0.0 0.0,V2 1.0 0.0,V2 1.0 1.0,V2 2.0 1.0,V2 2.0 (-1.0),V2 3.0 (-1.0)
-  467   ,V2 3.0 2.0,V2 0.0 2.0]
-  468 
-  469 shape22 :: Polygon
-  470 shape22 = pScale 2 $ mkPolygon $ V.fromList
-  471   [V2 (-0.17) (-0.08)
-  472   ,V2 (-0.34) (-0.21)
-  473   ,V2 0.0 0.0
-  474   ,V2 (-0.10) 0.60
-  475   ,V2 (-0.14) 0.19
-  476   ,V2 (-0.05) 0.03
-  477   ]
-  478 
-  479 shape23 :: Polygon
-  480 shape23 = mkPolygon $ V.fromList
-  481   [ V2 0 0, V2 4 0
-  482   , V2 4 3, V2 2 3
-  483   , V2 2 2, V2 3 2
-  484   , V2 3 1, V2 1 1
-  485   , V2 1 2, V2 2 2
-  486   , V2 2 3, V2 0 3 ]
-  487 
-  488 concave :: Polygon
-  489 concave = mkPolygon $
-  490   V.fromList [V2 0 0, V2 2 0, V2 2 2, V2 1 1, V2 0 2]
-  491 
-  492 pMkWinding :: Int -> Polygon
-  493 pMkWinding n | n < 1 = error "Polygon must have at least one winding."
-  494 pMkWinding n = mkPolygon $
-  495     V.fromList $ p0 : p1 : walkTo p1 1 n (V2 1 0) ++ reverse (walkTo p0 1 (n+2) (V2 (-1) 0))
-  496   where
-  497     p0 = V2 0 0
-  498     p1 = V2 0 1
-  499     walkTo at a b dir
-  500       | a == b = []
-  501       | otherwise =
-  502         let newAt = at + (dir ^* toRational a)
-  503         in newAt : walkTo newAt (a+1) b (rot dir)
-  504     rot (V2 x y) =
-  505       V2 y (-x)
-  506 
-  507 pDeoverlap :: Polygon -> Polygon
-  508 pDeoverlap p = mkPolygon arr
-  509   where
-  510     arr = V.generate (pSize p) worker
-  511     worker 0 = pAccess p 0
-  512     worker n =
-  513       if length (V.elemIndices (pAccess p n) (polygonPoints p)) /= 1
-  514         then
-  515           let prev = arr V.! (n-1)
-  516               this = pAccess p n
-  517           in lerp 0.99999 this prev
-  518         else pAccess p n
-  519 
-  520 pCycles :: APolygon a -> [APolygon a]
-  521 pCycles p = map (pAdjustOffset p) [0 .. pSize p-1]
-  522 
-  523 pCycle :: PolyCtx a => APolygon a -> Double -> APolygon a
-  524 pCycle p 0 = p
-  525 pCycle p t = mkPolygon $ worker 0 0
-  526   where
-  527     worker acc i
-  528       | segment + acc > limit =
-  529         V.singleton (lerp (realToFrac $ (segment + acc - limit)/segment) x y) <>
-  530         -- V.drop (i+1) (polygonPoints p) <>
-  531         V.fromList (map (pAccess p) [i+1..pSize p-1]) <>
-  532         V.fromList (map (pAccess p) [0 .. i])
-  533         -- V.take (i+1) (polygonPoints p)
-  534       | i == pSize p-1  = V.fromList (map (pAccess p) [0 .. pSize p-1])
-  535       | otherwise = worker (acc+segment) (i+1)
-  536         where
-  537           x = pAccess p i
-  538           y = pAccess p $ i+1
-  539           segment = distance' x y
-  540     len = pCircumference' p
-  541     limit = t * len
-  542 
-  543 pCentroid :: Fractional a => APolygon a -> V2 a
-  544 pCentroid p = V2 cx cy
-  545   where
-  546     a = pArea p
-  547     cx = recip (6*a) * V.sum (pMapEdges fnX p)
-  548     cy = recip (6*a) * V.sum (pMapEdges fnY p)
-  549     fnX (V2 x y) (V2 x' y') = (x+x')*(x*y' - x'*y)
-  550     fnY (V2 x y) (V2 x' y') = (y+y')*(x*y' - x'*y)
-  551 
-  552 {-# INLINE pMapEdges #-}
-  553 pMapEdges :: (V2 a -> V2 a -> b) -> APolygon a -> V.Vector b
-  554 pMapEdges fn p = V.generate n $ \i ->
-  555   if i == n-1
-  556     then fn (arr `V.unsafeIndex` i) (arr `V.unsafeIndex` 0)
-  557     else fn (arr `V.unsafeIndex` i) (arr `V.unsafeIndex` (i+1))
-  558   where
-  559     n = pSize p
-  560     arr = polygonPoints p
-  561 
-  562 {-# SPECIALIZE pArea :: APolygon Double -> Double #-}
-  563 {-# SPECIALIZE pArea :: APolygon Rational -> Rational #-}
-  564 pArea :: (Fractional a) => APolygon a -> a
-  565 pArea p =
-  566   -- 0.5 * V.sum (pMapEdges (\(V2 x y) (V2 x' y') -> x*y' - x'*y) p)
-  567   0.5 * worker 0 0
-  568   where
-  569     fn (V2 x y) (V2 x' y') = x*y' - x'*y
-  570     arr = polygonPoints p
-  571     worker !acc i
-  572       | i == pSize p - 1 = acc + fn (arr `V.unsafeIndex` i) (arr `V.unsafeIndex` 0)
-  573       | otherwise =
-  574         worker (acc + fn (arr `V.unsafeIndex` i) (arr `V.unsafeIndex` (i+1))) (i+1)
-  575 
-  576 pCircumference :: (Real a, Fractional a) => APolygon a -> a
-  577 pCircumference p = sum
-  578   [ approxDist (pAccess p i) (pAccess p $ i+1)
-  579   | i <- [0 .. pSize p-1]]
-  580 
-  581 pCircumference' :: (Real a, Fractional a) => APolygon a -> Double
-  582 pCircumference' p = sum
-  583   [ distance' (pAccess p i) (pAccess p $ i+1)
-  584   | i <- [0 .. pSize p-1]]
-  585 
+    3 {-# OPTIONS_HADDOCK hide #-}
+    4 module Reanimate.Math.Polygon
+    5   ( APolygon(..)
+    6   , Polygon
+    7   , FPolygon
+    8   , P
+    9   , mkPolygon     -- :: (Fractional a, Ord a) => V.Vector (V2 a) -> APolygon a
+   10   , mkPolygonFromRing -- :: (Fractional a, Ord a) => Ring a -> APolygon a
+   11   , castPolygon   -- :: (Real a, Fractional b, Ord a) => APolygon a -> APolygon b
+   12   , pParent       -- :: Polygon -> Int -> Int -> Int
+   13   , pSetOffset    -- :: APolygon a -> Int -> APolygon a
+   14   , pAdjustOffset -- :: APolygon a -> Int -> APolygon a
+   15   , pSize         -- :: APolygon a -> Int
+   16   , pNull         -- :: APolygon a -> Bool
+   17   , pNext         -- :: APolygon a -> Int -> Int
+   18   , pPrev         -- :: APolygon a -> Int -> Int
+   19   , pIsSimple     -- :: Polygon -> Bool
+   20   , pIsConvex     -- :: Polygon -> Bool
+   21   , pIsCCW        -- :: Polygon -> Bool
+   22   , pScale        -- :: Rational -> Polygon -> Polygon
+   23   , pAtCentroid   -- :: Polygon -> Polygon
+   24   , pAtCenter     -- :: Polygon -> Polygon
+   25   , pTranslate    -- :: V2 Rational -> Polygon -> Polygon
+   26   , pCenter       -- :: Polygon -> V2 Rational
+   27   , pBoundingBox  -- :: Polygon -> (Rational, Rational, Rational, Rational)
+   28   , pIsInside     -- :: Polygon -> V2 Rational -> Bool
+   29   , pAccess       -- :: APolygon a -> Int -> V2 a
+   30   , pMkWinding    -- :: Int -> Polygon
+   31   , pDeoverlap    -- :: Polygon -> Polygon
+   32   , pCycles       -- :: Polygon -> [Polygon]
+   33   , pCycle        -- :: (Real a, Fractional a, Ord a) => APolygon a -> Double -> APolygon a
+   34   , pCentroid     -- :: Polygon -> V2 Rational
+   35   , pMapEdges     -- :: (V2 Rational -> V2 Rational -> a) -> Polygon -> V.Vector a
+   36   , pArea         -- :: Polygon -> Rational
+   37   , pCircumference   -- :: (Real a, Fractional a) => APolygon a -> a
+   38   , pCircumference'  -- :: (Real a, Fractional a) => APolygon a -> Double
+   39   , pAddPoints       -- :: Int -> Polygon -> Polygon
+   40   , pAddPointsRestricted -- :: [Int] -> Int -> Polygon -> Polygon
+   41   , pAddPointsBetween -- :: (Fractional a, Ord a, Real a) => (Int, Int) -> Int -> APolygon a -> APolygon a
+   42   , pRayIntersect    -- :: Polygon -> (Int, Int) -> (Int,Int) -> Maybe (V2 Rational)
+   43   , pOverlap         -- :: Polygon -> Polygon -> Polygon
+   44   , pCuts         -- :: Polygon -> [(Polygon,Polygon)]
+   45   , pCutEqual     -- :: Polygon -> (Polygon, Polygon)
+   46   -- * Triangulation
+   47   , isValidTriangulation     -- :: Polygon -> Triangulation -> Bool
+   48   , triangulationsToPolygons -- :: Polygon -> Triangulation -> [Polygon]
+   49   -- * Single-Source-Shortest-Path
+   50   , ssspVisibility -- :: Polygon -> Polygon
+   51   , ssspWindows -- :: Polygon -> [(V2 Rational, V2 Rational)]
+   52   -- * Duals
+   53   , pdualPolygons -- :: Polygon -> PDual -> [Polygon]
+   54   -- * Built-in shapes for testing
+   55   , triangle  -- :: Polygon
+   56   , triangle' -- :: [P]
+   57   , shape1  -- :: Polygon
+   58   , shape2  -- :: Polygon
+   59   , shape3  -- :: Polygon
+   60   , shape4  -- :: Polygon
+   61   , shape5  -- :: Polygon
+   62   , shape6  -- :: Polygon
+   63   , shape7  -- :: Polygon
+   64   , shape8  -- :: Polygon
+   65   , shape9  -- :: Polygon
+   66   , shape10 -- :: Polygon
+   67   , shape11 -- :: Polygon
+   68   , shape12 -- :: Polygon
+   69   , shape13 -- :: Polygon
+   70   , shape14 -- :: Polygon
+   71   , shape15 -- :: Polygon
+   72   , shape16 -- :: Polygon
+   73   , shape17 -- :: Polygon
+   74   , shape18 -- :: Polygon
+   75   , shape19 -- :: Polygon
+   76   , shape20 -- :: Polygon
+   77   , shape21 -- :: Polygon
+   78   , shape22 -- :: Polygon
+   79   , shape23 -- :: Polygon
+   80   , concave -- :: Polygon
+   81   -- * Internals
+   82   , pRing       -- :: APolygon a -> Ring a
+   83   , pUnsafeMap  -- :: (Ring a -> Ring a) -> APolygon a -> APolygon a
+   84   , pCopy       -- :: Polygon -> Polygon
+   85   , pGenerate   -- :: [(Double, Double)] -> Polygon
+   86   , pUnGenerate -- :: Polygon -> [(Double, Double)]
+   87   , Epsilon
+   88   ) where
+   89 
+   90 -- import           Control.Exception
+   91 import           Data.Hashable
+   92 import           Data.List                  (intersect, maximumBy, sort, sortOn,
+   93                                              tails)
+   94 import           Data.Maybe
+   95 import           Data.Ratio
+   96 import           Data.Serialize
+   97 import           Data.Vector                (Vector)
+   98 import qualified Data.Vector                as V
+   99 import           Linear.V2
+  100 import           Linear.Vector
+  101 import           Reanimate.Math.Common
+  102 -- import           Reanimate.Math.EarClip
+  103 import           Reanimate.Math.SSSP
+  104 import           Reanimate.Math.Triangulate
+  105 
+  106 -- import Debug.Trace
+  107 
+  108 -- Generate random polygons, options:
+  109 --   1. put corners around a circle. Vary the radius.
+  110 --   2. close a hilbert curve
+  111 type FPolygon = APolygon Double
+  112 -- Optimize representation?
+  113 --   Polygon = (Vector XNumerator, Vector XDenominator
+  114 --             ,Vector YNumerator, Vector YDenominator)
+  115 data APolygon a = Polygon
+  116   { polygonPoints        :: Vector (V2 a)
+  117   , polygonOffset        :: Int
+  118   , polygonTriangulation :: Triangulation
+  119   , polygonSSSP          :: Vector SSSP
+  120   }
+  121 type Polygon = APolygon Rational
+  122 type P = V2 Double
+  123 
+  124 instance Show a => Show (APolygon a) where
+  125   show = show . V.toList . polygonPoints
+  126 
+  127 instance Hashable a => Hashable (APolygon a) where
+  128   hashWithSalt s p = V.foldl' hashWithSalt s (polygonPoints p)
+  129 
+  130 instance (PolyCtx a, Serialize a) => Serialize (APolygon a) where
+  131   put = put . V.toList . polygonPoints
+  132   get = mkPolygon . V.fromList <$> get
+  133 
+  134 pRing :: APolygon a -> Ring a
+  135 pRing = ringPack . polygonPoints
+  136 
+  137 type PolyCtx a = (Real a, Fractional a, Epsilon a)
+  138 
+  139 mkPolygon :: PolyCtx a => V.Vector (V2 a) -> APolygon a
+  140 mkPolygon points = Polygon
+  141     { polygonPoints = points
+  142     , polygonOffset = 0
+  143     , polygonTriangulation = trig
+  144     , polygonSSSP = V.generate n $ \i -> sssp ring (dual i trig)
+  145     }
+  146   where
+  147     n = length points
+  148     ring = ringPack points
+  149     trig = triangulate ring
+  150       -- earClip ring
+  151 
+  152 castPolygon :: (PolyCtx a, PolyCtx b) => APolygon a -> APolygon b
+  153 castPolygon = mkPolygon . V.map (fmap realToFrac) . polygonPoints
+  154 
+  155 mkPolygonFromRing :: PolyCtx a => Ring a -> APolygon a
+  156 mkPolygonFromRing = mkPolygon . ringUnpack
+  157 
+  158 pUnsafeMap :: (Ring a -> Ring a) -> APolygon a -> APolygon a
+  159 pUnsafeMap fn p = p{ polygonPoints = ringUnpack (fn (pRing p)) }
+  160 
+  161 -- pParent p i j = shortest-path parent from j to i
+  162 pParent :: APolygon a -> Int -> Int -> Int
+  163 pParent p i j =
+  164     (sTree V.! mod (j + polygonOffset p) n - polygonOffset p) `mod` n
+  165   where
+  166     sTree = polygonSSSP p V.! mod (i + polygonOffset p) n
+  167     n = pSize p
+  168 
+  169 pCopy :: Polygon -> Polygon
+  170 pCopy p = mkPolygon $ V.generate (pSize p) $ pAccess p
+  171 
+  172 pSetOffset :: APolygon a -> Int -> APolygon a
+  173 pSetOffset p offset =
+  174   p { polygonOffset = offset `mod` pSize p }
+  175 
+  176 pAdjustOffset :: APolygon a -> Int -> APolygon a
+  177 pAdjustOffset p offset =
+  178   p { polygonOffset = (polygonOffset p + offset) `mod` pSize p }
+  179 
+  180 {-# INLINE pSize #-}
+  181 pSize :: APolygon a -> Int
+  182 pSize = length . polygonPoints
+  183 
+  184 pNull :: APolygon a -> Bool
+  185 pNull = V.null . polygonPoints
+  186 
+  187 pNext :: APolygon a -> Int -> Int
+  188 pNext p i = (i+1) `mod` pSize p
+  189 
+  190 pPrev :: APolygon a -> Int -> Int
+  191 pPrev p i = (i-1) `mod` pSize p
+  192 
+  193 -- When is a polygon valid/simple?
+  194 --   It is counter-clockwise.
+  195 --   No edges intersect.
+  196 -- O(n^2)
+  197 -- 'checkEdge' takes 90% of the time.
+  198 pIsSimple :: Polygon -> Bool
+  199 pIsSimple p | pSize p < 3 = False
+  200 pIsSimple p = pIsCCW p && noDups && checkEdge 0 2
+  201   where
+  202     noDups = checkForDups (sort (V.toList (polygonPoints p)))
+  203     checkForDups (x:y:xs)
+  204       = x /= y && checkForDups (y:xs)
+  205     checkForDups _ = True
+  206     len = pSize p
+  207     -- check i,i+1 against j,j+1
+  208     -- j > i+1
+  209     checkEdge i j
+  210       | j >= len = (i > len-3) || checkEdge (i+1) (i+3)
+  211       | otherwise =
+  212         case lineIntersect (pAccess p i, pAccess p $ i+1)
+  213                            (pAccess p j, pAccess p $ j+1) of
+  214           Just u | u /= pAccess p i -> False
+  215           _nothing                  -> checkEdge i (j+1)
+  216 
+  217 pScale :: Rational -> Polygon -> Polygon
+  218 pScale s = pUnsafeMap (ringMap (^* s))
+  219 
+  220 pAtCentroid :: Polygon -> Polygon
+  221 pAtCentroid p = pTranslate (negate c) p
+  222   where c = pCentroid p ^/ 2
+  223 
+  224 pAtCenter :: Polygon -> Polygon
+  225 pAtCenter p = pTranslate (negate $ pCenter p) p
+  226 
+  227 pTranslate :: V2 Rational -> Polygon -> Polygon
+  228 pTranslate v = pUnsafeMap (ringMap (+v))
+  229 
+  230 pCenter :: Polygon -> V2 Rational
+  231 pCenter p = V2 (x+w/2) (y+h/2)
+  232   where
+  233     (x,y,w,h) = pBoundingBox p
+  234 
+  235 -- Returns (min-x, min-y, width, height)
+  236 pBoundingBox :: Polygon -> (Rational, Rational, Rational, Rational)
+  237 pBoundingBox = \p ->
+  238     let V2 x y = pAccess p 0 in
+  239     case V.foldl' worker (x, y, 0, 0) (polygonPoints p) of
+  240       (xMin, yMin, xMax, yMax) ->
+  241         (xMin, yMin, xMax-xMin, yMax-yMin)
+  242   where
+  243     worker (xMin,yMin,xMax,yMax) (V2 thisX thisY) =
+  244       (min xMin thisX, min yMin thisY
+  245       ,max xMax thisX, max yMax thisY)
+  246 
+  247 -- Place n points on a circle, use one parameter to slide the points back and forth.
+  248 -- Use second parameter to move points closer to center circle.
+  249 pGenerate :: [(Double, Double)] -> Polygon
+  250 pGenerate points
+  251   | len < 4 = error "pGenerate: require at least four points"
+  252   | otherwise = mkPolygon $ V.fromList
+  253   [ V2 (realToFrac $ cos ang * rMod)
+  254        (realToFrac $ sin ang * rMod)
+  255   | (i,(angMod,rMod))  <- zip [0..] points
+  256   , let minAngle = tau / len * i - pi
+  257         maxAngle = tau / len * (i+1) - pi
+  258         ang = minAngle + (maxAngle-minAngle)*angMod
+  259   ]
+  260   where
+  261     tau = 2*pi
+  262     len = fromIntegral (length points)
+  263 
+  264 pUnGenerate :: Polygon -> [(Double, Double)]
+  265 pUnGenerate p =
+  266     [ worker i (fmap realToFrac e)
+  267     | (i,e) <- zip [0..] (V.toList $ polygonPoints p) ]
+  268   where
+  269     len = fromIntegral (pSize p)
+  270     worker i (V2 x y) =
+  271       let ang = atan2 y x
+  272           minAngle = tau / len * i - pi
+  273           maxAngle = tau / len * (i+1) - pi
+  274       in ((ang-minAngle)/(maxAngle-minAngle), sqrt (x*x+y*y))
+  275     tau = 2*pi
+  276 
+  277 -- When is a triangulation valid?
+  278 --   Intersection: No internal edges intersect.
+  279 --   Completeness: All edge neighbours share a single internal edge.
+  280 isValidTriangulation :: Polygon -> Triangulation -> Bool
+  281 isValidTriangulation p t = isComplete && intersectionFree
+  282   where
+  283     o = polygonOffset p
+  284     isComplete = all isProper [0 .. pSize p-1]
+  285     isProper i =
+  286       let j = pNext p i in
+  287       length ((pPrev p i : (t V.! i)) `intersect` (pNext p j : t V.! j)) == 1
+  288     intersectionFree = and
+  289       [ case lineIntersect (pAccess p (a-o), pAccess p (b-o)) (pAccess p (c-o), pAccess p (d-o)) of
+  290           Nothing -> True
+  291           Just u  -> u == pAccess p (a-o) || u == pAccess p (b-o) ||
+  292                      u == pAccess p (c-o) || u == pAccess p (d-o)
+  293       | ((a,b),(c,d)) <- edgePairs ]
+  294     edgePairs = [ (e1, e2) | (e1, rest) <- zip edges (drop 1 $ tails edges), e2 <- rest]
+  295     edges =
+  296       [ (n, i)
+  297       | (n, lst) <- zip [0..] (V.toList t)
+  298       , i <- lst
+  299       , n < i
+  300       ]
+  301 
+  302 triangulationsToPolygons :: Polygon -> Triangulation -> [Polygon]
+  303 triangulationsToPolygons p t =
+  304   [ mkPolygon $ V.fromList
+  305     [ pAccess p g, pAccess p i, pAccess p j ]
+  306   | i <- [0 .. pSize p-1]
+  307   , let js = filter (i<) $ t V.! i
+  308   , (g, j) <- zip (i-1:js) js
+  309   ]
+  310 
+  311 pIsInside :: Polygon -> V2 Rational -> Bool
+  312 pIsInside p point = or
+  313   [ isInside (rawAccess g) (rawAccess i) (rawAccess j) point
+  314   | i <- [0 .. pSize p-1]
+  315   , let js = filter (i<) $ polygonTriangulation p V.! i
+  316   , (g, j) <- zip (i-1:js) js
+  317   ]
+  318   where
+  319     rawAccess x = polygonPoints p V.! x
+  320 
+  321 -- reducePolygons :: Int -> [Polygon] -> [Polygon]
+  322 -- reducePolygons n ps
+  323 --   | length ps <= n = ps
+  324 --   | otherwise =
+  325 --     let p = findSmallest ps
+  326 --         es = edges p
+  327 --         e = findSmallest es
+  328 --     in reducePolygons n (merge p e : delete p (delete e ps))
+  329 --   where
+  330 --     findSmallest = minimumBy (comparing area2X)
+  331 --     shareEdge p1 p2 =
+  332 
+  333 {-# INLINE pAccess #-}
+  334 pAccess :: APolygon a -> Int -> V2 a
+  335 pAccess p i = -- polygonPoints p V.! ((polygonOffset p + i) `mod` pSize p)
+  336   polygonPoints p `V.unsafeIndex` ((polygonOffset p + i) `mod` pSize p)
+  337 
+  338 triangle :: Polygon
+  339 triangle = mkPolygon $ V.fromList [V2 1 1, V2 0 0, V2 2 0]
+  340 
+  341 triangle' :: [P]
+  342 triangle' = reverse [V2 1 1, V2 0 0, V2 2 0]
+  343 
+  344 shape1 :: Polygon
+  345 shape1 = mkPolygon $ V.fromList
+  346   [ V2 0 0, V2 2 0
+  347   , V2 2 1, V2 2 2, V2 2 3, V2 2 4, V2 2 5, V2 2 6
+  348   , V2 1 1, V2 0 1 ]
+  349 
+  350 shape2 :: Polygon
+  351 shape2 = mkPolygon $ V.fromList
+  352   [ V2 0 0, V2 1 0, V2 1 1, V2 2 1, V2 2 (-1), V2 0 (-1), V2 0 (-2)
+  353   , V2 3 (-2), V2 3 2, V2 0 2]
+  354 
+  355 shape3 :: Polygon
+  356 shape3 = mkPolygon $ V.fromList
+  357   [ V2 0 0, V2 1 0, V2 1 1, V2 2 1, V2 2 2, V2 0 2]
+  358 
+  359 shape4 :: Polygon
+  360 shape4 = mkPolygon $ V.fromList
+  361   [ V2 0 0, V2 1 0, V2 1 1, V2 2 1, V2 2 (-1), V2 3 (-1),V2 3 2, V2 0 2]
+  362 
+  363 shape5 :: Polygon
+  364 shape5 = pCycles shape4 !! 2
+  365 
+  366 -- square
+  367 shape6 :: Polygon
+  368 shape6 = mkPolygon $ V.fromList [ V2 0 0, V2 1 0, V2 1 1, V2 0 1 ]
+  369 
+  370 shape7 :: Polygon
+  371 shape7 = pScale 6 $ mkPolygon $ V.fromList
+  372         [V2 ((-1567171105775771) % 144115188075855872) ((-7758063241391039) % 1152921504606846976)
+  373         ,V2 ((-2711114907999263) % 18014398509481984) ((-3561889280168807) % 18014398509481984)
+  374         ,V2 ((-6897139157863177) % 72057594037927936) ((-1632144794297397) % 4503599627370496)
+  375         ,V2 (5592137945106423 % 36028797018963968) ((-71351641856107) % 281474976710656)
+  376         ,V2 (2568147525079071 % 4503599627370496) ((-4312925637247687) % 18014398509481984)
+  377         ,V2 (1291079014395023 % 2251799813685248) (321513444515769 % 2251799813685248)
+  378         ,V2 (2071709221627247 % 4503599627370496) (4019115966736491 % 9007199254740992)
+  379         ,V2 ((-1589087869859839) % 144115188075855872) (4904023654354179 % 9007199254740992)
+  380         ,V2 ((-2328090886101149) % 36028797018963968) (2587887893460759 % 36028797018963968)
+  381         ,V2 ((-7990199074159871) % 18014398509481984) (1301850651537745 % 4503599627370496)]
+  382 
+  383 shape8 :: Polygon
+  384 shape8 = pScale 10 $ pGenerate
+  385           [(0.36,0.4),(0.7,1.8e-2),(0.7,0.2),(0.1,0.4),(0.2,0.2),(0.7,0.1),(0.4,8.0e-2)]
+  386 
+  387 shape9 :: Polygon
+  388 shape9 = pScale 5 $ pGenerate
+  389   [(0.5,0.2),(0.7,0.6),(0.4,0.3),(0.1,0.7),(0.3,1.0e-2),(0.5,0.3),(0.2,0.8),(0.1,0.8),(0.7,6.0e-2),(0.1,0.6)]
+  390 
+  391 shape10 :: Polygon
+  392 shape10 = pGenerate
+  393   [(0.4,0.7),(0.2,0.2),(0.3,0.9),(5.0e-2,0.1),(0.7,1.0e-2),(0.7,0.9),(0.2,0.1),(0.5,6.0e-2),(0.6,9.0e-2)]
+  394 
+  395 shape11 :: Polygon
+  396 shape11 = pGenerate
+  397   [(0.1,0.8),(0.7,0.6),(0.7,0.4),(0.3,0.5),(0.8,0.9),(0.8,6.0e-2),(1.0e-2,4.0e-2),(0.8,0.1)]
+  398 
+  399 shape12 :: Polygon
+  400 shape12 = mkPolygon $ V.fromList
+  401   [ V2 0 0, V2 0.5 1.5, V2 2 2, V2 (-2) 2, V2 (-0.5) 1.5 ]
+  402 
+  403 -- F shape
+  404 shape13 :: Polygon
+  405 shape13 = pCycles (mkPolygon $ V.reverse (V.fromList
+  406   [ V2 0 0, V2 0 2
+  407   , V2 1 2, V2 1 1.7, V2 0.3 1.7, V2 0.3 1
+  408   , V2 1 1, V2 1 0.7
+  409   , V2 0.3 0.7, V2 0.3 0 ])) !! 7
+  410 
+  411 -- E shape
+  412 shape14 :: Polygon
+  413 shape14 = pCycles (mkPolygon $ V.reverse $ V.fromList
+  414   [ V2 0 0, V2 0 2 -- up
+  415   , V2 1 2, V2 1 1.7, V2 0.3 1.7, V2 0.3 1 -- first prong
+  416   , V2 1 1, V2 1 0.7, V2 0.3 0.7, V2 0.3 0.3 -- second prong
+  417   , V2 1 0.3, V2 1 0 -- last prong
+  418   ]) !! 9
+  419 
+  420 --
+  421 shape15 :: Polygon
+  422 shape15 = mkPolygon $ V.fromList
+  423   [ V2 0 0, V2 2 0
+  424   , V2 2 2, V2 1 2
+  425   , V2 1 1, V2 0 1]
+  426 
+  427 shape16 :: Polygon
+  428 shape16 = mkPolygon $ V.fromList
+  429   [ V2 0 0, V2 2 0
+  430   , V2 2 1, V2 1 1
+  431   , V2 1 2, V2 0 2]
+  432 
+  433 shape17 :: Polygon
+  434 shape17 = mkPolygon $ V.fromList
+  435   [ V2 2 0, V2 2 1
+  436   , V2 1 1, V2 1 2
+  437   , V2 0 2, V2 0 1, V2 0 0 ]
+  438 
+  439 shape18 :: Polygon
+  440 shape18 = mkPolygon $ V.fromList
+  441   [ V2 2 0, V2 2 1, V2 2 2
+  442   , V2 1 2, V2 1 1
+  443   , V2 0 1, V2 0 0 ]
+  444 
+  445 shape19 :: Polygon
+  446 shape19 = mkPolygon $ V.fromList
+  447   [ V2 (-3) (-3), V2 0 (-1)
+  448   , V2 3 (-3), V2 1 0
+  449   , V2 3 3, V2 0 1
+  450   , V2 (-3) 3, V2 (-1) 0 ]
+  451 
+  452 shape20 :: Polygon
+  453 shape20 = mkPolygon $ V.fromList
+  454   [ V2 (-3) (-3)
+  455   , V2 0 (-1)
+  456   , V2 3 (-3)
+  457   , V2 5 0
+  458   , V2 2.5 (-2)
+  459   , V2 1 0
+  460   , V2 3 3
+  461   , V2 0 1
+  462   , V2 (-3) 3
+  463   , V2 (-1) 0 ]
+  464 
+  465 shape21 :: Polygon
+  466 shape21 = mkPolygon $ V.fromList
+  467   [V2 0.0 0.0,V2 1.0 0.0,V2 1.0 1.0,V2 2.0 1.0,V2 2.0 (-1.0),V2 3.0 (-1.0)
+  468   ,V2 3.0 2.0,V2 0.0 2.0]
+  469 
+  470 shape22 :: Polygon
+  471 shape22 = pScale 2 $ mkPolygon $ V.fromList
+  472   [V2 (-0.17) (-0.08)
+  473   ,V2 (-0.34) (-0.21)
+  474   ,V2 0.0 0.0
+  475   ,V2 (-0.10) 0.60
+  476   ,V2 (-0.14) 0.19
+  477   ,V2 (-0.05) 0.03
+  478   ]
+  479 
+  480 shape23 :: Polygon
+  481 shape23 = mkPolygon $ V.fromList
+  482   [ V2 0 0, V2 4 0
+  483   , V2 4 3, V2 2 3
+  484   , V2 2 2, V2 3 2
+  485   , V2 3 1, V2 1 1
+  486   , V2 1 2, V2 2 2
+  487   , V2 2 3, V2 0 3 ]
+  488 
+  489 concave :: Polygon
+  490 concave = mkPolygon $
+  491   V.fromList [V2 0 0, V2 2 0, V2 2 2, V2 1 1, V2 0 2]
+  492 
+  493 pMkWinding :: Int -> Polygon
+  494 pMkWinding n | n < 1 = error "Polygon must have at least one winding."
+  495 pMkWinding n = mkPolygon $
+  496     V.fromList $ p0 : p1 : walkTo p1 1 n (V2 1 0) ++ reverse (walkTo p0 1 (n+2) (V2 (-1) 0))
+  497   where
+  498     p0 = V2 0 0
+  499     p1 = V2 0 1
+  500     walkTo at a b dir
+  501       | a == b = []
+  502       | otherwise =
+  503         let newAt = at + (dir ^* toRational a)
+  504         in newAt : walkTo newAt (a+1) b (rot dir)
+  505     rot (V2 x y) =
+  506       V2 y (-x)
+  507 
+  508 pDeoverlap :: Polygon -> Polygon
+  509 pDeoverlap p = mkPolygon arr
+  510   where
+  511     arr = V.generate (pSize p) worker
+  512     worker 0 = pAccess p 0
+  513     worker n =
+  514       if length (V.elemIndices (pAccess p n) (polygonPoints p)) /= 1
+  515         then
+  516           let prev = arr V.! (n-1)
+  517               this = pAccess p n
+  518           in lerp 0.99999 this prev
+  519         else pAccess p n
+  520 
+  521 pCycles :: APolygon a -> [APolygon a]
+  522 pCycles p = map (pAdjustOffset p) [0 .. pSize p-1]
+  523 
+  524 pCycle :: PolyCtx a => APolygon a -> Double -> APolygon a
+  525 pCycle p 0 = p
+  526 pCycle p t = mkPolygon $ worker 0 0
+  527   where
+  528     worker acc i
+  529       | segment + acc > limit =
+  530         V.singleton (lerp (realToFrac $ (segment + acc - limit)/segment) x y) <>
+  531         -- V.drop (i+1) (polygonPoints p) <>
+  532         V.fromList (map (pAccess p) [i+1..pSize p-1]) <>
+  533         V.fromList (map (pAccess p) [0 .. i])
+  534         -- V.take (i+1) (polygonPoints p)
+  535       | i == pSize p-1  = V.fromList (map (pAccess p) [0 .. pSize p-1])
+  536       | otherwise = worker (acc+segment) (i+1)
+  537         where
+  538           x = pAccess p i
+  539           y = pAccess p $ i+1
+  540           segment = distance' x y
+  541     len = pCircumference' p
+  542     limit = t * len
+  543 
+  544 pCentroid :: Fractional a => APolygon a -> V2 a
+  545 pCentroid p = V2 cx cy
+  546   where
+  547     a = pArea p
+  548     cx = recip (6*a) * V.sum (pMapEdges fnX p)
+  549     cy = recip (6*a) * V.sum (pMapEdges fnY p)
+  550     fnX (V2 x y) (V2 x' y') = (x+x')*(x*y' - x'*y)
+  551     fnY (V2 x y) (V2 x' y') = (y+y')*(x*y' - x'*y)
+  552 
+  553 {-# INLINE pMapEdges #-}
+  554 pMapEdges :: (V2 a -> V2 a -> b) -> APolygon a -> V.Vector b
+  555 pMapEdges fn p = V.generate n $ \i ->
+  556   if i == n-1
+  557     then fn (arr `V.unsafeIndex` i) (arr `V.unsafeIndex` 0)
+  558     else fn (arr `V.unsafeIndex` i) (arr `V.unsafeIndex` (i+1))
+  559   where
+  560     n = pSize p
+  561     arr = polygonPoints p
+  562 
+  563 {-# SPECIALIZE pArea :: APolygon Double -> Double #-}
+  564 {-# SPECIALIZE pArea :: APolygon Rational -> Rational #-}
+  565 pArea :: (Fractional a) => APolygon a -> a
+  566 pArea p =
+  567   -- 0.5 * V.sum (pMapEdges (\(V2 x y) (V2 x' y') -> x*y' - x'*y) p)
+  568   0.5 * worker 0 0
+  569   where
+  570     fn (V2 x y) (V2 x' y') = x*y' - x'*y
+  571     arr = polygonPoints p
+  572     worker !acc i
+  573       | i == pSize p - 1 = acc + fn (arr `V.unsafeIndex` i) (arr `V.unsafeIndex` 0)
+  574       | otherwise =
+  575         worker (acc + fn (arr `V.unsafeIndex` i) (arr `V.unsafeIndex` (i+1))) (i+1)
+  576 
+  577 pCircumference :: (Real a, Fractional a) => APolygon a -> a
+  578 pCircumference p = sum
+  579   [ approxDist (pAccess p i) (pAccess p $ i+1)
+  580   | i <- [0 .. pSize p-1]]
+  581 
+  582 pCircumference' :: (Real a, Fractional a) => APolygon a -> Double
+  583 pCircumference' p = sum
+  584   [ distance' (pAccess p i) (pAccess p $ i+1)
+  585   | i <- [0 .. pSize p-1]]
   586 
-  587 -- Add points by splitting the longest lines in half repeatedly.
-  588 pAddPoints :: PolyCtx a => Int -> APolygon a -> APolygon a
-  589 pAddPoints n p | n <= 0 = p
-  590 pAddPoints n p = pAddPoints (n-1) $
-  591     mkPolygon $ V.fromList $ concatMap worker [0 .. pSize p-1]
-  592   where
-  593     worker idx
-  594       | idx == longestEdge =
-  595         let start = pAccess p idx
-  596             end = pAccess p $ idx+1
-  597             middle = lerp 0.5 end start
-  598         in [start, middle]
-  599       | otherwise = [pAccess p idx]
-  600     longestEdge = maximumBy cmpLength [0 .. pSize p-1]
-  601     cmpLength a b =
-  602       distSquared (pAccess p a) (pAccess p $ a+1) `compare`
-  603       distSquared (pAccess p b) (pAccess p $ b+1)
-  604 
-  605 pAddPointsRestricted :: PolyCtx a => [(V2 a, V2 a)] -> Int -> APolygon a -> APolygon a
-  606 pAddPointsRestricted _immutableEdges n p | n <= 0 = p
-  607 pAddPointsRestricted immutableEdges n p = pAddPointsRestricted immutableEdges (n-1) $
-  608     mkPolygon $ V.fromList $ concatMap worker [0 .. pSize p-1]
-  609   where
-  610     isImmutable idx =
-  611       (pAccess p idx, pAccess p $ idx+1) `elem` immutableEdges ||
-  612       (pAccess p $ idx+1, pAccess p idx) `elem` immutableEdges
-  613     worker idx
-  614       | idx == longestEdge && not (isImmutable idx) =
-  615         let start = pAccess p idx
-  616             end = pAccess p $ idx+1
-  617             middle = lerp 0.5 end start
-  618         in [start, middle]
-  619       | otherwise = [pAccess p idx]
-  620     longestEdge = maximumBy cmpLength [0 .. pSize p-1]
-  621     cmpLength a _ | isImmutable a = LT
-  622     cmpLength _ b | isImmutable b = GT
-  623     cmpLength a b =
-  624       distSquared (pAccess p a) (pAccess p $ a+1) `compare`
-  625       distSquared (pAccess p b) (pAccess p $ b+1)
-  626 
-  627 pAddPointsBetween :: PolyCtx a => (Int, Int) -> Int -> APolygon a -> APolygon a
-  628 pAddPointsBetween _ n p | n <= 0 = p
-  629 pAddPointsBetween (i,l) n p = pAddPointsBetween (i,l+1) (n-1) $
-  630     mkPolygon $ V.fromList $ concatMap worker [0 .. pSize p-1]
-  631   where
-  632     worker idx
-  633       | idx == longestEdge =
-  634         let start = pAccess p idx
-  635             end = pAccess p $ idx+1
-  636             middle = lerp 0.5 end start
-  637         in [start, middle]
-  638       | otherwise = [pAccess p idx]
-  639     longestEdge = maximumBy cmpLength [i .. i+l-1]
-  640     cmpLength a b =
-  641       distSquared (pAccess p a) (pAccess p $ a+1) `compare`
-  642       distSquared (pAccess p b) (pAccess p $ b+1)
-  643 
-  644 -- addPoints :: Int -> Polygon -> Polygon
-  645 -- addPoints n p = mkPolygon $ V.fromList $ worker n 0 (map (pAccess p) [0..s])
-  646 --   where
-  647 --     worker 0 _ rest = init rest
-  648 --     worker i acc (x:y:xs) =
-  649 --       let xy = approxDist x y in
-  650 --       if acc + xy > limit
-  651 --         then x : worker (i-1) 0 (lerp ((limit-acc)/xy) y x : y:xs)
-  652 --         else x : worker i (acc+xy) (y:xs)
-  653 --     worker _ _ [_] = []
-  654 --     worker _ _ _ = error "addPoints: invalid polygon"
-  655 --     s = pSize p
-  656 --     len = polygonLength p
-  657 --     limit = len / fromIntegral (n+1)
-  658 
-  659 pIsConvex :: Polygon -> Bool
-  660 pIsConvex p = and
-  661   [ area2X (pAccess p i) (pAccess p j) (pAccess p k) > 0
-  662   | i <- [0..n-1]
-  663   , j <- [i+1..n-1]
-  664   , k <- [j+1..n-1]
-  665   ]
-  666   where n = pSize p
-  667 
-  668 pIsCCW :: Polygon -> Bool
-  669 pIsCCW p | pNull p = False
-  670 pIsCCW p = V.sum (pMapEdges fn p) < 0
-  671   where
-  672     fn (V2 x1 y1) (V2 x2 y2) = (x2-x1)*(y2+y1)
-  673 
-  674 {-# INLINE pRayIntersect #-}
-  675 pRayIntersect :: PolyCtx a => APolygon a -> (Int, Int) -> (Int,Int) -> Maybe (V2 a)
-  676 pRayIntersect p (a,b) (c,d) =
-  677   rayIntersect (pAccess p a, pAccess p b) (pAccess p c, pAccess p d)
-  678 
-  679 pCuts :: (Real a, Fractional a, Epsilon a) => APolygon a -> [(APolygon a,APolygon a)]
-  680 pCuts p =
-  681   [ pCutAt (pAdjustOffset p i) (j-i)
-  682   | i <- [0 .. pSize p-1 ]
-  683   , j <- [i+2 .. pSize p-1 ]
-  684   , (j+1) `mod` pSize p /= i
-  685   , pParent p i j == i ]
-  686 
-  687 pCutEqual :: PolyCtx a => APolygon a -> (APolygon a, APolygon a)
-  688 pCutEqual p =
-  689     fromMaybe (p,p) $ listToMaybe $ sortOn f $ pCuts p
-  690   where
-  691     f (a,b) = abs (pArea a - pArea b)
-  692 
-  693 -- FIXME: This should be more efficient
-  694 pCutAt :: PolyCtx a => APolygon a -> Int -> (APolygon a, APolygon a)
-  695 pCutAt p i = (mkPolygon $ V.fromList left, mkPolygon $ V.fromList right)
-  696   where
-  697     n     = pSize p
-  698     left  = map (pAccess p) [0 .. i]
-  699     right = map (pAccess p) (0:[i..n-1])
-  700 
-  701 pOverlap :: PolyCtx a => APolygon a -> APolygon a -> APolygon a
-  702 pOverlap a b = mkPolygon $ V.fromList $ clearDups $ concatMap edgeIntersect [0 .. pSize a-1]
-  703   where
-  704     clearDups (x:y:xs)
-  705       | x == y = clearDups (y:xs)
-  706       | otherwise = x : clearDups (y:xs)
-  707     clearDups xs = xs
-  708     edgeIntersect edge =
-  709       sortOn (distSquared (pAccess a edge)) $ catMaybes
-  710       [ lineIntersect (aP, aP') (bP, bP')
-  711       | i <- [0 .. pSize b-1]
-  712       , let aP = pAccess a edge
-  713             aP' = pAccess a (edge+1)
-  714             bP = pAccess b i
-  715             bP' = pAccess b (i+1)
-  716       ]
-  717 
-  718 ---------------------------------------------------------
-  719 -- SSSP visibility and SSSP windows
-  720 
-  721 ssspVisibility :: PolyCtx a => APolygon a -> APolygon a
-  722 ssspVisibility p = mkPolygon $
-  723     V.fromList $ clearDups $ go [0 .. pSize p-1] -- ([root..pSize p-1]  ++ [0 .. root-1])
-  724   where
-  725     clearDups (x:y:xs)
-  726       | x == y = clearDups (y:xs)
-  727       | otherwise = x : clearDups (y:xs)
-  728     clearDups xs = xs
-  729     obstructedBy n =
-  730       case pParent p 0 n of
-  731         0 -> n
-  732         i -> obstructedBy i
-  733     go [] = []
-  734     go [x] = [pAccess p x]
-  735     go (x:y:xs) =
-  736       let xO = obstructedBy x
-  737           yO = obstructedBy y
-  738       in case () of
-  739           ()
-  740             -- Both ends are visible.
-  741             | xO == x && yO == y -> pAccess p x : go (y:xs)
-  742             -- X is visible, x to intersect (0,yO) (x,y)
-  743             | xO == x   ->
-  744               pAccess p x : fromMaybe (pAccess p y) (pRayIntersect p (0,yO) (x,y)) : go (y:xs)
-  745             -- Y is visible
-  746             | yO == y   -> fromMaybe (pAccess p x) (pRayIntersect p (0,xO) (x,y)) : pAccess p y : go (y:xs)
-  747             -- Neither is visible and they've obstructed by the same point
-  748             -- so the entire edge is hidden.
-  749             | xO == yO -> go (y:xs)
-  750             -- Neither is visible. Cast shadow from obstruction points to
-  751             -- find if a subsection of the edge is visible.
-  752             | otherwise ->
-  753               let a = fromMaybe (error "a") (pRayIntersect p (0,xO) (x,y))
-  754                   b = fromMaybe (error "b") (pRayIntersect p (0,yO) (x,y))
-  755               in if a /= b
-  756                 then a : b : go (y:xs)
-  757                 else go (y:xs)
-  758 
-  759 ssspWindows :: Polygon -> [(V2 Rational, V2 Rational)]
-  760 ssspWindows p = clearDups $ go (pAccess p 0) [0..pSize p-1]
-  761   where
-  762     clearDups (x:y:xs)
-  763       | x == y = clearDups (y:xs)
-  764       | otherwise = x : clearDups (y:xs)
-  765     clearDups xs = xs
-  766     obstructedBy n =
-  767       case pParent p 0 n of
-  768         0 -> n
-  769         i -> obstructedBy i
-  770     go _ [] = []
-  771     go _ [_] = []
-  772     go l (x:y:xs) =
-  773       let xO = obstructedBy x
-  774           yO = obstructedBy y
-  775       in case () of
-  776           ()
-  777             -- Both ends are visible.
-  778             | xO == x && yO == y -> go (pAccess p x) (y:xs)
-  779             -- X is visible, x to intersect (0,yO) (x,y)
-  780             | xO == x   ->
-  781               go (fromMaybe (pAccess p y) (pRayIntersect p (0,yO) (x,y))) (y:xs)
-  782             -- Y is visible
-  783             | yO == y   ->
-  784               let newL = fromMaybe (pAccess p x) (pRayIntersect p (0,xO) (x,y)) in
-  785               (l, newL) :
-  786               go newL (y:xs)
-  787             -- Neither is visible and they've obstructed by the same point
-  788             -- so the entire edge is hidden.
-  789             | xO == yO -> go l (y:xs)
-  790             -- Neither is visible. Cast shadow from obstruction points to
-  791             -- find if a subsection of the edge is visible.
-  792             | otherwise ->
-  793               let a = fromMaybe (error "a") (pRayIntersect p (0,xO) (x,y))
-  794                   b = fromMaybe (error "b") (pRayIntersect p (0,yO) (x,y))
-  795               in if a /= b
-  796                 then (l, a) : (b, pAccess p yO) : go (pAccess p yO) (y:xs)
-  797                 else go l (y:xs)
-  798 
-  799 pdualPolygons :: Polygon -> PDual -> [Polygon]
-  800 pdualPolygons p pdual = map mkPolygonFromRing (pdualRings (pRing p) pdual)
+  587 
+  588 -- Add points by splitting the longest lines in half repeatedly.
+  589 pAddPoints :: PolyCtx a => Int -> APolygon a -> APolygon a
+  590 pAddPoints n p | n <= 0 = p
+  591 pAddPoints n p = pAddPoints (n-1) $
+  592     mkPolygon $ V.fromList $ concatMap worker [0 .. pSize p-1]
+  593   where
+  594     worker idx
+  595       | idx == longestEdge =
+  596         let start = pAccess p idx
+  597             end = pAccess p $ idx+1
+  598             middle = lerp 0.5 end start
+  599         in [start, middle]
+  600       | otherwise = [pAccess p idx]
+  601     longestEdge = maximumBy cmpLength [0 .. pSize p-1]
+  602     cmpLength a b =
+  603       distSquared (pAccess p a) (pAccess p $ a+1) `compare`
+  604       distSquared (pAccess p b) (pAccess p $ b+1)
+  605 
+  606 pAddPointsRestricted :: PolyCtx a => [(V2 a, V2 a)] -> Int -> APolygon a -> APolygon a
+  607 pAddPointsRestricted _immutableEdges n p | n <= 0 = p
+  608 pAddPointsRestricted immutableEdges n p = pAddPointsRestricted immutableEdges (n-1) $
+  609     mkPolygon $ V.fromList $ concatMap worker [0 .. pSize p-1]
+  610   where
+  611     isImmutable idx =
+  612       (pAccess p idx, pAccess p $ idx+1) `elem` immutableEdges ||
+  613       (pAccess p $ idx+1, pAccess p idx) `elem` immutableEdges
+  614     worker idx
+  615       | idx == longestEdge && not (isImmutable idx) =
+  616         let start = pAccess p idx
+  617             end = pAccess p $ idx+1
+  618             middle = lerp 0.5 end start
+  619         in [start, middle]
+  620       | otherwise = [pAccess p idx]
+  621     longestEdge = maximumBy cmpLength [0 .. pSize p-1]
+  622     cmpLength a _ | isImmutable a = LT
+  623     cmpLength _ b | isImmutable b = GT
+  624     cmpLength a b =
+  625       distSquared (pAccess p a) (pAccess p $ a+1) `compare`
+  626       distSquared (pAccess p b) (pAccess p $ b+1)
+  627 
+  628 pAddPointsBetween :: PolyCtx a => (Int, Int) -> Int -> APolygon a -> APolygon a
+  629 pAddPointsBetween _ n p | n <= 0 = p
+  630 pAddPointsBetween (i,l) n p = pAddPointsBetween (i,l+1) (n-1) $
+  631     mkPolygon $ V.fromList $ concatMap worker [0 .. pSize p-1]
+  632   where
+  633     worker idx
+  634       | idx == longestEdge =
+  635         let start = pAccess p idx
+  636             end = pAccess p $ idx+1
+  637             middle = lerp 0.5 end start
+  638         in [start, middle]
+  639       | otherwise = [pAccess p idx]
+  640     longestEdge = maximumBy cmpLength [i .. i+l-1]
+  641     cmpLength a b =
+  642       distSquared (pAccess p a) (pAccess p $ a+1) `compare`
+  643       distSquared (pAccess p b) (pAccess p $ b+1)
+  644 
+  645 -- addPoints :: Int -> Polygon -> Polygon
+  646 -- addPoints n p = mkPolygon $ V.fromList $ worker n 0 (map (pAccess p) [0..s])
+  647 --   where
+  648 --     worker 0 _ rest = init rest
+  649 --     worker i acc (x:y:xs) =
+  650 --       let xy = approxDist x y in
+  651 --       if acc + xy > limit
+  652 --         then x : worker (i-1) 0 (lerp ((limit-acc)/xy) y x : y:xs)
+  653 --         else x : worker i (acc+xy) (y:xs)
+  654 --     worker _ _ [_] = []
+  655 --     worker _ _ _ = error "addPoints: invalid polygon"
+  656 --     s = pSize p
+  657 --     len = polygonLength p
+  658 --     limit = len / fromIntegral (n+1)
+  659 
+  660 pIsConvex :: Polygon -> Bool
+  661 pIsConvex p = and
+  662   [ area2X (pAccess p i) (pAccess p j) (pAccess p k) > 0
+  663   | i <- [0..n-1]
+  664   , j <- [i+1..n-1]
+  665   , k <- [j+1..n-1]
+  666   ]
+  667   where n = pSize p
+  668 
+  669 pIsCCW :: Polygon -> Bool
+  670 pIsCCW p | pNull p = False
+  671 pIsCCW p = V.sum (pMapEdges fn p) < 0
+  672   where
+  673     fn (V2 x1 y1) (V2 x2 y2) = (x2-x1)*(y2+y1)
+  674 
+  675 {-# INLINE pRayIntersect #-}
+  676 pRayIntersect :: PolyCtx a => APolygon a -> (Int, Int) -> (Int,Int) -> Maybe (V2 a)
+  677 pRayIntersect p (a,b) (c,d) =
+  678   rayIntersect (pAccess p a, pAccess p b) (pAccess p c, pAccess p d)
+  679 
+  680 pCuts :: (Real a, Fractional a, Epsilon a) => APolygon a -> [(APolygon a,APolygon a)]
+  681 pCuts p =
+  682   [ pCutAt (pAdjustOffset p i) (j-i)
+  683   | i <- [0 .. pSize p-1 ]
+  684   , j <- [i+2 .. pSize p-1 ]
+  685   , (j+1) `mod` pSize p /= i
+  686   , pParent p i j == i ]
+  687 
+  688 pCutEqual :: PolyCtx a => APolygon a -> (APolygon a, APolygon a)
+  689 pCutEqual p =
+  690     fromMaybe (p,p) $ listToMaybe $ sortOn f $ pCuts p
+  691   where
+  692     f (a,b) = abs (pArea a - pArea b)
+  693 
+  694 -- FIXME: This should be more efficient
+  695 pCutAt :: PolyCtx a => APolygon a -> Int -> (APolygon a, APolygon a)
+  696 pCutAt p i = (mkPolygon $ V.fromList left, mkPolygon $ V.fromList right)
+  697   where
+  698     n     = pSize p
+  699     left  = map (pAccess p) [0 .. i]
+  700     right = map (pAccess p) (0:[i..n-1])
+  701 
+  702 pOverlap :: PolyCtx a => APolygon a -> APolygon a -> APolygon a
+  703 pOverlap a b = mkPolygon $ V.fromList $ clearDups $ concatMap edgeIntersect [0 .. pSize a-1]
+  704   where
+  705     clearDups (x:y:xs)
+  706       | x == y = clearDups (y:xs)
+  707       | otherwise = x : clearDups (y:xs)
+  708     clearDups xs = xs
+  709     edgeIntersect edge =
+  710       sortOn (distSquared (pAccess a edge)) $ catMaybes
+  711       [ lineIntersect (aP, aP') (bP, bP')
+  712       | i <- [0 .. pSize b-1]
+  713       , let aP = pAccess a edge
+  714             aP' = pAccess a (edge+1)
+  715             bP = pAccess b i
+  716             bP' = pAccess b (i+1)
+  717       ]
+  718 
+  719 ---------------------------------------------------------
+  720 -- SSSP visibility and SSSP windows
+  721 
+  722 ssspVisibility :: PolyCtx a => APolygon a -> APolygon a
+  723 ssspVisibility p = mkPolygon $
+  724     V.fromList $ clearDups $ go [0 .. pSize p-1] -- ([root..pSize p-1]  ++ [0 .. root-1])
+  725   where
+  726     clearDups (x:y:xs)
+  727       | x == y = clearDups (y:xs)
+  728       | otherwise = x : clearDups (y:xs)
+  729     clearDups xs = xs
+  730     obstructedBy n =
+  731       case pParent p 0 n of
+  732         0 -> n
+  733         i -> obstructedBy i
+  734     go [] = []
+  735     go [x] = [pAccess p x]
+  736     go (x:y:xs) =
+  737       let xO = obstructedBy x
+  738           yO = obstructedBy y
+  739       in case () of
+  740           ()
+  741             -- Both ends are visible.
+  742             | xO == x && yO == y -> pAccess p x : go (y:xs)
+  743             -- X is visible, x to intersect (0,yO) (x,y)
+  744             | xO == x   ->
+  745               pAccess p x : fromMaybe (pAccess p y) (pRayIntersect p (0,yO) (x,y)) : go (y:xs)
+  746             -- Y is visible
+  747             | yO == y   -> fromMaybe (pAccess p x) (pRayIntersect p (0,xO) (x,y)) : pAccess p y : go (y:xs)
+  748             -- Neither is visible and they've obstructed by the same point
+  749             -- so the entire edge is hidden.
+  750             | xO == yO -> go (y:xs)
+  751             -- Neither is visible. Cast shadow from obstruction points to
+  752             -- find if a subsection of the edge is visible.
+  753             | otherwise ->
+  754               let a = fromMaybe (error "a") (pRayIntersect p (0,xO) (x,y))
+  755                   b = fromMaybe (error "b") (pRayIntersect p (0,yO) (x,y))
+  756               in if a /= b
+  757                 then a : b : go (y:xs)
+  758                 else go (y:xs)
+  759 
+  760 ssspWindows :: Polygon -> [(V2 Rational, V2 Rational)]
+  761 ssspWindows p = clearDups $ go (pAccess p 0) [0..pSize p-1]
+  762   where
+  763     clearDups (x:y:xs)
+  764       | x == y = clearDups (y:xs)
+  765       | otherwise = x : clearDups (y:xs)
+  766     clearDups xs = xs
+  767     obstructedBy n =
+  768       case pParent p 0 n of
+  769         0 -> n
+  770         i -> obstructedBy i
+  771     go _ [] = []
+  772     go _ [_] = []
+  773     go l (x:y:xs) =
+  774       let xO = obstructedBy x
+  775           yO = obstructedBy y
+  776       in case () of
+  777           ()
+  778             -- Both ends are visible.
+  779             | xO == x && yO == y -> go (pAccess p x) (y:xs)
+  780             -- X is visible, x to intersect (0,yO) (x,y)
+  781             | xO == x   ->
+  782               go (fromMaybe (pAccess p y) (pRayIntersect p (0,yO) (x,y))) (y:xs)
+  783             -- Y is visible
+  784             | yO == y   ->
+  785               let newL = fromMaybe (pAccess p x) (pRayIntersect p (0,xO) (x,y)) in
+  786               (l, newL) :
+  787               go newL (y:xs)
+  788             -- Neither is visible and they've obstructed by the same point
+  789             -- so the entire edge is hidden.
+  790             | xO == yO -> go l (y:xs)
+  791             -- Neither is visible. Cast shadow from obstruction points to
+  792             -- find if a subsection of the edge is visible.
+  793             | otherwise ->
+  794               let a = fromMaybe (error "a") (pRayIntersect p (0,xO) (x,y))
+  795                   b = fromMaybe (error "b") (pRayIntersect p (0,yO) (x,y))
+  796               in if a /= b
+  797                 then (l, a) : (b, pAccess p yO) : go (pAccess p yO) (y:xs)
+  798                 else go l (y:xs)
+  799 
+  800 pdualPolygons :: Polygon -> PDual -> [Polygon]
+  801 pdualPolygons p pdual = map mkPolygonFromRing (pdualRings (pRing p) pdual)
diff --git a/reanimate-0.4.1.0-inplace/Reanimate.Math.SSSP.hs.html b/reanimate-0.4.1.0-inplace/Reanimate.Math.SSSP.hs.html index 914f97a..4ff5029 100644 --- a/reanimate-0.4.1.0-inplace/Reanimate.Math.SSSP.hs.html +++ b/reanimate-0.4.1.0-inplace/Reanimate.Math.SSSP.hs.html @@ -20,345 +20,346 @@ span.spaces { background: white } 1 {-# LANGUAGE FlexibleInstances #-} 2 {-# LANGUAGE MultiParamTypeClasses #-} 3 {-# OPTIONS_GHC -fno-warn-orphans #-} - 4 module Reanimate.Math.SSSP - 5 ( -- * Single-Source-Shortest-Path - 6 SSSP - 7 , sssp -- :: (Fractional a, Ord a) => Ring a -> Dual -> SSSP - 8 , dual -- :: Int -> Triangulation -> Dual - 9 , Dual(..) - 10 , DualTree(..) - 11 , PDual - 12 , toPDual -- :: Ring Rational -> Dual -> PDual - 13 , pdualRings -- :: Ring Rational -> PDual -> [Ring Rational] - 14 -- * Misc - 15 , dualToTriangulation -- :: Ring Rational -> Dual -> Triangulation - 16 , pdualReduce -- :: Ring Rational -> PDual -> Int -> PDual - 17 , visibilityArray -- :: Ring Rational -> V.Vector [Int] - 18 , naive -- :: Ring Rational -> SSSP - 19 , naive2 -- :: Ring Rational -> SSSP - 20 , drawDual -- :: Dual -> String - 21 ) where - 22 - 23 import Control.Monad - 24 -- import Control.Exception - 25 import Control.Monad.ST - 26 -- import Data.FingerTree (SearchResult (..), (|>)) - 27 -- import qualified Data.FingerTree as F - 28 import Data.Foldable - 29 import Data.List - 30 import qualified Data.Map as Map - 31 import Data.Maybe - 32 import Data.Ord - 33 import Data.STRef - 34 import Data.Tree - 35 import qualified Data.Vector as V - 36 import qualified Data.Vector.Mutable as MV - 37 import Reanimate.Math.Common - 38 import Reanimate.Math.Triangulate - 39 - 40 -- import Debug.Trace - 41 - 42 type SSSP = V.Vector Int - 43 + 4 {-# OPTIONS_HADDOCK hide #-} + 5 module Reanimate.Math.SSSP + 6 ( -- * Single-Source-Shortest-Path + 7 SSSP + 8 , sssp -- :: (Fractional a, Ord a) => Ring a -> Dual -> SSSP + 9 , dual -- :: Int -> Triangulation -> Dual + 10 , Dual(..) + 11 , DualTree(..) + 12 , PDual + 13 , toPDual -- :: Ring Rational -> Dual -> PDual + 14 , pdualRings -- :: Ring Rational -> PDual -> [Ring Rational] + 15 -- * Misc + 16 , dualToTriangulation -- :: Ring Rational -> Dual -> Triangulation + 17 , pdualReduce -- :: Ring Rational -> PDual -> Int -> PDual + 18 , visibilityArray -- :: Ring Rational -> V.Vector [Int] + 19 , naive -- :: Ring Rational -> SSSP + 20 , naive2 -- :: Ring Rational -> SSSP + 21 , drawDual -- :: Dual -> String + 22 ) where + 23 + 24 import Control.Monad + 25 -- import Control.Exception + 26 import Control.Monad.ST + 27 -- import Data.FingerTree (SearchResult (..), (|>)) + 28 -- import qualified Data.FingerTree as F + 29 import Data.Foldable + 30 import Data.List + 31 import qualified Data.Map as Map + 32 import Data.Maybe + 33 import Data.Ord + 34 import Data.STRef + 35 import Data.Tree + 36 import qualified Data.Vector as V + 37 import qualified Data.Vector.Mutable as MV + 38 import Reanimate.Math.Common + 39 import Reanimate.Math.Triangulate + 40 + 41 -- import Debug.Trace + 42 + 43 type SSSP = V.Vector Int 44 - 45 -- ssspParent :: Polygon -> SSSP -> Int -> Int - 46 -- ssspParent p sTree x = - 47 -- (sTree V.! ((x - polygonOffset p) `mod` n) + polygonOffset p) `mod` n - 48 -- where - 49 -- n = polygonSize p - 50 - 51 visibilityArray :: Ring Rational -> V.Vector [Int] - 52 visibilityArray p = arr - 53 where - 54 n = ringSize p - 55 arr = V.fromList - 56 [ visibility y - 57 | y <- [0..n-1] - 58 ] - 59 visibility y = - 60 [ i - 61 | i <- [0..y-1] - 62 , y `elem` arr V.! i ] ++ - 63 [ i - 64 | i <- [y+1 .. n-1] - 65 , let pI = ringAccess p i - 66 isOpen = isRightTurn pYp pY pYn - 67 , ringClamp p (y+1) == i || ringClamp p (y-1) == i || if isOpen - 68 then isLeftTurnOrLinear pY pYn pI || - 69 isLeftTurnOrLinear pYp pY pI - 70 else not $ isRightTurn pY pYn pI || - 71 isRightTurn pYp pY pI - 72 , let myEdges = [(e1,e2) | (e1,e2) <- edges, e1/=y, e1/=i, e2/=y,e2/=i] - 73 , all (isNothing . lineIntersect (pY,pI)) - 74 [ (ringAccess p e1, ringAccess p e2) | (e1,e2) <- myEdges ]] - 75 where - 76 pY = ringAccess p y - 77 pYn = ringAccess p $ y+1 - 78 pYp = ringAccess p $ y-1 - 79 edges = zip [0..n-1] (tail [0..n-1] ++ [0]) - 80 + 45 + 46 -- ssspParent :: Polygon -> SSSP -> Int -> Int + 47 -- ssspParent p sTree x = + 48 -- (sTree V.! ((x - polygonOffset p) `mod` n) + polygonOffset p) `mod` n + 49 -- where + 50 -- n = polygonSize p + 51 + 52 visibilityArray :: Ring Rational -> V.Vector [Int] + 53 visibilityArray p = arr + 54 where + 55 n = ringSize p + 56 arr = V.fromList + 57 [ visibility y + 58 | y <- [0..n-1] + 59 ] + 60 visibility y = + 61 [ i + 62 | i <- [0..y-1] + 63 , y `elem` arr V.! i ] ++ + 64 [ i + 65 | i <- [y+1 .. n-1] + 66 , let pI = ringAccess p i + 67 isOpen = isRightTurn pYp pY pYn + 68 , ringClamp p (y+1) == i || ringClamp p (y-1) == i || if isOpen + 69 then isLeftTurnOrLinear pY pYn pI || + 70 isLeftTurnOrLinear pYp pY pI + 71 else not $ isRightTurn pY pYn pI || + 72 isRightTurn pYp pY pI + 73 , let myEdges = [(e1,e2) | (e1,e2) <- edges, e1/=y, e1/=i, e2/=y,e2/=i] + 74 , all (isNothing . lineIntersect (pY,pI)) + 75 [ (ringAccess p e1, ringAccess p e2) | (e1,e2) <- myEdges ]] + 76 where + 77 pY = ringAccess p y + 78 pYn = ringAccess p $ y+1 + 79 pYp = ringAccess p $ y-1 + 80 edges = zip [0..n-1] (tail [0..n-1] ++ [0]) 81 82 - 83 -- Iterative Single Source Shortest Path solver. Quite slow. - 84 naive :: Ring Rational -> SSSP - 85 naive p = - 86 V.fromList $ Map.elems $ - 87 Map.map snd $ - 88 worker initial - 89 where - 90 initial = Map.singleton 0 (0,0) - 91 visibility = visibilityArray p - 92 worker :: Map.Map Int (Rational, Int) -> Map.Map Int (Rational, Int) - 93 worker m - 94 | m==newM = newM - 95 | otherwise = worker newM - 96 where - 97 ms' = [ Map.fromList - 98 [ case Map.lookup v m of - 99 Nothing -> (v, (distThroughI, i)) - 100 Just (otherDist,parent) - 101 | otherDist > distThroughI -> (v, (distThroughI, i)) - 102 | otherwise -> (v, (otherDist, parent)) - 103 | v <- visibility V.! i - 104 , let distThroughI = dist + approxDist (ringAccess p i) (ringAccess p v) ] - 105 | (i,(dist,_)) <- Map.toList m - 106 ] - 107 newM = Map.unionsWith g (m:ms') :: Map.Map Int (Rational,Int) - 108 g a b = if fst a < fst b then a else b - 109 - 110 naive2 :: Ring Rational -> SSSP - 111 naive2 p = runST $ do - 112 parents <- MV.replicate (ringSize p) (-1) - 113 costs <- MV.replicate (ringSize p) (-1) - 114 MV.write parents 0 0 - 115 MV.write costs 0 0 - 116 changedRef <- newSTRef False - 117 let loop i - 118 | i == ringSize p = do - 119 changed <- readSTRef changedRef - 120 when changed $ do - 121 writeSTRef changedRef False - 122 loop 0 - 123 | otherwise = do - 124 myCost <- MV.read costs i - 125 unless (myCost < 0) $ - 126 forM_ (visibility V.! i) $ \n -> do - 127 -- n is visible from i. - 128 theirCost <- MV.read costs n - 129 let throughCost = myCost + approxDist (ringAccess p i) (ringAccess p n) - 130 when (throughCost < theirCost || theirCost < 0) $ do - 131 MV.write parents n i - 132 MV.write costs n throughCost - 133 writeSTRef changedRef True - 134 loop (i+1) - 135 loop 0 - 136 V.unsafeFreeze parents - 137 where - 138 visibility = visibilityArray p - 139 - 140 data PDual = PDual (V.Vector Int) Rational [PDual] - 141 deriving (Show) - 142 - 143 toPDual :: Ring Rational -> Dual -> PDual - 144 toPDual p d = - 145 case d of - 146 Dual (a,b,c) l r -> - 147 PDual (V.fromList [a,b,c]) - 148 (area2X (ringAccess p a) (ringAccess p b) (ringAccess p c)) - 149 (catMaybes [ worker c a l, worker b c r]) - 150 where - 151 worker _ _ EmptyDual = Nothing - 152 worker a b (NodeDual x l r) = Just $ - 153 PDual (V.fromList [a,x,b]) - 154 (area2X (ringAccess p a) (ringAccess p x) (ringAccess p b)) - 155 (catMaybes [ worker x b l, worker a x r]) - 156 - 157 pdualSize :: PDual -> Int - 158 pdualSize (PDual _ _ children) = 1 + sum (map pdualSize children) - 159 - 160 pdualArea :: PDual -> Rational - 161 pdualArea (PDual _ faceArea _) = faceArea - 162 - 163 -- FIXME: 'origin' isn't used. Remove. - 164 pdualReduce :: Ring Rational -> PDual -> Int -> PDual - 165 pdualReduce origin pdual n - 166 | pdualSize pdual <= n = pdual - 167 | otherwise = - 168 let smallest = minimum $ pAreas pdual - 169 in pdualReduce origin (merge smallest pdual) n - 170 where - 171 merge _s (PDual p faceArea []) = PDual p faceArea [] - 172 merge s (PDual p faceArea children) - 173 | faceArea == s = - 174 let (PDual p2 area2 children2:xs) = sortBy (comparing pdualArea) children - 175 in PDual (joinP p p2) (faceArea+area2) (children2++xs) - 176 | otherwise = - 177 let (PDual p2 area2 children2:xs) = sortBy (comparing pdualArea) children - 178 in if area2 == s - 179 then PDual (joinP p p2) (faceArea+area2) (children2++xs) - 180 else PDual p faceArea (map (merge s) children) - 181 pAreas (PDual _ faceArea children) = faceArea : concatMap pAreas children - 182 joinP a b = V.fromList (sort (V.toList a ++ V.toList b)) - 183 - 184 pdualRings :: Ring Rational -> PDual -> [Ring Rational] - 185 pdualRings p (PDual pts _area children) = - 186 ringPack (V.map (ringAccess p) pts) : concatMap (pdualRings p) children - 187 - 188 -- Dual of triangulated polygon - 189 data Dual = Dual (Int,Int,Int) -- (a,b,c) - 190 DualTree -- borders ca - 191 DualTree -- borders bc - 192 deriving (Show) - 193 - 194 data DualTree - 195 = EmptyDual - 196 | NodeDual Int -- axb triangle, a and b are from parent. - 197 DualTree -- borders xb - 198 DualTree -- borders ax - 199 deriving (Show) - 200 - 201 drawDual :: Dual -> String - 202 drawDual d = drawTree $ - 203 case d of - 204 Dual (a,b,c) l r -> Node (show (a,b,c)) [worker c a l, worker b c r] - 205 where - 206 worker _a _b EmptyDual = Node "Leaf" [] - 207 worker a b (NodeDual x l r) = - 208 Node (show (b,a,x)) [worker x b l, worker a x r] - 209 - 210 dualToTriangulation :: Ring Rational -> Dual -> Triangulation - 211 dualToTriangulation p d = edgesToTriangulation (ringSize p) $ filter goodEdge $ - 212 case d of - 213 Dual (a,b,c) l r -> - 214 (a,b):(a,c):(b,c):worker c a l ++ worker b c r - 215 where - 216 goodEdge (a,b) - 217 = a /= ringClamp p (b+1) && a /= ringClamp p (b-1) - 218 worker _a _b EmptyDual = [] - 219 worker a b (NodeDual x l r) = - 220 (a,x) : (x, b) : worker x b l ++ worker a x r - 221 - 222 -- Dual path: - 223 -- (Int,Int,Int) + V.Vector Int + V.Vector LeftOrRight - 224 - 225 -- simplifyDual :: DualTree -> DualTree - 226 -- -- simplifyDual (NodeDual x EmptyDual EmptyDual) = NodeLeaf x - 227 -- -- simplifyDual (NodeDual x l EmptyDual) = NodeDualL x l - 228 -- -- simplifyDual (NodeDual x EmptyDual r) = NodeDualR x r - 229 -- simplifyDual d = d - 230 - 231 dual :: Int -> Triangulation -> Dual - 232 dual root t = - 233 case hasTriangle of - 234 [] -> error "weird triangulation" - 235 -- [] -> Dual (0,1,V.length t-1) EmptyDual (dualTree t (1, (V.length t-1)) 0) - 236 (x:_) -> Dual (root,rootNext,x) (dualTree t (x,root) rootNext) (dualTree t (rootNext,x) root) - 237 where - 238 rootNext = idx (root+1) - 239 rootPrev = idx (root-1) - 240 rootNNext = idx (root+2) - 241 idx i = i `mod` n - 242 hasTriangle = (rootPrev : t V.! root) `intersect` (rootNNext : t V.! rootNext) - 243 n = V.length t - 244 - 245 -- a=6, b=0, e=1 - 246 dualTree :: Triangulation -> (Int,Int) -> Int -> DualTree - 247 dualTree t (a,b) e = -- simplifyDual $ - 248 case hasTriangle of - 249 [] -> EmptyDual - 250 [(ab)] -> - 251 NodeDual ab - 252 (dualTree t (ab,b) a) - 253 (dualTree t (a,ab) b) - 254 _ -> error $ "Invalid triangulation: " ++ show (a,b,e,hasTriangle) - 255 where - 256 hasTriangle = (prev a : next a : t V.! a) `intersect` (prev b : next b : t V.! b) - 257 \\ [e] - 258 n = V.length t - 259 next x = (x+1) `mod` n - 260 prev x = (x-1) `mod` n - 261 - 262 -- data MinMax = MinMax Int Int | MinMaxEmpty deriving (Show) - 263 -- instance Semigroup MinMax where - 264 -- MinMaxEmpty <> b = b - 265 -- a <> MinMaxEmpty = a - 266 -- MinMax a b <> MinMax c d - 267 -- = MinMax (min a c) (max b d) - 268 -- -- = MinMax c b - 269 -- instance Monoid MinMax where - 270 -- mempty = MinMaxEmpty - 271 -- - 272 -- instance F.Measured MinMax Int where - 273 -- measure i = MinMax i i - 274 - 275 -- dualRoot :: Dual -> Int - 276 -- dualRoot (Dual (a,_,_) _ _) = a - 277 - 278 -- O(n*ln n), could be O(n) if I could figure out how to use fingertrees... - 279 sssp :: (Fractional a, Ord a, Epsilon a) => Ring a -> Dual -> SSSP - 280 sssp p d = toSSSP $ - 281 case d of - 282 Dual (a,b,c) l r -> - 283 (a, a) : - 284 (b, a) : - 285 (c, a) : - 286 worker [c] [b] a r ++ - 287 loopLeft a c l - 288 where - 289 toSSSP edges = - 290 (V.fromList . map snd . sortOn fst) edges - 291 loopLeft a outer l = - 292 case l of - 293 EmptyDual -> [] - 294 NodeDual x l' r' -> - 295 (x,a) : - 296 worker [x] [outer] a r' ++ - 297 loopLeft a x l' - 298 searchFn _checkStep _cusp _x [] = Nothing - 299 searchFn checkStep cusp x (y:ys) - 300 | not (checkStep (ringAccess p cusp) (ringAccess p y) (ringAccess p x)) - 301 = Just $ helper [] y ys - 302 | otherwise = Nothing - 303 where - 304 helper acc v [] = (v, [], reverse acc) - 305 helper acc v1 (v2:vs) - 306 | checkStep (ringAccess p v1) (ringAccess p v2) (ringAccess p x) = - 307 (v1, v2:vs, reverse acc) - 308 | otherwise = helper (v1:acc) v2 vs - 309 searchRight = searchFn isLeftTurn - 310 searchLeft = searchFn isRightTurn - 311 -- adj x = x -- ringClamp p (x-dualRoot d) - 312 -- optTrace msg = - 313 -- if False -- dualRoot d == 1 || dualRoot d == 0 - 314 -- then trace msg - 315 -- else id - 316 worker _ _ _ EmptyDual = [] - 317 worker f1 f2 cusp (NodeDual x l r) = - 318 -- (optTrace ("Funnel: " ++ show - 319 -- (map adj $ toList f1 - 320 -- ,adj cusp - 321 -- ,map adj $ toList f2 - 322 -- ,adj x - 323 -- , dualRoot d)) - 324 -- ) $ - 325 case searchLeft cusp x (toList f1) of - 326 Just (v, f1Hi, f1Lo) -> - 327 -- optTrace (" Visble from left: " ++ show (adj x,adj v)) $ - 328 (x, v::Int) : - 329 worker f1Hi [x] v l ++ - 330 worker (f1Lo ++ [v, x]) f2 cusp r - 331 Nothing -> - 332 case searchRight cusp x (toList f2) of - 333 Just (v, f2Hi, f2Lo) -> - 334 -- optTrace (" Visble from right: " ++ show (adj x,adj v)) $ - 335 (x, v::Int) : - 336 worker f1 (f2Lo ++ [v, x]) cusp l ++ - 337 worker [x] f2Hi v r - 338 Nothing -> - 339 -- optTrace (" Visble from cusp: " ++ show (adj x,adj cusp)) $ - 340 (x, cusp::Int) : - 341 worker f1 [x] cusp l ++ - 342 worker [x] f2 cusp r + 83 + 84 -- Iterative Single Source Shortest Path solver. Quite slow. + 85 naive :: Ring Rational -> SSSP + 86 naive p = + 87 V.fromList $ Map.elems $ + 88 Map.map snd $ + 89 worker initial + 90 where + 91 initial = Map.singleton 0 (0,0) + 92 visibility = visibilityArray p + 93 worker :: Map.Map Int (Rational, Int) -> Map.Map Int (Rational, Int) + 94 worker m + 95 | m==newM = newM + 96 | otherwise = worker newM + 97 where + 98 ms' = [ Map.fromList + 99 [ case Map.lookup v m of + 100 Nothing -> (v, (distThroughI, i)) + 101 Just (otherDist,parent) + 102 | otherDist > distThroughI -> (v, (distThroughI, i)) + 103 | otherwise -> (v, (otherDist, parent)) + 104 | v <- visibility V.! i + 105 , let distThroughI = dist + approxDist (ringAccess p i) (ringAccess p v) ] + 106 | (i,(dist,_)) <- Map.toList m + 107 ] + 108 newM = Map.unionsWith g (m:ms') :: Map.Map Int (Rational,Int) + 109 g a b = if fst a < fst b then a else b + 110 + 111 naive2 :: Ring Rational -> SSSP + 112 naive2 p = runST $ do + 113 parents <- MV.replicate (ringSize p) (-1) + 114 costs <- MV.replicate (ringSize p) (-1) + 115 MV.write parents 0 0 + 116 MV.write costs 0 0 + 117 changedRef <- newSTRef False + 118 let loop i + 119 | i == ringSize p = do + 120 changed <- readSTRef changedRef + 121 when changed $ do + 122 writeSTRef changedRef False + 123 loop 0 + 124 | otherwise = do + 125 myCost <- MV.read costs i + 126 unless (myCost < 0) $ + 127 forM_ (visibility V.! i) $ \n -> do + 128 -- n is visible from i. + 129 theirCost <- MV.read costs n + 130 let throughCost = myCost + approxDist (ringAccess p i) (ringAccess p n) + 131 when (throughCost < theirCost || theirCost < 0) $ do + 132 MV.write parents n i + 133 MV.write costs n throughCost + 134 writeSTRef changedRef True + 135 loop (i+1) + 136 loop 0 + 137 V.unsafeFreeze parents + 138 where + 139 visibility = visibilityArray p + 140 + 141 data PDual = PDual (V.Vector Int) Rational [PDual] + 142 deriving (Show) + 143 + 144 toPDual :: Ring Rational -> Dual -> PDual + 145 toPDual p d = + 146 case d of + 147 Dual (a,b,c) l r -> + 148 PDual (V.fromList [a,b,c]) + 149 (area2X (ringAccess p a) (ringAccess p b) (ringAccess p c)) + 150 (catMaybes [ worker c a l, worker b c r]) + 151 where + 152 worker _ _ EmptyDual = Nothing + 153 worker a b (NodeDual x l r) = Just $ + 154 PDual (V.fromList [a,x,b]) + 155 (area2X (ringAccess p a) (ringAccess p x) (ringAccess p b)) + 156 (catMaybes [ worker x b l, worker a x r]) + 157 + 158 pdualSize :: PDual -> Int + 159 pdualSize (PDual _ _ children) = 1 + sum (map pdualSize children) + 160 + 161 pdualArea :: PDual -> Rational + 162 pdualArea (PDual _ faceArea _) = faceArea + 163 + 164 -- FIXME: 'origin' isn't used. Remove. + 165 pdualReduce :: Ring Rational -> PDual -> Int -> PDual + 166 pdualReduce origin pdual n + 167 | pdualSize pdual <= n = pdual + 168 | otherwise = + 169 let smallest = minimum $ pAreas pdual + 170 in pdualReduce origin (merge smallest pdual) n + 171 where + 172 merge _s (PDual p faceArea []) = PDual p faceArea [] + 173 merge s (PDual p faceArea children) + 174 | faceArea == s = + 175 let (PDual p2 area2 children2:xs) = sortBy (comparing pdualArea) children + 176 in PDual (joinP p p2) (faceArea+area2) (children2++xs) + 177 | otherwise = + 178 let (PDual p2 area2 children2:xs) = sortBy (comparing pdualArea) children + 179 in if area2 == s + 180 then PDual (joinP p p2) (faceArea+area2) (children2++xs) + 181 else PDual p faceArea (map (merge s) children) + 182 pAreas (PDual _ faceArea children) = faceArea : concatMap pAreas children + 183 joinP a b = V.fromList (sort (V.toList a ++ V.toList b)) + 184 + 185 pdualRings :: Ring Rational -> PDual -> [Ring Rational] + 186 pdualRings p (PDual pts _area children) = + 187 ringPack (V.map (ringAccess p) pts) : concatMap (pdualRings p) children + 188 + 189 -- Dual of triangulated polygon + 190 data Dual = Dual (Int,Int,Int) -- (a,b,c) + 191 DualTree -- borders ca + 192 DualTree -- borders bc + 193 deriving (Show) + 194 + 195 data DualTree + 196 = EmptyDual + 197 | NodeDual Int -- axb triangle, a and b are from parent. + 198 DualTree -- borders xb + 199 DualTree -- borders ax + 200 deriving (Show) + 201 + 202 drawDual :: Dual -> String + 203 drawDual d = drawTree $ + 204 case d of + 205 Dual (a,b,c) l r -> Node (show (a,b,c)) [worker c a l, worker b c r] + 206 where + 207 worker _a _b EmptyDual = Node "Leaf" [] + 208 worker a b (NodeDual x l r) = + 209 Node (show (b,a,x)) [worker x b l, worker a x r] + 210 + 211 dualToTriangulation :: Ring Rational -> Dual -> Triangulation + 212 dualToTriangulation p d = edgesToTriangulation (ringSize p) $ filter goodEdge $ + 213 case d of + 214 Dual (a,b,c) l r -> + 215 (a,b):(a,c):(b,c):worker c a l ++ worker b c r + 216 where + 217 goodEdge (a,b) + 218 = a /= ringClamp p (b+1) && a /= ringClamp p (b-1) + 219 worker _a _b EmptyDual = [] + 220 worker a b (NodeDual x l r) = + 221 (a,x) : (x, b) : worker x b l ++ worker a x r + 222 + 223 -- Dual path: + 224 -- (Int,Int,Int) + V.Vector Int + V.Vector LeftOrRight + 225 + 226 -- simplifyDual :: DualTree -> DualTree + 227 -- -- simplifyDual (NodeDual x EmptyDual EmptyDual) = NodeLeaf x + 228 -- -- simplifyDual (NodeDual x l EmptyDual) = NodeDualL x l + 229 -- -- simplifyDual (NodeDual x EmptyDual r) = NodeDualR x r + 230 -- simplifyDual d = d + 231 + 232 dual :: Int -> Triangulation -> Dual + 233 dual root t = + 234 case hasTriangle of + 235 [] -> error "weird triangulation" + 236 -- [] -> Dual (0,1,V.length t-1) EmptyDual (dualTree t (1, (V.length t-1)) 0) + 237 (x:_) -> Dual (root,rootNext,x) (dualTree t (x,root) rootNext) (dualTree t (rootNext,x) root) + 238 where + 239 rootNext = idx (root+1) + 240 rootPrev = idx (root-1) + 241 rootNNext = idx (root+2) + 242 idx i = i `mod` n + 243 hasTriangle = (rootPrev : t V.! root) `intersect` (rootNNext : t V.! rootNext) + 244 n = V.length t + 245 + 246 -- a=6, b=0, e=1 + 247 dualTree :: Triangulation -> (Int,Int) -> Int -> DualTree + 248 dualTree t (a,b) e = -- simplifyDual $ + 249 case hasTriangle of + 250 [] -> EmptyDual + 251 [(ab)] -> + 252 NodeDual ab + 253 (dualTree t (ab,b) a) + 254 (dualTree t (a,ab) b) + 255 _ -> error $ "Invalid triangulation: " ++ show (a,b,e,hasTriangle) + 256 where + 257 hasTriangle = (prev a : next a : t V.! a) `intersect` (prev b : next b : t V.! b) + 258 \\ [e] + 259 n = V.length t + 260 next x = (x+1) `mod` n + 261 prev x = (x-1) `mod` n + 262 + 263 -- data MinMax = MinMax Int Int | MinMaxEmpty deriving (Show) + 264 -- instance Semigroup MinMax where + 265 -- MinMaxEmpty <> b = b + 266 -- a <> MinMaxEmpty = a + 267 -- MinMax a b <> MinMax c d + 268 -- = MinMax (min a c) (max b d) + 269 -- -- = MinMax c b + 270 -- instance Monoid MinMax where + 271 -- mempty = MinMaxEmpty + 272 -- + 273 -- instance F.Measured MinMax Int where + 274 -- measure i = MinMax i i + 275 + 276 -- dualRoot :: Dual -> Int + 277 -- dualRoot (Dual (a,_,_) _ _) = a + 278 + 279 -- O(n*ln n), could be O(n) if I could figure out how to use fingertrees... + 280 sssp :: (Fractional a, Ord a, Epsilon a) => Ring a -> Dual -> SSSP + 281 sssp p d = toSSSP $ + 282 case d of + 283 Dual (a,b,c) l r -> + 284 (a, a) : + 285 (b, a) : + 286 (c, a) : + 287 worker [c] [b] a r ++ + 288 loopLeft a c l + 289 where + 290 toSSSP edges = + 291 (V.fromList . map snd . sortOn fst) edges + 292 loopLeft a outer l = + 293 case l of + 294 EmptyDual -> [] + 295 NodeDual x l' r' -> + 296 (x,a) : + 297 worker [x] [outer] a r' ++ + 298 loopLeft a x l' + 299 searchFn _checkStep _cusp _x [] = Nothing + 300 searchFn checkStep cusp x (y:ys) + 301 | not (checkStep (ringAccess p cusp) (ringAccess p y) (ringAccess p x)) + 302 = Just $ helper [] y ys + 303 | otherwise = Nothing + 304 where + 305 helper acc v [] = (v, [], reverse acc) + 306 helper acc v1 (v2:vs) + 307 | checkStep (ringAccess p v1) (ringAccess p v2) (ringAccess p x) = + 308 (v1, v2:vs, reverse acc) + 309 | otherwise = helper (v1:acc) v2 vs + 310 searchRight = searchFn isLeftTurn + 311 searchLeft = searchFn isRightTurn + 312 -- adj x = x -- ringClamp p (x-dualRoot d) + 313 -- optTrace msg = + 314 -- if False -- dualRoot d == 1 || dualRoot d == 0 + 315 -- then trace msg + 316 -- else id + 317 worker _ _ _ EmptyDual = [] + 318 worker f1 f2 cusp (NodeDual x l r) = + 319 -- (optTrace ("Funnel: " ++ show + 320 -- (map adj $ toList f1 + 321 -- ,adj cusp + 322 -- ,map adj $ toList f2 + 323 -- ,adj x + 324 -- , dualRoot d)) + 325 -- ) $ + 326 case searchLeft cusp x (toList f1) of + 327 Just (v, f1Hi, f1Lo) -> + 328 -- optTrace (" Visble from left: " ++ show (adj x,adj v)) $ + 329 (x, v::Int) : + 330 worker f1Hi [x] v l ++ + 331 worker (f1Lo ++ [v, x]) f2 cusp r + 332 Nothing -> + 333 case searchRight cusp x (toList f2) of + 334 Just (v, f2Hi, f2Lo) -> + 335 -- optTrace (" Visble from right: " ++ show (adj x,adj v)) $ + 336 (x, v::Int) : + 337 worker f1 (f2Lo ++ [v, x]) cusp l ++ + 338 worker [x] f2Hi v r + 339 Nothing -> + 340 -- optTrace (" Visble from cusp: " ++ show (adj x,adj cusp)) $ + 341 (x, cusp::Int) : + 342 worker f1 [x] cusp l ++ + 343 worker [x] f2 cusp r diff --git a/reanimate-0.4.1.0-inplace/Reanimate.Math.Triangulate.hs.html b/reanimate-0.4.1.0-inplace/Reanimate.Math.Triangulate.hs.html index e41538a..fe4995c 100644 --- a/reanimate-0.4.1.0-inplace/Reanimate.Math.Triangulate.hs.html +++ b/reanimate-0.4.1.0-inplace/Reanimate.Math.Triangulate.hs.html @@ -19,88 +19,89 @@ span.spaces { background: white } 
     1 {-# LANGUAGE DataKinds           #-}
     2 {-# LANGUAGE ScopedTypeVariables #-}
-    3 module Reanimate.Math.Triangulate
-    4   ( Triangulation
-    5   , edgesToTriangulation
-    6   , edgesToTriangulationM
-    7   , trianglesToTriangulation
-    8   , trianglesToTriangulationM
-    9   , triangulate
-   10   )
-   11 where
-   12 
-   13 import           Algorithms.Geometry.PolygonTriangulation.Triangulate (triangulate')
-   14 import           Algorithms.Geometry.PolygonTriangulation.Types
-   15 import           Control.Lens
-   16 import           Control.Monad
-   17 import           Control.Monad.ST
-   18 import           Data.Ext
-   19 import           Data.Geometry.PlanarSubdivision                      (PolygonFaceData)
-   20 import           Data.Geometry.Point
-   21 import           Data.Geometry.Polygon
-   22 import qualified Data.IntSet                                          as ISet
-   23 import qualified Data.PlaneGraph as Geo
-   24 import           Data.Proxy
-   25 import qualified Data.Vector                                          as V
-   26 import qualified Data.Vector.Mutable                                  as MV
-   27 import           Linear.V2
-   28 import           Reanimate.Math.Common
-   29 -- Max edges: n-2
-   30 -- Each edge is represented twice: 2n-4
-   31 -- Flat structure:
-   32 --   edges   :: V.Vector Int -- max length (2n-4)
-   33 --   offsets :: V.Vector Int -- length n
-   34 -- Combine the two vectors? < n => offsets, >= n => edges?
-   35 type Triangulation = V.Vector [Int]
-   36 
-   37 -- FIXME: Move to Common or a Triangulation module
-   38 -- O(n)
-   39 edgesToTriangulation :: Int -> [(Int, Int)] -> Triangulation
-   40 edgesToTriangulation size edges = runST $ do
-   41   v <- edgesToTriangulationM size edges
-   42   V.unsafeFreeze v
-   43 
-   44 edgesToTriangulationM :: Int -> [(Int, Int)] -> ST s (V.MVector s [Int])
-   45 edgesToTriangulationM size edges = do
-   46   v <- MV.replicate size []
-   47   forM_ edges $ \(e1, e2) -> do
-   48     MV.modify v (e1 :) e2
-   49     MV.modify v (e2 :) e1
-   50   forM_ [0 .. size - 1] $ \i -> MV.modify v (ISet.toList . ISet.fromList) i
-   51   return v
-   52 
-   53 trianglesToTriangulation :: Int -> V.Vector (Int, Int, Int) -> Triangulation
-   54 trianglesToTriangulation size edges = runST $ do
-   55   v <- trianglesToTriangulationM size edges
-   56   V.unsafeFreeze v
-   57 
-   58 trianglesToTriangulationM
-   59   :: Int -> V.Vector (Int, Int, Int) -> ST s (V.MVector s [Int])
-   60 trianglesToTriangulationM size trigs = do
-   61   v <- MV.replicate size []
-   62   forM_ (V.toList trigs) $ \(a, b, c) -> do
-   63     MV.modify v (\x -> b : c : x) a
-   64     MV.modify v (\x -> a : c : x) b
-   65     MV.modify v (\x -> a : b : x) c
-   66   forM_ [0 .. size - 1] $ \i -> MV.modify v (ISet.toList . ISet.fromList) i
-   67   return v
-   68 
+    3 {-# OPTIONS_HADDOCK hide #-}
+    4 module Reanimate.Math.Triangulate
+    5   ( Triangulation
+    6   , edgesToTriangulation
+    7   , edgesToTriangulationM
+    8   , trianglesToTriangulation
+    9   , trianglesToTriangulationM
+   10   , triangulate
+   11   )
+   12 where
+   13 
+   14 import           Algorithms.Geometry.PolygonTriangulation.Triangulate (triangulate')
+   15 import           Algorithms.Geometry.PolygonTriangulation.Types
+   16 import           Control.Lens
+   17 import           Control.Monad
+   18 import           Control.Monad.ST
+   19 import           Data.Ext
+   20 import           Data.Geometry.PlanarSubdivision                      (PolygonFaceData)
+   21 import           Data.Geometry.Point
+   22 import           Data.Geometry.Polygon
+   23 import qualified Data.IntSet                                          as ISet
+   24 import qualified Data.PlaneGraph as Geo
+   25 import           Data.Proxy
+   26 import qualified Data.Vector                                          as V
+   27 import qualified Data.Vector.Mutable                                  as MV
+   28 import           Linear.V2
+   29 import           Reanimate.Math.Common
+   30 -- Max edges: n-2
+   31 -- Each edge is represented twice: 2n-4
+   32 -- Flat structure:
+   33 --   edges   :: V.Vector Int -- max length (2n-4)
+   34 --   offsets :: V.Vector Int -- length n
+   35 -- Combine the two vectors? < n => offsets, >= n => edges?
+   36 type Triangulation = V.Vector [Int]
+   37 
+   38 -- FIXME: Move to Common or a Triangulation module
+   39 -- O(n)
+   40 edgesToTriangulation :: Int -> [(Int, Int)] -> Triangulation
+   41 edgesToTriangulation size edges = runST $ do
+   42   v <- edgesToTriangulationM size edges
+   43   V.unsafeFreeze v
+   44 
+   45 edgesToTriangulationM :: Int -> [(Int, Int)] -> ST s (V.MVector s [Int])
+   46 edgesToTriangulationM size edges = do
+   47   v <- MV.replicate size []
+   48   forM_ edges $ \(e1, e2) -> do
+   49     MV.modify v (e1 :) e2
+   50     MV.modify v (e2 :) e1
+   51   forM_ [0 .. size - 1] $ \i -> MV.modify v (ISet.toList . ISet.fromList) i
+   52   return v
+   53 
+   54 trianglesToTriangulation :: Int -> V.Vector (Int, Int, Int) -> Triangulation
+   55 trianglesToTriangulation size edges = runST $ do
+   56   v <- trianglesToTriangulationM size edges
+   57   V.unsafeFreeze v
+   58 
+   59 trianglesToTriangulationM
+   60   :: Int -> V.Vector (Int, Int, Int) -> ST s (V.MVector s [Int])
+   61 trianglesToTriangulationM size trigs = do
+   62   v <- MV.replicate size []
+   63   forM_ (V.toList trigs) $ \(a, b, c) -> do
+   64     MV.modify v (\x -> b : c : x) a
+   65     MV.modify v (\x -> a : c : x) b
+   66     MV.modify v (\x -> a : b : x) c
+   67   forM_ [0 .. size - 1] $ \i -> MV.modify v (ISet.toList . ISet.fromList) i
+   68   return v
    69 
-   70 triangulate :: forall a. (Fractional a, Ord a) => Ring a -> Triangulation
-   71 triangulate r = edgesToTriangulation (ringSize r) ds
-   72   where
-   73     ds :: [(Int,Int)]
-   74     ds =
-   75       [ (a^.Geo.vData, b^.Geo.vData)
-   76       | (d, Diagonal) <- V.toList (Geo.edges pg)
-   77       , let (a,b) = Geo.endPointData d pg ]
-   78     pg :: Geo.PlaneGraph () Int PolygonEdgeType PolygonFaceData a
-   79     pg = triangulate' Proxy p
-   80     p :: SimplePolygon Int a
-   81     p = fromPoints $
-   82       [ Point2 x y :+ n
-   83       | (n,V2 x y) <- zip [0..] (V.toList (ringUnpack r)) ]
-   84     -- ringUnpack
+   70 
+   71 triangulate :: forall a. (Fractional a, Ord a) => Ring a -> Triangulation
+   72 triangulate r = edgesToTriangulation (ringSize r) ds
+   73   where
+   74     ds :: [(Int,Int)]
+   75     ds =
+   76       [ (a^.Geo.vData, b^.Geo.vData)
+   77       | (d, Diagonal) <- V.toList (Geo.edges pg)
+   78       , let (a,b) = Geo.endPointData d pg ]
+   79     pg :: Geo.PlaneGraph () Int PolygonEdgeType PolygonFaceData a
+   80     pg = triangulate' Proxy p
+   81     p :: SimplePolygon Int a
+   82     p = fromPoints $
+   83       [ Point2 x y :+ n
+   84       | (n,V2 x y) <- zip [0..] (V.toList (ringUnpack r)) ]
+   85     -- ringUnpack
diff --git a/reanimate-0.4.1.0-inplace/Reanimate.Morph.Common.hs.html b/reanimate-0.4.1.0-inplace/Reanimate.Morph.Common.hs.html index 43c291d..efbd008 100644 --- a/reanimate-0.4.1.0-inplace/Reanimate.Morph.Common.hs.html +++ b/reanimate-0.4.1.0-inplace/Reanimate.Morph.Common.hs.html @@ -20,214 +20,221 @@ span.spaces { background: white } 1 {-# LANGUAGE RecordWildCards #-} 2 {-# LANGUAGE TupleSections #-} 3 {-# LANGUAGE UnicodeSyntax #-} - 4 module Reanimate.Morph.Common - 5 ( PointCorrespondence - 6 , Trajectory - 7 , ObjectCorrespondence - 8 , Morph(..) - 9 , morph - 10 , splitObjectCorrespondence - 11 , dupObjectCorrespondence - 12 , genesisObjectCorrespondence - 13 , toShapes - 14 , normalizePolygons - 15 , annotatePolygons - 16 , unsafeSVGToPolygon - 17 ) where - 18 - 19 import Control.Lens - 20 import qualified Data.Vector as V - 21 import Graphics.SvgTree (DrawAttributes, Texture (..), - 22 drawAttributes, fillColor, - 23 fillOpacity, groupOpacity, - 24 strokeColor, strokeOpacity) - 25 import Linear.V2 - 26 import Reanimate.Animation - 27 import Reanimate.ColorComponents - 28 import Reanimate.Ease - 29 import Reanimate.Math.Polygon (APolygon, Epsilon, Polygon, - 30 mkPolygon, pAddPoints, pCentroid, - 31 pCutEqual, pSize, polygonPoints) - 32 import Reanimate.PolyShape - 33 import Reanimate.Svg - 34 - 35 -- import Debug.Trace - 36 - 37 -- Correspondence - 38 -- Trajectory - 39 -- Color interpolation - 40 -- Polygon holes - 41 -- Polygon splitting - 42 - 43 -- Graphical polygon? FIXME: Come up with a better name. - 44 type GPolygon = (DrawAttributes, Polygon) - 45 - 46 -- | Method determining how points in the source polygon align with - 47 -- points in the target polygon. - 48 type PointCorrespondence = Polygon → Polygon → (Polygon, Polygon) + 4 {-| + 5 Copyright : Written by David Himmelstrup + 6 License : Unlicense + 7 Maintainer : lemmih@gmail.com + 8 Stability : experimental + 9 Portability : POSIX + 10 -} + 11 module Reanimate.Morph.Common + 12 ( PointCorrespondence + 13 , Trajectory + 14 , ObjectCorrespondence + 15 , Morph(..) + 16 , morph + 17 , splitObjectCorrespondence + 18 , dupObjectCorrespondence + 19 , genesisObjectCorrespondence + 20 , toShapes + 21 , normalizePolygons + 22 , annotatePolygons + 23 , unsafeSVGToPolygon + 24 ) where + 25 + 26 import Control.Lens + 27 import qualified Data.Vector as V + 28 import Graphics.SvgTree (DrawAttributes, Texture (..), + 29 drawAttributes, fillColor, + 30 fillOpacity, groupOpacity, + 31 strokeColor, strokeOpacity) + 32 import Linear.V2 + 33 import Reanimate.Animation + 34 import Reanimate.ColorComponents + 35 import Reanimate.Ease + 36 import Reanimate.Math.Polygon (APolygon, Epsilon, Polygon, + 37 mkPolygon, pAddPoints, pCentroid, + 38 pCutEqual, pSize, polygonPoints) + 39 import Reanimate.PolyShape + 40 import Reanimate.Svg + 41 + 42 -- import Debug.Trace + 43 + 44 -- Correspondence + 45 -- Trajectory + 46 -- Color interpolation + 47 -- Polygon holes + 48 -- Polygon splitting 49 - 50 -- | Method for interpolating between two aligned polygons. - 51 type Trajectory = (Polygon, Polygon) → (Double → Polygon) + 50 -- Graphical polygon? FIXME: Come up with a better name. + 51 type GPolygon = (DrawAttributes, Polygon) 52 - 53 -- | Method for pairing sets of polygons. - 54 type ObjectCorrespondence = [GPolygon] → [GPolygon] → [(GPolygon, GPolygon)] - 55 - 56 -- | Morphing strategy - 57 data Morph = Morph - 58 { morphTolerance :: Double - 59 -- ^ Morphing curves is not always possible and - 60 -- sometimes shapes are reduced to polygons or meta-curves. - 61 -- This parameter determined the accuracy of this transformation. - 62 , morphColorComponents :: ColorComponents - 63 -- ^ Color components used for color interpolation. LAB is usually - 64 -- the best option here. - 65 , morphPointCorrespondence :: PointCorrespondence - 66 -- ^ Desired point-correspondence algorithm. - 67 , morphTrajectory :: Trajectory - 68 -- ^ Desired interpolation algorithm. - 69 , morphObjectCorrespondence :: ObjectCorrespondence - 70 -- ^ Desired object-correspondence algorithm. - 71 } - 72 - 73 {-# INLINE morph #-} - 74 -- | Apply morphing strategy to interpolate between two SVG images. - 75 morph :: Morph -> SVG -> SVG -> Double -> SVG - 76 morph Morph{..} src dst = \t -> - 77 case t of - 78 -- 0 -> lowerTransformations src - 79 -- 1 -> lowerTransformations dst - 80 _ -> mkGroup - 81 [ render (genPoints t) - 82 & drawAttributes .~ genAttrs t - 83 | (genAttrs, genPoints) <- gens - 84 ] - 85 where - 86 render p = mkLinePathClosed - 87 [ (x,y) | V2 x y <- map (fmap realToFrac) $ V.toList $ polygonPoints p ] - 88 srcShapes = toShapes morphTolerance src - 89 dstShapes = toShapes morphTolerance dst - 90 pairs = morphObjectCorrespondence srcShapes dstShapes - 91 gens = - 92 [ (interpolateAttrs morphColorComponents srcAttr dstAttr, morphTrajectory arranged) - 93 | ((srcAttr, srcPoly'), (dstAttr, dstPoly')) <- pairs - 94 , let arranged = morphPointCorrespondence srcPoly' dstPoly' - 95 ] - 96 - 97 -- | Add points to each polygon such that they end up with same size. - 98 normalizePolygons :: (Real a, Fractional a, Epsilon a) => APolygon a -> APolygon a -> (APolygon a, APolygon a) - 99 normalizePolygons src dst = - 100 (pAddPoints (max 0 $ dstN-srcN) src - 101 ,pAddPoints (max 0 $ srcN-dstN) dst) - 102 where - 103 srcN = pSize src - 104 dstN = pSize dst - 105 - 106 interpolateAttrs :: ColorComponents -> DrawAttributes -> DrawAttributes -> Double -> DrawAttributes - 107 interpolateAttrs colorComps src dst t = - 108 src & fillColor .~ (interpColor <$> src^.fillColor <*> dst^.fillColor) - 109 & strokeColor .~ (interpColor <$> src^.strokeColor <*> dst^.strokeColor) - 110 & fillOpacity .~ (interpOpacity <$> src^.fillOpacity <*> dst^.fillOpacity) - 111 & groupOpacity .~ (interpOpacity <$> src^.groupOpacity <*> dst^.groupOpacity) - 112 & strokeOpacity .~ (interpOpacity <$> src^.strokeOpacity <*> dst^.strokeOpacity) - 113 where - 114 interpColor (ColorRef a) (ColorRef b) = - 115 ColorRef $ interpolateRGBA8 colorComps a b t - 116 -- interpolateColor (ColorRef a) FillNone = ColorRef a - 117 interpColor a _ = a - 118 interpOpacity a b = realToFrac (fromToS (realToFrac a) (realToFrac b) t) - 119 - 120 -- | Object-correspondence algorithm that spawn objects as necessary. - 121 genesisObjectCorrespondence :: ObjectCorrespondence - 122 genesisObjectCorrespondence left right = - 123 case (left, right) of - 124 ([] , []) -> [] - 125 ([], (y1,y2):ys) -> - 126 ((y1,y2), (y1, emptyFrom y2 y2)) : genesisObjectCorrespondence [] ys - 127 ((x1,x2):xs, []) -> - 128 ((x1,x2), (x1, emptyFrom x2 x2)) : genesisObjectCorrespondence xs [] - 129 (x:xs, y:ys) -> - 130 (x,y) : genesisObjectCorrespondence xs ys - 131 where - 132 emptyFrom a b = mkPolygon $ V.map (const $ pCentroid a) (polygonPoints b) - 133 - 134 -- | Object-correspondence algorithm that duplicate objects as necessary. - 135 dupObjectCorrespondence :: ObjectCorrespondence - 136 dupObjectCorrespondence left right = - 137 case (left, right) of - 138 (_, []) -> [] - 139 ([], _) -> [] - 140 ([x], [y]) -> - 141 [(x,y)] - 142 ([(x1,x2)], yShapes) -> - 143 let x2s = replicate (length yShapes) x2 - 144 in dupObjectCorrespondence (map (x1,) x2s) yShapes - 145 (xShapes, [(y1,y2)]) -> - 146 let y2s = replicate (length xShapes) y2 - 147 in dupObjectCorrespondence xShapes (map (y1,) y2s) - 148 (x:xs, y:ys) -> - 149 (x, y) : dupObjectCorrespondence xs ys - 150 - 151 -- | Object-correspondence algorithm that splits objects in smaller pieces - 152 -- as necessary. - 153 splitObjectCorrespondence :: ObjectCorrespondence - 154 -- splitObjectCorrespondence = dupObjectCorrespondence - 155 splitObjectCorrespondence left right = - 156 case (left, right) of - 157 (_, []) -> [] - 158 ([], _) -> [] - 159 ([x], [y]) -> - 160 [(x,y)] - 161 ([(x1,x2)], yShapes) -> - 162 let x2s = splitPolygon (length yShapes) x2 - 163 in splitObjectCorrespondence (map (x1,) x2s) yShapes - 164 (xShapes, [(y1,y2)]) -> - 165 let y2s = splitPolygon (length xShapes) y2 - 166 in splitObjectCorrespondence xShapes (map (y1,) y2s) - 167 (x:xs, y:ys) -> - 168 (x,y) : splitObjectCorrespondence xs ys - 169 - 170 splitPolygon :: Int -> Polygon -> [Polygon] - 171 splitPolygon 1 p = [p] - 172 splitPolygon n p = - 173 let (a,b) = pCutEqual p - 174 in splitPolygon (n`div`2) a ++ splitPolygon ((n+1)`div`2) b - 175 - 176 -- joinPairs :: Correspondence -> [(DrawAttributes, PolyShape)] -> [(DrawAttributes, PolyShape)] - 177 -- -> [(DrawAttributes, DrawAttributes, [(RPoint, RPoint)])] - 178 -- joinPairs _ _ [] = [] - 179 -- joinPairs _ [] _ = [] - 180 -- joinPairs corr [(x1,x2)] [(y1,y2)] = - 181 -- [(x1,y1, corr x2 y2)] - 182 -- joinPairs corr [(x1,x2)] yShapes = - 183 -- let x2s = splitPolyShape 0.001 (length yShapes) x2 - 184 -- in joinPairs corr (map (x1,) x2s) yShapes - 185 -- joinPairs corr xShapes [(y1,y2)] = - 186 -- let y2s = reverse $ splitPolyShape 0.001 (length xShapes) y2 - 187 -- in joinPairs corr xShapes (map (y1,) y2s) - 188 -- joinPairs corr ((x1,x2):xs) ((y1,y2):ys) = - 189 -- (x1,y1, corr x2 y2) : joinPairs corr xs ys - 190 -- joinPairs _ _ _ = [] - 191 - 192 -- FIXME: sort by size, smallest to largest - 193 -- | Extract shapes and their graphical attributes from an SVG node. - 194 toShapes :: Double -> SVG -> [(DrawAttributes, Polygon)] - 195 toShapes tol src = - 196 [ (attrs, plToPolygon tol shape) - 197 | (_, attrs, glyph) <- svgGlyphs $ lowerTransformations $ pathify src - 198 , shape <- map mergePolyShapeHoles $ plGroupShapes $ svgToPolyShapes glyph - 199 ] - 200 - 201 -- | Extract the first polygon in an SVG node. Will fail if there - 202 -- are no acceptable shapes. - 203 unsafeSVGToPolygon :: Double -> SVG -> Polygon - 204 unsafeSVGToPolygon tol src = snd $ head $ toShapes tol src - 205 - 206 -- | Map over each polygon in an SVG node. - 207 annotatePolygons :: (Polygon -> SVG) -> SVG -> SVG - 208 annotatePolygons fn svg = mkGroup - 209 [ fn poly & drawAttributes .~ attr - 210 | (attr, poly) <- toShapes 0.001 svg - 211 ] + 53 -- | Method determining how points in the source polygon align with + 54 -- points in the target polygon. + 55 type PointCorrespondence = Polygon → Polygon → (Polygon, Polygon) + 56 + 57 -- | Method for interpolating between two aligned polygons. + 58 type Trajectory = (Polygon, Polygon) → (Double → Polygon) + 59 + 60 -- | Method for pairing sets of polygons. + 61 type ObjectCorrespondence = [GPolygon] → [GPolygon] → [(GPolygon, GPolygon)] + 62 + 63 -- | Morphing strategy + 64 data Morph = Morph + 65 { morphTolerance :: Double + 66 -- ^ Morphing curves is not always possible and + 67 -- sometimes shapes are reduced to polygons or meta-curves. + 68 -- This parameter determined the accuracy of this transformation. + 69 , morphColorComponents :: ColorComponents + 70 -- ^ Color components used for color interpolation. LAB is usually + 71 -- the best option here. + 72 , morphPointCorrespondence :: PointCorrespondence + 73 -- ^ Desired point-correspondence algorithm. + 74 , morphTrajectory :: Trajectory + 75 -- ^ Desired interpolation algorithm. + 76 , morphObjectCorrespondence :: ObjectCorrespondence + 77 -- ^ Desired object-correspondence algorithm. + 78 } + 79 + 80 {-# INLINE morph #-} + 81 -- | Apply morphing strategy to interpolate between two SVG images. + 82 morph :: Morph -> SVG -> SVG -> Double -> SVG + 83 morph Morph{..} src dst = \t -> + 84 case t of + 85 -- 0 -> lowerTransformations src + 86 -- 1 -> lowerTransformations dst + 87 _ -> mkGroup + 88 [ render (genPoints t) + 89 & drawAttributes .~ genAttrs t + 90 | (genAttrs, genPoints) <- gens + 91 ] + 92 where + 93 render p = mkLinePathClosed + 94 [ (x,y) | V2 x y <- map (fmap realToFrac) $ V.toList $ polygonPoints p ] + 95 srcShapes = toShapes morphTolerance src + 96 dstShapes = toShapes morphTolerance dst + 97 pairs = morphObjectCorrespondence srcShapes dstShapes + 98 gens = + 99 [ (interpolateAttrs morphColorComponents srcAttr dstAttr, morphTrajectory arranged) + 100 | ((srcAttr, srcPoly'), (dstAttr, dstPoly')) <- pairs + 101 , let arranged = morphPointCorrespondence srcPoly' dstPoly' + 102 ] + 103 + 104 -- | Add points to each polygon such that they end up with same size. + 105 normalizePolygons :: (Real a, Fractional a, Epsilon a) => APolygon a -> APolygon a -> (APolygon a, APolygon a) + 106 normalizePolygons src dst = + 107 (pAddPoints (max 0 $ dstN-srcN) src + 108 ,pAddPoints (max 0 $ srcN-dstN) dst) + 109 where + 110 srcN = pSize src + 111 dstN = pSize dst + 112 + 113 interpolateAttrs :: ColorComponents -> DrawAttributes -> DrawAttributes -> Double -> DrawAttributes + 114 interpolateAttrs colorComps src dst t = + 115 src & fillColor .~ (interpColor <$> src^.fillColor <*> dst^.fillColor) + 116 & strokeColor .~ (interpColor <$> src^.strokeColor <*> dst^.strokeColor) + 117 & fillOpacity .~ (interpOpacity <$> src^.fillOpacity <*> dst^.fillOpacity) + 118 & groupOpacity .~ (interpOpacity <$> src^.groupOpacity <*> dst^.groupOpacity) + 119 & strokeOpacity .~ (interpOpacity <$> src^.strokeOpacity <*> dst^.strokeOpacity) + 120 where + 121 interpColor (ColorRef a) (ColorRef b) = + 122 ColorRef $ interpolateRGBA8 colorComps a b t + 123 -- interpolateColor (ColorRef a) FillNone = ColorRef a + 124 interpColor a _ = a + 125 interpOpacity a b = realToFrac (fromToS (realToFrac a) (realToFrac b) t) + 126 + 127 -- | Object-correspondence algorithm that spawn objects as necessary. + 128 genesisObjectCorrespondence :: ObjectCorrespondence + 129 genesisObjectCorrespondence left right = + 130 case (left, right) of + 131 ([] , []) -> [] + 132 ([], (y1,y2):ys) -> + 133 ((y1,y2), (y1, emptyFrom y2 y2)) : genesisObjectCorrespondence [] ys + 134 ((x1,x2):xs, []) -> + 135 ((x1,x2), (x1, emptyFrom x2 x2)) : genesisObjectCorrespondence xs [] + 136 (x:xs, y:ys) -> + 137 (x,y) : genesisObjectCorrespondence xs ys + 138 where + 139 emptyFrom a b = mkPolygon $ V.map (const $ pCentroid a) (polygonPoints b) + 140 + 141 -- | Object-correspondence algorithm that duplicate objects as necessary. + 142 dupObjectCorrespondence :: ObjectCorrespondence + 143 dupObjectCorrespondence left right = + 144 case (left, right) of + 145 (_, []) -> [] + 146 ([], _) -> [] + 147 ([x], [y]) -> + 148 [(x,y)] + 149 ([(x1,x2)], yShapes) -> + 150 let x2s = replicate (length yShapes) x2 + 151 in dupObjectCorrespondence (map (x1,) x2s) yShapes + 152 (xShapes, [(y1,y2)]) -> + 153 let y2s = replicate (length xShapes) y2 + 154 in dupObjectCorrespondence xShapes (map (y1,) y2s) + 155 (x:xs, y:ys) -> + 156 (x, y) : dupObjectCorrespondence xs ys + 157 + 158 -- | Object-correspondence algorithm that splits objects in smaller pieces + 159 -- as necessary. + 160 splitObjectCorrespondence :: ObjectCorrespondence + 161 -- splitObjectCorrespondence = dupObjectCorrespondence + 162 splitObjectCorrespondence left right = + 163 case (left, right) of + 164 (_, []) -> [] + 165 ([], _) -> [] + 166 ([x], [y]) -> + 167 [(x,y)] + 168 ([(x1,x2)], yShapes) -> + 169 let x2s = splitPolygon (length yShapes) x2 + 170 in splitObjectCorrespondence (map (x1,) x2s) yShapes + 171 (xShapes, [(y1,y2)]) -> + 172 let y2s = splitPolygon (length xShapes) y2 + 173 in splitObjectCorrespondence xShapes (map (y1,) y2s) + 174 (x:xs, y:ys) -> + 175 (x,y) : splitObjectCorrespondence xs ys + 176 + 177 splitPolygon :: Int -> Polygon -> [Polygon] + 178 splitPolygon 1 p = [p] + 179 splitPolygon n p = + 180 let (a,b) = pCutEqual p + 181 in splitPolygon (n`div`2) a ++ splitPolygon ((n+1)`div`2) b + 182 + 183 -- joinPairs :: Correspondence -> [(DrawAttributes, PolyShape)] -> [(DrawAttributes, PolyShape)] + 184 -- -> [(DrawAttributes, DrawAttributes, [(RPoint, RPoint)])] + 185 -- joinPairs _ _ [] = [] + 186 -- joinPairs _ [] _ = [] + 187 -- joinPairs corr [(x1,x2)] [(y1,y2)] = + 188 -- [(x1,y1, corr x2 y2)] + 189 -- joinPairs corr [(x1,x2)] yShapes = + 190 -- let x2s = splitPolyShape 0.001 (length yShapes) x2 + 191 -- in joinPairs corr (map (x1,) x2s) yShapes + 192 -- joinPairs corr xShapes [(y1,y2)] = + 193 -- let y2s = reverse $ splitPolyShape 0.001 (length xShapes) y2 + 194 -- in joinPairs corr xShapes (map (y1,) y2s) + 195 -- joinPairs corr ((x1,x2):xs) ((y1,y2):ys) = + 196 -- (x1,y1, corr x2 y2) : joinPairs corr xs ys + 197 -- joinPairs _ _ _ = [] + 198 + 199 -- FIXME: sort by size, smallest to largest + 200 -- | Extract shapes and their graphical attributes from an SVG node. + 201 toShapes :: Double -> SVG -> [(DrawAttributes, Polygon)] + 202 toShapes tol src = + 203 [ (attrs, plToPolygon tol shape) + 204 | (_, attrs, glyph) <- svgGlyphs $ lowerTransformations $ pathify src + 205 , shape <- map mergePolyShapeHoles $ plGroupShapes $ svgToPolyShapes glyph + 206 ] + 207 + 208 -- | Extract the first polygon in an SVG node. Will fail if there + 209 -- are no acceptable shapes. + 210 unsafeSVGToPolygon :: Double -> SVG -> Polygon + 211 unsafeSVGToPolygon tol src = snd $ head $ toShapes tol src + 212 + 213 -- | Map over each polygon in an SVG node. + 214 annotatePolygons :: (Polygon -> SVG) -> SVG -> SVG + 215 annotatePolygons fn svg = mkGroup + 216 [ fn poly & drawAttributes .~ attr + 217 | (attr, poly) <- toShapes 0.001 svg + 218 ] diff --git a/reanimate-0.4.1.0-inplace/Reanimate.Morph.Linear.hs.html b/reanimate-0.4.1.0-inplace/Reanimate.Morph.Linear.hs.html index 949a383..9916854 100644 --- a/reanimate-0.4.1.0-inplace/Reanimate.Morph.Linear.hs.html +++ b/reanimate-0.4.1.0-inplace/Reanimate.Morph.Linear.hs.html @@ -17,65 +17,72 @@ span.spaces { background: white } never executed always true always false 
-    1 module Reanimate.Morph.Linear
-    2   ( linear, rawLinear
-    3   , linearCorrespondence
-    4   , closestLinearCorrespondence
-    5   , closestLinearCorrespondenceA
-    6   , linearTrajectory
-    7   ) where
-    8 
-    9 import           Data.Hashable
-   10 import qualified Data.Vector            as V
-   11 import           Linear.Vector
-   12 import           Reanimate.ColorComponents
-   13 import           Reanimate.Math.Common
-   14 import           Reanimate.Math.Polygon
-   15 import           Reanimate.Morph.Cache
-   16 import           Reanimate.Morph.Common
-   17 
-   18 linear :: Morph
-   19 linear = rawLinear
-   20   { morphPointCorrespondence  =
-   21       cachePointCorrespondence (hash ("closest"::String))
-   22         closestLinearCorrespondence }
-   23 
-   24 rawLinear :: Morph
-   25 rawLinear = Morph
-   26   { morphTolerance            = 0.001
-   27   , morphColorComponents      = labComponents
-   28   , morphPointCorrespondence  = linearCorrespondence
-   29   , morphTrajectory           = linearTrajectory
-   30   , morphObjectCorrespondence = splitObjectCorrespondence }
-   31 
-   32 linearCorrespondence :: PointCorrespondence
-   33 linearCorrespondence = normalizePolygons
-   34 
-   35 closestLinearCorrespondence :: PointCorrespondence
-   36 closestLinearCorrespondence = closestLinearCorrespondenceA
-   37 
-   38 closestLinearCorrespondenceA :: (Real a, Fractional a, Epsilon a) => APolygon a -> APolygon a -> (APolygon a, APolygon a)
-   39 closestLinearCorrespondenceA src' dst' =
-   40     (src, worker dst (score dst) options)
-   41   where
-   42     (src, dst) = normalizePolygons src' dst'
-   43     worker bestP _bestPScore [] = bestP
-   44     worker bestP bestPScore (x:xs) =
-   45       let newScore = score x in
-   46       if newScore < bestPScore
-   47         then worker x newScore xs
-   48         else worker bestP bestPScore xs
-   49     options = pCycles dst
-   50     score p = sum
-   51       [ -- approxDist (pAccess src n) (pAccess p n)
-   52         distSquared (pAccess src n) (pAccess p n)
-   53       | n <- [0 .. pSize src-1] ]
-   54 
-   55 linearTrajectory :: Trajectory
-   56 linearTrajectory (src,dst)
-   57   | pSize src == pSize dst = \t -> mkPolygon $
-   58     V.zipWith (lerp $ realToFrac t) (polygonPoints dst) (polygonPoints src)
-   59   | otherwise = error $ "Invalid lengths: " ++ show (pSize src, pSize dst)
+    1 {-|
+    2 Copyright   : Written by David Himmelstrup
+    3 License     : Unlicense
+    4 Maintainer  : lemmih@gmail.com
+    5 Stability   : experimental
+    6 Portability : POSIX
+    7 -}
+    8 module Reanimate.Morph.Linear
+    9   ( linear, rawLinear
+   10   , linearCorrespondence
+   11   , closestLinearCorrespondence
+   12   , closestLinearCorrespondenceA
+   13   , linearTrajectory
+   14   ) where
+   15 
+   16 import           Data.Hashable
+   17 import qualified Data.Vector            as V
+   18 import           Linear.Vector
+   19 import           Reanimate.ColorComponents
+   20 import           Reanimate.Math.Common
+   21 import           Reanimate.Math.Polygon
+   22 import           Reanimate.Morph.Cache
+   23 import           Reanimate.Morph.Common
+   24 
+   25 linear :: Morph
+   26 linear = rawLinear
+   27   { morphPointCorrespondence  =
+   28       cachePointCorrespondence (hash ("closest"::String))
+   29         closestLinearCorrespondence }
+   30 
+   31 rawLinear :: Morph
+   32 rawLinear = Morph
+   33   { morphTolerance            = 0.001
+   34   , morphColorComponents      = labComponents
+   35   , morphPointCorrespondence  = linearCorrespondence
+   36   , morphTrajectory           = linearTrajectory
+   37   , morphObjectCorrespondence = splitObjectCorrespondence }
+   38 
+   39 linearCorrespondence :: PointCorrespondence
+   40 linearCorrespondence = normalizePolygons
+   41 
+   42 closestLinearCorrespondence :: PointCorrespondence
+   43 closestLinearCorrespondence = closestLinearCorrespondenceA
+   44 
+   45 closestLinearCorrespondenceA :: (Real a, Fractional a, Epsilon a) => APolygon a -> APolygon a -> (APolygon a, APolygon a)
+   46 closestLinearCorrespondenceA src' dst' =
+   47     (src, worker dst (score dst) options)
+   48   where
+   49     (src, dst) = normalizePolygons src' dst'
+   50     worker bestP _bestPScore [] = bestP
+   51     worker bestP bestPScore (x:xs) =
+   52       let newScore = score x in
+   53       if newScore < bestPScore
+   54         then worker x newScore xs
+   55         else worker bestP bestPScore xs
+   56     options = pCycles dst
+   57     score p = sum
+   58       [ -- approxDist (pAccess src n) (pAccess p n)
+   59         distSquared (pAccess src n) (pAccess p n)
+   60       | n <- [0 .. pSize src-1] ]
+   61 
+   62 linearTrajectory :: Trajectory
+   63 linearTrajectory (src,dst)
+   64   | pSize src == pSize dst = \t -> mkPolygon $
+   65     V.zipWith (lerp $ realToFrac t) (polygonPoints dst) (polygonPoints src)
+   66   | otherwise = error $ "Invalid lengths: " ++ show (pSize src, pSize dst)
diff --git a/reanimate-0.4.1.0-inplace/Reanimate.Parameters.hs.html b/reanimate-0.4.1.0-inplace/Reanimate.Parameters.hs.html index 5f5a10c..7bf78d5 100644 --- a/reanimate-0.4.1.0-inplace/Reanimate.Parameters.hs.html +++ b/reanimate-0.4.1.0-inplace/Reanimate.Parameters.hs.html @@ -117,8 +117,8 @@ span.spaces { background: white } 98 99 {-# NOINLINE pNoExternals #-} 100 -- | This parameter determined whether or not external tools are allowed. - 101 -- If this flag is True then tools such as 'latex' and 'blender' will not - 102 -- be invoked. + 101 -- If this flag is True then tools such as 'Reanimate.LaTeX.latex' and + 102 -- 'Reanimate.Blender.blender' will not be invoked. 103 pNoExternals :: Bool 104 pNoExternals = unsafePerformIO (readIORef pNoExternalsRef) 105 diff --git a/reanimate-0.4.1.0-inplace/Reanimate.Raster.hs.html b/reanimate-0.4.1.0-inplace/Reanimate.Raster.hs.html index aa23fe4..de5128f 100644 --- a/reanimate-0.4.1.0-inplace/Reanimate.Raster.hs.html +++ b/reanimate-0.4.1.0-inplace/Reanimate.Raster.hs.html @@ -271,11 +271,11 @@ span.spaces { background: white } 252 Left{} -> error "bad image" 253 Right img -> return img 254 - 255 -- | Use 'potrace' to trace edges in a raster image and convert them to SVG polygons. + 255 -- | Use \'potrace\' to trace edges in a raster image and convert them to SVG polygons. 256 vectorize :: FilePath -> SVG 257 vectorize = vectorize_ [] 258 - 259 -- | Same as 'vectorize' but takes a list of arguments for 'potrace'. + 259 -- | Same as 'vectorize' but takes a list of arguments for \'potrace\'. 260 vectorize_ :: [String] -> FilePath -> SVG 261 vectorize_ _ path | pNoExternals = mkText $ T.pack path 262 vectorize_ args path = unsafePerformIO $ do diff --git a/reanimate-0.4.1.0-inplace/Reanimate.Render.hs.html b/reanimate-0.4.1.0-inplace/Reanimate.Render.hs.html index c39fe23..3a2dd15 100644 --- a/reanimate-0.4.1.0-inplace/Reanimate.Render.hs.html +++ b/reanimate-0.4.1.0-inplace/Reanimate.Render.hs.html @@ -18,394 +18,401 @@ span.spaces { background: white } 
     1 {-# LANGUAGE MultiWayIf #-}
-    2 module Reanimate.Render
-    3   ( render
-    4   , renderSvgs
-    5   , renderSnippets        -- :: Animation -> IO ()
-    6   , renderOneFrame
-    7   , Format(..)
-    8   , Raster(..)
-    9   , Width, Height, FPS
-   10   , requireRaster         -- :: Raster -> IO Raster
-   11   , selectRaster          -- :: Raster -> IO Raster
-   12   , applyRaster           -- :: Raster -> FilePath -> IO ()
-   13   ) where
-   14 
-   15 import           Control.Concurrent
-   16 import           Control.Exception
-   17 import           Control.Monad             (forM_, forever, unless, void, when)
-   18 import           Data.Either
-   19 import           Data.Function
-   20 import qualified Data.Text                 as T
-   21 import qualified Data.Text.IO              as T
-   22 import           Data.Time
-   23 import           Graphics.SvgTree          (Number (..))
-   24 import           Numeric
-   25 import           Reanimate.Animation
-   26 import           Reanimate.Driver.Check
-   27 import           Reanimate.Driver.Magick
-   28 import           Reanimate.Misc
-   29 import           Reanimate.Parameters
-   30 import           System.Console.ANSI.Codes
-   31 import           System.Exit
-   32 import           System.FileLock (withTryFileLock, SharedExclusive(..), unlockFile)
-   33 import           System.Directory
-   34 import           System.FilePath           (replaceExtension, (<.>), (</>))
-   35 import           System.IO
-   36 import           Text.Printf               (printf)
-   37 
-   38 idempotentFile :: FilePath -> IO () -> IO ()
-   39 idempotentFile path action = do
-   40     _ <- withTryFileLock lockFile Exclusive $ \lock -> do
-   41       haveFile <- doesFileExist path
-   42       unless haveFile action
-   43       unlockFile lock
-   44       _ <- try (removeFile lockFile) :: IO (Either SomeException ())
-   45       return ()
-   46     return ()
-   47   where
-   48     lockFile = path <.> "lock"
-   49 
-   50 renderSvgs :: FilePath -> Int -> Bool -> Animation -> IO ()
-   51 renderSvgs folder offset _prettyPrint ani = do
-   52   print frameCount
-   53   lock <- newMVar ()
-   54 
-   55   handle errHandler $ concurrentForM_ (frameOrder rate frameCount) $ \nth' -> do
-   56     let nth = (nth'+offset) `mod` frameCount
-   57         now = (duration ani / (fromIntegral frameCount - 1)) * fromIntegral nth
-   58         frame = frameAt (if frameCount <= 1 then 0 else now) ani
-   59         svg = renderSvg Nothing Nothing frame
-   60         path = folder </> show nth <.> "svg"
+    2 {-|
+    3 Copyright   : Written by David Himmelstrup
+    4 License     : Unlicense
+    5 Maintainer  : lemmih@gmail.com
+    6 Stability   : experimental
+    7 Portability : POSIX
+    8 -}
+    9 module Reanimate.Render
+   10   ( render
+   11   , renderSvgs
+   12   , renderSnippets        -- :: Animation -> IO ()
+   13   , renderOneFrame
+   14   , Format(..)
+   15   , Raster(..)
+   16   , Width, Height, FPS
+   17   , requireRaster         -- :: Raster -> IO Raster
+   18   , selectRaster          -- :: Raster -> IO Raster
+   19   , applyRaster           -- :: Raster -> FilePath -> IO ()
+   20   ) where
+   21 
+   22 import           Control.Concurrent
+   23 import           Control.Exception
+   24 import           Control.Monad             (forM_, forever, unless, void, when)
+   25 import           Data.Either
+   26 import           Data.Function
+   27 import qualified Data.Text                 as T
+   28 import qualified Data.Text.IO              as T
+   29 import           Data.Time
+   30 import           Graphics.SvgTree          (Number (..))
+   31 import           Numeric
+   32 import           Reanimate.Animation
+   33 import           Reanimate.Driver.Check
+   34 import           Reanimate.Driver.Magick
+   35 import           Reanimate.Misc
+   36 import           Reanimate.Parameters
+   37 import           System.Console.ANSI.Codes
+   38 import           System.Exit
+   39 import           System.FileLock (withTryFileLock, SharedExclusive(..), unlockFile)
+   40 import           System.Directory
+   41 import           System.FilePath           (replaceExtension, (<.>), (</>))
+   42 import           System.IO
+   43 import           Text.Printf               (printf)
+   44 
+   45 idempotentFile :: FilePath -> IO () -> IO ()
+   46 idempotentFile path action = do
+   47     _ <- withTryFileLock lockFile Exclusive $ \lock -> do
+   48       haveFile <- doesFileExist path
+   49       unless haveFile action
+   50       unlockFile lock
+   51       _ <- try (removeFile lockFile) :: IO (Either SomeException ())
+   52       return ()
+   53     return ()
+   54   where
+   55     lockFile = path <.> "lock"
+   56 
+   57 renderSvgs :: FilePath -> Int -> Bool -> Animation -> IO ()
+   58 renderSvgs folder offset _prettyPrint ani = do
+   59   print frameCount
+   60   lock <- newMVar ()
    61 
-   62     idempotentFile path $ writeFile path svg
-   63     withMVar lock $ \_ -> do
-   64       print nth
-   65       hFlush stdout
-   66  where
-   67   rate       = 60
-   68   frameCount = round (duration ani * fromIntegral rate) :: Int
-   69   errHandler (ErrorCall msg) = do
-   70     hPutStrLn stderr msg
-   71     exitWith (ExitFailure 1)
-   72 
-   73 renderOneFrame :: FilePath -> Int -> Bool -> Int -> Animation -> IO ()
-   74 renderOneFrame folder offset _prettyPrint rate ani =
-   75     worker (frameOrder rate frameCount)
-   76   where
-   77     worker [] = putStrLn "Done"
-   78     worker (x:xs) = do
-   79       let nth = (x+offset) `mod` frameCount
-   80           now = (duration ani / (fromIntegral frameCount - 1)) * fromIntegral nth
-   81           frame = frameAt (if frameCount <= 1 then 0 else now) ani
-   82           svg = renderSvg Nothing Nothing frame
-   83           path = folder </> show nth <.> "svg"
-   84           tmpPath = path <.> "tmp"
-   85       haveFile <- doesFileExist path
-   86       if haveFile
-   87         then worker xs
-   88         else do
-   89           writeFile tmpPath svg
-   90           renameOrCopyFile tmpPath path
-   91           print nth
-   92     frameCount = round (duration ani * fromIntegral rate) :: Int
-   93 
-   94 -- XXX: Merge with 'renderSvgs'
-   95 renderSnippets :: Animation -> IO ()
-   96 renderSnippets ani = forM_ [0 .. frameCount - 1] $ \nth -> do
-   97   let now   = (duration ani / (fromIntegral frameCount - 1)) * fromIntegral nth
-   98       frame = frameAt now ani
-   99       svg   = renderSvg Nothing Nothing frame
-  100   putStr (show nth)
-  101   T.putStrLn $ T.concat . T.lines . T.pack $ svg
-  102   where frameCount = 10 :: Integer
-  103 
-  104 frameOrder :: Int -> Int -> [Int]
-  105 frameOrder fps nFrames = worker [] fps
-  106  where
-  107   worker _seen 0        = []
-  108   worker seen  nthFrame = filterFrameList seen nthFrame nFrames
-  109     ++ worker (nthFrame : seen) (nthFrame `div` 2)
+   62   handle errHandler $ concurrentForM_ (frameOrder rate frameCount) $ \nth' -> do
+   63     let nth = (nth'+offset) `mod` frameCount
+   64         now = (duration ani / (fromIntegral frameCount - 1)) * fromIntegral nth
+   65         frame = frameAt (if frameCount <= 1 then 0 else now) ani
+   66         svg = renderSvg Nothing Nothing frame
+   67         path = folder </> show nth <.> "svg"
+   68 
+   69     idempotentFile path $ writeFile path svg
+   70     withMVar lock $ \_ -> do
+   71       print nth
+   72       hFlush stdout
+   73  where
+   74   rate       = 60
+   75   frameCount = round (duration ani * fromIntegral rate) :: Int
+   76   errHandler (ErrorCall msg) = do
+   77     hPutStrLn stderr msg
+   78     exitWith (ExitFailure 1)
+   79 
+   80 renderOneFrame :: FilePath -> Int -> Bool -> Int -> Animation -> IO ()
+   81 renderOneFrame folder offset _prettyPrint rate ani =
+   82     worker (frameOrder rate frameCount)
+   83   where
+   84     worker [] = putStrLn "Done"
+   85     worker (x:xs) = do
+   86       let nth = (x+offset) `mod` frameCount
+   87           now = (duration ani / (fromIntegral frameCount - 1)) * fromIntegral nth
+   88           frame = frameAt (if frameCount <= 1 then 0 else now) ani
+   89           svg = renderSvg Nothing Nothing frame
+   90           path = folder </> show nth <.> "svg"
+   91           tmpPath = path <.> "tmp"
+   92       haveFile <- doesFileExist path
+   93       if haveFile
+   94         then worker xs
+   95         else do
+   96           writeFile tmpPath svg
+   97           renameOrCopyFile tmpPath path
+   98           print nth
+   99     frameCount = round (duration ani * fromIntegral rate) :: Int
+  100 
+  101 -- XXX: Merge with 'renderSvgs'
+  102 renderSnippets :: Animation -> IO ()
+  103 renderSnippets ani = forM_ [0 .. frameCount - 1] $ \nth -> do
+  104   let now   = (duration ani / (fromIntegral frameCount - 1)) * fromIntegral nth
+  105       frame = frameAt now ani
+  106       svg   = renderSvg Nothing Nothing frame
+  107   putStr (show nth)
+  108   T.putStrLn $ T.concat . T.lines . T.pack $ svg
+  109   where frameCount = 10 :: Integer
   110 
-  111 filterFrameList :: [Int] -> Int -> Int -> [Int]
-  112 filterFrameList seen nthFrame nFrames = filter (not . isSeen)
-  113                                                [0, nthFrame .. nFrames - 1]
-  114   where isSeen x = any (\y -> x `mod` y == 0) seen
-  115 
-  116 data Format = RenderMp4 | RenderGif | RenderWebm
-  117   deriving (Show)
-  118 
-  119 mp4Arguments :: FPS -> FilePath -> FilePath -> FilePath -> [String]
-  120 mp4Arguments fps progress template target =
-  121   [ "-r"
-  122   , show fps
-  123   , "-i"
-  124   , template
-  125   , "-y"
-  126   , "-c:v"
-  127   , "libx264"
-  128   , "-vf"
-  129   , "fps=" ++ show fps
-  130   , "-preset"
-  131   , "slow"
-  132   , "-crf"
-  133   , "18"
-  134   , "-movflags"
-  135   , "+faststart"
-  136   , "-progress"
-  137   , progress
-  138   , "-pix_fmt"
-  139   , "yuv420p"
-  140   , target
-  141   ]
-  142 
-  143 -- gifArguments :: FPS -> FilePath -> FilePath -> FilePath -> [String]
-  144 -- gifArguments fps progress template target =
-  145 
-  146 render
-  147   :: Animation
-  148   -> FilePath
-  149   -> Raster
-  150   -> Format
-  151   -> Width
-  152   -> Height
-  153   -> FPS
-  154   -> Bool
-  155   -> IO ()
-  156 render ani target raster format width height fps partial = do
-  157   printf "Starting render of animation: %.1f\n" (duration ani)
-  158   ffmpeg <- requireExecutable "ffmpeg"
-  159   generateFrames raster ani width height fps partial $ \template ->
-  160     withTempFile "txt" $ \progress -> do
-  161       writeFile progress ""
-  162       progressH <- openFile progress ReadMode
-  163       hSetBuffering progressH NoBuffering
-  164       allFinished <- newEmptyMVar
-  165       void $ forkIO $ do
-  166         progressPrinter "rendered" (animationFrameCount ani fps)
-  167           $ \done -> fix $ \loop -> do
-  168             eof <- hIsEOF progressH
-  169             if eof
-  170               then threadDelay 1000000 >> loop
-  171               else do
-  172                 l <- try (hGetLine progressH)
-  173                 case l of
-  174                   Left  SomeException{} -> return ()
-  175                   Right str             ->
-  176                     case take 6 str of
-  177                       "frame=" -> do
-  178                         void $ swapMVar done (read (drop 6 str))
-  179                         loop
-  180                       _ | str == "progress=end" -> return ()
-  181                       _                         -> loop
-  182         putMVar allFinished ()
-  183       case format of
-  184         RenderMp4 -> runCmd ffmpeg (mp4Arguments fps progress template target)
-  185         RenderGif -> withTempFile "png" $ \palette -> do
-  186           runCmd
-  187             ffmpeg
-  188             [ "-i"
-  189             , template
-  190             , "-y"
-  191             , "-vf"
-  192             , "fps="
-  193             ++ show fps
-  194             ++ ",scale="
-  195             ++ show width
-  196             ++ ":"
-  197             ++ show height
-  198             ++ ":flags=lanczos,palettegen"
-  199             , "-t"
-  200             , showFFloat Nothing (duration ani) ""
-  201             , palette
-  202             ]
-  203           runCmd
-  204             ffmpeg
-  205             [ "-framerate"
-  206             , show fps
-  207             , "-i"
-  208             , template
-  209             , "-y"
-  210             , "-i"
-  211             , palette
-  212             , "-progress"
-  213             , progress
-  214             , "-filter_complex"
-  215             , "fps="
-  216             ++ show fps
-  217             ++ ",scale="
-  218             ++ show width
-  219             ++ ":"
-  220             ++ show height
-  221             ++ ":flags=lanczos[x];[x][1:v]paletteuse"
-  222             , "-t"
-  223             , showFFloat Nothing (duration ani) ""
-  224             , target
-  225             ]
-  226         RenderWebm -> runCmd
-  227           ffmpeg
-  228           [ "-r"
-  229           , show fps
-  230           , "-i"
-  231           , template
-  232           , "-y"
-  233           , "-progress"
-  234           , progress
-  235           , "-c:v"
-  236           , "libvpx-vp9"
-  237           , "-vf"
-  238           , "fps=" ++ show fps
-  239           , target
-  240           ]
-  241       takeMVar allFinished
-  242 
-  243 ---------------------------------------------------------------------------------
-  244 -- Helpers
-  245 
-  246 progressPrinter :: String -> Int -> (MVar Int -> IO ()) -> IO ()
-  247 progressPrinter typeName maxCount action = do
-  248   printf "\rFrames %s: 0/%d" typeName maxCount
-  249   putStr $ clearFromCursorToLineEndCode ++ "\r"
-  250   done  <- newMVar (0 :: Int)
-  251   start <- getCurrentTime
-  252   let bgThread = forever $ do
-  253         nDone <- readMVar done
-  254         now   <- getCurrentTime
-  255         let spent = diffUTCTime now start
-  256             remaining =
-  257               (spent / (fromIntegral nDone / fromIntegral maxCount)) - spent
-  258         printf "\rFrames %s: %d/%d" typeName nDone maxCount
-  259         putStr $ ", time spent: " ++ ppDiff spent
-  260         unless (nDone == 0) $ do
-  261           putStr $ ", time remaining: " ++ ppDiff remaining
-  262           putStr $ ", total time: " ++ ppDiff (remaining + spent)
-  263         putStr $ clearFromCursorToLineEndCode ++ "\r"
-  264         hFlush stdout
-  265         threadDelay 1000000
-  266   withBackgroundThread bgThread $ action done
-  267   now <- getCurrentTime
-  268   let spent = diffUTCTime now start
-  269   printf "\rFrames %s: %d/%d" typeName maxCount maxCount
-  270   putStr $ ", time spent: " ++ ppDiff spent
-  271   putStr $ clearFromCursorToLineEndCode ++ "\n"
-  272 
-  273 animationFrameCount :: Animation -> FPS -> Int
-  274 animationFrameCount ani rate = round (duration ani * fromIntegral rate) :: Int
-  275 
-  276 generateFrames
-  277   :: Raster -> Animation -> Width -> Height -> FPS -> Bool -> (FilePath -> IO a) -> IO a
-  278 generateFrames raster ani width_ height_ rate partial action = withTempDir $ \tmp -> do
-  279   let frameName nth = tmp </> printf nameTemplate nth
-  280   setRootDirectory tmp
-  281   progressPrinter "generated" frameCount
-  282     $ \done -> handle h $ concurrentForM_ frames $ \n -> do
-  283         writeFile (frameName n) $ renderSvg width height $ nthFrame n
-  284         modifyMVar_ done $ \nDone -> return (nDone + 1)
-  285 
-  286   when (isValidRaster raster)
-  287     $ progressPrinter "rastered" frameCount
-  288     $ \done -> handle h $ concurrentForM_ frames $ \n -> do
-  289         applyRaster raster (frameName n)
-  290         modifyMVar_ done $ \nDone -> return (nDone + 1)
-  291 
-  292   action (tmp </> rasterTemplate raster)
-  293  where
-  294   isValidRaster RasterNone = False
-  295   isValidRaster RasterAuto = False
-  296   isValidRaster _          = True
-  297 
-  298   width  = Just $ Px $ fromIntegral width_
-  299   height = Just $ Px $ fromIntegral height_
-  300   h UserInterrupt | partial = do
-  301     hPutStrLn
-  302       stderr
-  303       "\nCtrl-C detected. Trying to generate video with available frames. \
-  304                        \Hit ctrl-c again to abort."
-  305     return ()
-  306   h other = throwIO other
-  307   -- frames = [0..frameCount-1]
-  308   frames = frameOrder rate frameCount
-  309   nthFrame nth = frameAt (recip (fromIntegral rate) * fromIntegral nth) ani
-  310   frameCount = animationFrameCount ani rate
-  311   nameTemplate :: String
-  312   nameTemplate = "render-%05d.svg"
-  313 
-  314 withBackgroundThread :: IO () -> IO a -> IO a
-  315 withBackgroundThread t = bracket (forkIO t) killThread . const
-  316 
-  317 ppDiff :: NominalDiffTime -> String
-  318 ppDiff diff | hours == 0 && mins == 0 = show secs ++ "s"
-  319             | hours == 0              = printf "%.2d:%.2d" mins secs
-  320             | otherwise               = printf "%.2d:%.2d:%.2d" hours mins secs
-  321  where
-  322   (osecs, secs) = round diff `divMod` (60 :: Int)
-  323   (hours, mins) = osecs `divMod` 60
-  324 
-  325 rasterTemplate :: Raster -> String
-  326 rasterTemplate RasterNone = "render-%05d.svg"
-  327 rasterTemplate RasterAuto = "render-%05d.svg"
-  328 rasterTemplate _          = "render-%05d.png"
-  329 
-  330 requireRaster :: Raster -> IO Raster
-  331 requireRaster raster = do
-  332   raster' <- selectRaster (if raster == RasterNone then RasterAuto else raster)
-  333   case raster' of
-  334     RasterNone -> do
-  335       hPutStrLn
-  336         stderr
-  337         "Raster required but none could be found. \
-  338         \Please install either inkscape, imagemagick, or rsvg-convert."
-  339       exitWith (ExitFailure 1)
-  340     _ -> pure raster'
-  341 
-  342 selectRaster :: Raster -> IO Raster
-  343 selectRaster RasterAuto = do
-  344   rsvg   <- hasRSvg
-  345   ink    <- hasInkscape
-  346   magick <- hasMagick
-  347   if
-  348     | isRight rsvg   -> pure RasterRSvg
-  349     | isRight ink    -> pure RasterInkscape
-  350     | isRight magick -> pure RasterMagick
-  351     | otherwise      -> pure RasterNone
-  352 selectRaster r = pure r
-  353 
-  354 applyRaster :: Raster -> FilePath -> IO ()
-  355 applyRaster RasterNone     _    = return ()
-  356 applyRaster RasterAuto     _    = return ()
-  357 applyRaster RasterInkscape path = runCmd
-  358   "inkscape"
-  359   [ "--without-gui"
-  360   , "--file=" ++ path
-  361   , "--export-png=" ++ replaceExtension path "png"
-  362   ]
-  363 applyRaster RasterRSvg path = runCmd
-  364   "rsvg-convert"
-  365   [path, "--unlimited", "--output", replaceExtension path "png"]
-  366 applyRaster RasterMagick path =
-  367   runCmd magickCmd [path, replaceExtension path "png"]
-  368 
-  369 concurrentForM_ :: [a] -> (a -> IO ()) -> IO ()
-  370 concurrentForM_ lst action = do
-  371   n    <- getNumCapabilities
-  372   sem  <- newQSemN n
-  373   eVar <- newEmptyMVar
-  374   forM_ lst $ \elt -> do
-  375     waitQSemN sem 1
-  376     emp <- isEmptyMVar eVar
-  377     if emp
-  378       then
-  379         void
-  380           $ forkIO
-  381               (         catch       (action elt) (void . tryPutMVar eVar)
-  382               `finally` signalQSemN sem          1
-  383               )
-  384       else signalQSemN sem 1
-  385   waitQSemN sem n
-  386   mbE <- tryTakeMVar eVar
-  387   case mbE of
-  388     Nothing -> return ()
-  389     Just e  -> throwIO (e :: SomeException)
+  111 frameOrder :: Int -> Int -> [Int]
+  112 frameOrder fps nFrames = worker [] fps
+  113  where
+  114   worker _seen 0        = []
+  115   worker seen  nthFrame = filterFrameList seen nthFrame nFrames
+  116     ++ worker (nthFrame : seen) (nthFrame `div` 2)
+  117 
+  118 filterFrameList :: [Int] -> Int -> Int -> [Int]
+  119 filterFrameList seen nthFrame nFrames = filter (not . isSeen)
+  120                                                [0, nthFrame .. nFrames - 1]
+  121   where isSeen x = any (\y -> x `mod` y == 0) seen
+  122 
+  123 data Format = RenderMp4 | RenderGif | RenderWebm
+  124   deriving (Show)
+  125 
+  126 mp4Arguments :: FPS -> FilePath -> FilePath -> FilePath -> [String]
+  127 mp4Arguments fps progress template target =
+  128   [ "-r"
+  129   , show fps
+  130   , "-i"
+  131   , template
+  132   , "-y"
+  133   , "-c:v"
+  134   , "libx264"
+  135   , "-vf"
+  136   , "fps=" ++ show fps
+  137   , "-preset"
+  138   , "slow"
+  139   , "-crf"
+  140   , "18"
+  141   , "-movflags"
+  142   , "+faststart"
+  143   , "-progress"
+  144   , progress
+  145   , "-pix_fmt"
+  146   , "yuv420p"
+  147   , target
+  148   ]
+  149 
+  150 -- gifArguments :: FPS -> FilePath -> FilePath -> FilePath -> [String]
+  151 -- gifArguments fps progress template target =
+  152 
+  153 render
+  154   :: Animation
+  155   -> FilePath
+  156   -> Raster
+  157   -> Format
+  158   -> Width
+  159   -> Height
+  160   -> FPS
+  161   -> Bool
+  162   -> IO ()
+  163 render ani target raster format width height fps partial = do
+  164   printf "Starting render of animation: %.1f\n" (duration ani)
+  165   ffmpeg <- requireExecutable "ffmpeg"
+  166   generateFrames raster ani width height fps partial $ \template ->
+  167     withTempFile "txt" $ \progress -> do
+  168       writeFile progress ""
+  169       progressH <- openFile progress ReadMode
+  170       hSetBuffering progressH NoBuffering
+  171       allFinished <- newEmptyMVar
+  172       void $ forkIO $ do
+  173         progressPrinter "rendered" (animationFrameCount ani fps)
+  174           $ \done -> fix $ \loop -> do
+  175             eof <- hIsEOF progressH
+  176             if eof
+  177               then threadDelay 1000000 >> loop
+  178               else do
+  179                 l <- try (hGetLine progressH)
+  180                 case l of
+  181                   Left  SomeException{} -> return ()
+  182                   Right str             ->
+  183                     case take 6 str of
+  184                       "frame=" -> do
+  185                         void $ swapMVar done (read (drop 6 str))
+  186                         loop
+  187                       _ | str == "progress=end" -> return ()
+  188                       _                         -> loop
+  189         putMVar allFinished ()
+  190       case format of
+  191         RenderMp4 -> runCmd ffmpeg (mp4Arguments fps progress template target)
+  192         RenderGif -> withTempFile "png" $ \palette -> do
+  193           runCmd
+  194             ffmpeg
+  195             [ "-i"
+  196             , template
+  197             , "-y"
+  198             , "-vf"
+  199             , "fps="
+  200             ++ show fps
+  201             ++ ",scale="
+  202             ++ show width
+  203             ++ ":"
+  204             ++ show height
+  205             ++ ":flags=lanczos,palettegen"
+  206             , "-t"
+  207             , showFFloat Nothing (duration ani) ""
+  208             , palette
+  209             ]
+  210           runCmd
+  211             ffmpeg
+  212             [ "-framerate"
+  213             , show fps
+  214             , "-i"
+  215             , template
+  216             , "-y"
+  217             , "-i"
+  218             , palette
+  219             , "-progress"
+  220             , progress
+  221             , "-filter_complex"
+  222             , "fps="
+  223             ++ show fps
+  224             ++ ",scale="
+  225             ++ show width
+  226             ++ ":"
+  227             ++ show height
+  228             ++ ":flags=lanczos[x];[x][1:v]paletteuse"
+  229             , "-t"
+  230             , showFFloat Nothing (duration ani) ""
+  231             , target
+  232             ]
+  233         RenderWebm -> runCmd
+  234           ffmpeg
+  235           [ "-r"
+  236           , show fps
+  237           , "-i"
+  238           , template
+  239           , "-y"
+  240           , "-progress"
+  241           , progress
+  242           , "-c:v"
+  243           , "libvpx-vp9"
+  244           , "-vf"
+  245           , "fps=" ++ show fps
+  246           , target
+  247           ]
+  248       takeMVar allFinished
+  249 
+  250 ---------------------------------------------------------------------------------
+  251 -- Helpers
+  252 
+  253 progressPrinter :: String -> Int -> (MVar Int -> IO ()) -> IO ()
+  254 progressPrinter typeName maxCount action = do
+  255   printf "\rFrames %s: 0/%d" typeName maxCount
+  256   putStr $ clearFromCursorToLineEndCode ++ "\r"
+  257   done  <- newMVar (0 :: Int)
+  258   start <- getCurrentTime
+  259   let bgThread = forever $ do
+  260         nDone <- readMVar done
+  261         now   <- getCurrentTime
+  262         let spent = diffUTCTime now start
+  263             remaining =
+  264               (spent / (fromIntegral nDone / fromIntegral maxCount)) - spent
+  265         printf "\rFrames %s: %d/%d" typeName nDone maxCount
+  266         putStr $ ", time spent: " ++ ppDiff spent
+  267         unless (nDone == 0) $ do
+  268           putStr $ ", time remaining: " ++ ppDiff remaining
+  269           putStr $ ", total time: " ++ ppDiff (remaining + spent)
+  270         putStr $ clearFromCursorToLineEndCode ++ "\r"
+  271         hFlush stdout
+  272         threadDelay 1000000
+  273   withBackgroundThread bgThread $ action done
+  274   now <- getCurrentTime
+  275   let spent = diffUTCTime now start
+  276   printf "\rFrames %s: %d/%d" typeName maxCount maxCount
+  277   putStr $ ", time spent: " ++ ppDiff spent
+  278   putStr $ clearFromCursorToLineEndCode ++ "\n"
+  279 
+  280 animationFrameCount :: Animation -> FPS -> Int
+  281 animationFrameCount ani rate = round (duration ani * fromIntegral rate) :: Int
+  282 
+  283 generateFrames
+  284   :: Raster -> Animation -> Width -> Height -> FPS -> Bool -> (FilePath -> IO a) -> IO a
+  285 generateFrames raster ani width_ height_ rate partial action = withTempDir $ \tmp -> do
+  286   let frameName nth = tmp </> printf nameTemplate nth
+  287   setRootDirectory tmp
+  288   progressPrinter "generated" frameCount
+  289     $ \done -> handle h $ concurrentForM_ frames $ \n -> do
+  290         writeFile (frameName n) $ renderSvg width height $ nthFrame n
+  291         modifyMVar_ done $ \nDone -> return (nDone + 1)
+  292 
+  293   when (isValidRaster raster)
+  294     $ progressPrinter "rastered" frameCount
+  295     $ \done -> handle h $ concurrentForM_ frames $ \n -> do
+  296         applyRaster raster (frameName n)
+  297         modifyMVar_ done $ \nDone -> return (nDone + 1)
+  298 
+  299   action (tmp </> rasterTemplate raster)
+  300  where
+  301   isValidRaster RasterNone = False
+  302   isValidRaster RasterAuto = False
+  303   isValidRaster _          = True
+  304 
+  305   width  = Just $ Px $ fromIntegral width_
+  306   height = Just $ Px $ fromIntegral height_
+  307   h UserInterrupt | partial = do
+  308     hPutStrLn
+  309       stderr
+  310       "\nCtrl-C detected. Trying to generate video with available frames. \
+  311                        \Hit ctrl-c again to abort."
+  312     return ()
+  313   h other = throwIO other
+  314   -- frames = [0..frameCount-1]
+  315   frames = frameOrder rate frameCount
+  316   nthFrame nth = frameAt (recip (fromIntegral rate) * fromIntegral nth) ani
+  317   frameCount = animationFrameCount ani rate
+  318   nameTemplate :: String
+  319   nameTemplate = "render-%05d.svg"
+  320 
+  321 withBackgroundThread :: IO () -> IO a -> IO a
+  322 withBackgroundThread t = bracket (forkIO t) killThread . const
+  323 
+  324 ppDiff :: NominalDiffTime -> String
+  325 ppDiff diff | hours == 0 && mins == 0 = show secs ++ "s"
+  326             | hours == 0              = printf "%.2d:%.2d" mins secs
+  327             | otherwise               = printf "%.2d:%.2d:%.2d" hours mins secs
+  328  where
+  329   (osecs, secs) = round diff `divMod` (60 :: Int)
+  330   (hours, mins) = osecs `divMod` 60
+  331 
+  332 rasterTemplate :: Raster -> String
+  333 rasterTemplate RasterNone = "render-%05d.svg"
+  334 rasterTemplate RasterAuto = "render-%05d.svg"
+  335 rasterTemplate _          = "render-%05d.png"
+  336 
+  337 requireRaster :: Raster -> IO Raster
+  338 requireRaster raster = do
+  339   raster' <- selectRaster (if raster == RasterNone then RasterAuto else raster)
+  340   case raster' of
+  341     RasterNone -> do
+  342       hPutStrLn
+  343         stderr
+  344         "Raster required but none could be found. \
+  345         \Please install either inkscape, imagemagick, or rsvg-convert."
+  346       exitWith (ExitFailure 1)
+  347     _ -> pure raster'
+  348 
+  349 selectRaster :: Raster -> IO Raster
+  350 selectRaster RasterAuto = do
+  351   rsvg   <- hasRSvg
+  352   ink    <- hasInkscape
+  353   magick <- hasMagick
+  354   if
+  355     | isRight rsvg   -> pure RasterRSvg
+  356     | isRight ink    -> pure RasterInkscape
+  357     | isRight magick -> pure RasterMagick
+  358     | otherwise      -> pure RasterNone
+  359 selectRaster r = pure r
+  360 
+  361 applyRaster :: Raster -> FilePath -> IO ()
+  362 applyRaster RasterNone     _    = return ()
+  363 applyRaster RasterAuto     _    = return ()
+  364 applyRaster RasterInkscape path = runCmd
+  365   "inkscape"
+  366   [ "--without-gui"
+  367   , "--file=" ++ path
+  368   , "--export-png=" ++ replaceExtension path "png"
+  369   ]
+  370 applyRaster RasterRSvg path = runCmd
+  371   "rsvg-convert"
+  372   [path, "--unlimited", "--output", replaceExtension path "png"]
+  373 applyRaster RasterMagick path =
+  374   runCmd magickCmd [path, replaceExtension path "png"]
+  375 
+  376 concurrentForM_ :: [a] -> (a -> IO ()) -> IO ()
+  377 concurrentForM_ lst action = do
+  378   n    <- getNumCapabilities
+  379   sem  <- newQSemN n
+  380   eVar <- newEmptyMVar
+  381   forM_ lst $ \elt -> do
+  382     waitQSemN sem 1
+  383     emp <- isEmptyMVar eVar
+  384     if emp
+  385       then
+  386         void
+  387           $ forkIO
+  388               (         catch       (action elt) (void . tryPutMVar eVar)
+  389               `finally` signalQSemN sem          1
+  390               )
+  391       else signalQSemN sem 1
+  392   waitQSemN sem n
+  393   mbE <- tryTakeMVar eVar
+  394   case mbE of
+  395     Nothing -> return ()
+  396     Just e  -> throwIO (e :: SomeException)
diff --git a/reanimate-0.4.1.0-inplace/Reanimate.Svg.Unuse.hs.html b/reanimate-0.4.1.0-inplace/Reanimate.Svg.Unuse.hs.html index 5226910..c4c1daf 100644 --- a/reanimate-0.4.1.0-inplace/Reanimate.Svg.Unuse.hs.html +++ b/reanimate-0.4.1.0-inplace/Reanimate.Svg.Unuse.hs.html @@ -17,69 +17,76 @@ span.spaces { background: white } never executed always true always false 
-    1 module Reanimate.Svg.Unuse
-    2   ( replaceUses
-    3   , unbox
-    4   , embedDocument
-    5   ) where
-    6 
-    7 import           Control.Lens               ((%~), (&), (.~), (?~), (^.))
-    8 import qualified Data.Map                   as Map
-    9 import           Data.Maybe
-   10 import           Graphics.SvgTree           hiding (line, path, use)
-   11 import           Reanimate.Constants
-   12 import           Reanimate.Svg.Constructors
+    1 {-|
+    2 Copyright   : Written by David Himmelstrup
+    3 License     : Unlicense
+    4 Maintainer  : lemmih@gmail.com
+    5 Stability   : experimental
+    6 Portability : POSIX
+    7 -}
+    8 module Reanimate.Svg.Unuse
+    9   ( replaceUses
+   10   , unbox
+   11   , embedDocument
+   12   ) where
    13 
-   14 -- | Replace all @<use>@ nodes with their definition.
-   15 replaceUses :: Document -> Document
-   16 replaceUses doc = doc & elements %~ map (mapTree replace)
-   17   where
-   18     replaceDefinition PathTree{} = None
-   19     replaceDefinition t          = t
-   20 
-   21     replace t@DefinitionTree{} = mapTree replaceDefinition t
-   22     replace (UseTree _ Just{}) = error "replaceUses: subtree in use?"
-   23     replace (UseTree use Nothing) =
-   24       case Map.lookup (use^.useName) idMap of
-   25         Nothing -> error $ "Unknown id: " ++ (use^.useName)
-   26         Just tree -> mapTree replace $
-   27           GroupTree $
-   28           defaultSvg & groupChildren .~ [tree]
-   29                      & transform ?~
-   30                         fromMaybe [] (use^.transform) ++
-   31                         [baseToTransformation (use^.useBase)]
-   32     replace x = x
-   33     baseToTransformation (x,y) =
-   34       case (toUserUnit defaultDPI x, toUserUnit defaultDPI y) of
-   35         (Num a, Num b) -> Translate a b
-   36         _              -> TransformUnknown
-   37     docTree = mkGroup (doc^.elements)
-   38     idMap = foldTree updMap Map.empty docTree
-   39     updMap m tree =
-   40       case tree^.attrId of
-   41         Nothing  -> m
-   42         Just tid -> Map.insert tid tree m
-   43 
-   44 -- FIXME: the viewbox is ignored. Can we use the viewbox as a mask?
-   45 -- | Transform out viewbox. Definitions and CSS rules are discarded.
-   46 unbox :: Document -> Tree
-   47 unbox doc@Document{_viewBox = Just (_minx, _minw, _width, _height)} =
-   48   GroupTree $ defaultSvg
-   49           & groupChildren .~ doc^.elements
-   50 unbox doc =
-   51   GroupTree $ defaultSvg
-   52     & groupChildren .~ doc^.elements
-   53 
-   54 -- | Embed 'Document'. This keeps the entire document intact but makes
-   55 --   it more difficult to use, say, `Reanimate.Svg.pathify` on it.
-   56 embedDocument :: Document -> Tree
-   57 embedDocument doc =
-   58   translate (-screenWidth/2) (screenHeight/2) $
-   59   withFillOpacity 1 $
-   60   withStrokeWidth 0 $
-   61   flipYAxis $
-   62   SvgTree $ doc & width .~ Nothing
-   63                 & height .~ Nothing
+   14 import           Control.Lens               ((%~), (&), (.~), (?~), (^.))
+   15 import qualified Data.Map                   as Map
+   16 import           Data.Maybe
+   17 import           Graphics.SvgTree           hiding (line, path, use)
+   18 import           Reanimate.Constants
+   19 import           Reanimate.Svg.Constructors
+   20 
+   21 -- | Replace all @<use>@ nodes with their definition.
+   22 replaceUses :: Document -> Document
+   23 replaceUses doc = doc & elements %~ map (mapTree replace)
+   24   where
+   25     replaceDefinition PathTree{} = None
+   26     replaceDefinition t          = t
+   27 
+   28     replace t@DefinitionTree{} = mapTree replaceDefinition t
+   29     replace (UseTree _ Just{}) = error "replaceUses: subtree in use?"
+   30     replace (UseTree use Nothing) =
+   31       case Map.lookup (use^.useName) idMap of
+   32         Nothing -> error $ "Unknown id: " ++ (use^.useName)
+   33         Just tree -> mapTree replace $
+   34           GroupTree $
+   35           defaultSvg & groupChildren .~ [tree]
+   36                      & transform ?~
+   37                         fromMaybe [] (use^.transform) ++
+   38                         [baseToTransformation (use^.useBase)]
+   39     replace x = x
+   40     baseToTransformation (x,y) =
+   41       case (toUserUnit defaultDPI x, toUserUnit defaultDPI y) of
+   42         (Num a, Num b) -> Translate a b
+   43         _              -> TransformUnknown
+   44     docTree = mkGroup (doc^.elements)
+   45     idMap = foldTree updMap Map.empty docTree
+   46     updMap m tree =
+   47       case tree^.attrId of
+   48         Nothing  -> m
+   49         Just tid -> Map.insert tid tree m
+   50 
+   51 -- FIXME: the viewbox is ignored. Can we use the viewbox as a mask?
+   52 -- | Transform out viewbox. Definitions and CSS rules are discarded.
+   53 unbox :: Document -> Tree
+   54 unbox doc@Document{_viewBox = Just (_minx, _minw, _width, _height)} =
+   55   GroupTree $ defaultSvg
+   56           & groupChildren .~ doc^.elements
+   57 unbox doc =
+   58   GroupTree $ defaultSvg
+   59     & groupChildren .~ doc^.elements
+   60 
+   61 -- | Embed 'Document'. This keeps the entire document intact but makes
+   62 --   it more difficult to use, say, `Reanimate.Svg.pathify` on it.
+   63 embedDocument :: Document -> Tree
+   64 embedDocument doc =
+   65   translate (-screenWidth/2) (screenHeight/2) $
+   66   withFillOpacity 1 $
+   67   withStrokeWidth 0 $
+   68   flipYAxis $
+   69   SvgTree $ doc & width .~ Nothing
+   70                 & height .~ Nothing
diff --git a/reanimate-0.4.1.0-inplace/Reanimate.Svg.hs.html b/reanimate-0.4.1.0-inplace/Reanimate.Svg.hs.html index 513c397..bc8ad65 100644 --- a/reanimate-0.4.1.0-inplace/Reanimate.Svg.hs.html +++ b/reanimate-0.4.1.0-inplace/Reanimate.Svg.hs.html @@ -18,333 +18,340 @@ span.spaces { background: white } 
     1 {-# LANGUAGE LambdaCase #-}
-    2 module Reanimate.Svg
-    3   ( module Reanimate.Svg
-    4   , module Reanimate.Svg.Constructors
-    5   , module Reanimate.Svg.LineCommand
-    6   , module Reanimate.Svg.BoundingBox
-    7   , module Reanimate.Svg.Unuse
-    8   ) where
-    9 
-   10 import           Control.Lens                 ((%~), (&), (.~), (^.), (?~))
-   11 import           Control.Monad.State
-   12 import           Graphics.SvgTree             hiding (height, line, path, use,
-   13                                                width)
-   14 import           Linear.V2                    hiding (angle)
-   15 import           Reanimate.Constants
-   16 import           Reanimate.Animation (SVG)
-   17 import           Reanimate.Svg.Constructors
-   18 import           Reanimate.Svg.LineCommand
-   19 import           Reanimate.Svg.BoundingBox
-   20 import           Reanimate.Svg.Unuse
-   21 import qualified Reanimate.Transform          as Transform
-   22 
-   23 -- | Remove transformations (such as translations, rotations, scaling)
-   24 --   and apply them directly to the SVG nodes. Note, this function
-   25 --   may convert nodes (such as Circle or Rect) to paths. Also note
-   26 --   that /does/ change how the SVG is rendered. Particularly, stroke
-   27 --   width is affected by directly applying scaling.
-   28 --
-   29 --   @lowerTransformations (scale 2 (mkCircle 1)) = mkCircle 2@
-   30 lowerTransformations :: Tree -> Tree
-   31 lowerTransformations = worker False Transform.identity
-   32   where
-   33     updLineCmd m cmd =
-   34       case cmd of
-   35         LineMove p    -> LineMove $ Transform.transformPoint m p
-   36         -- LineDraw p -> LineDraw $ Transform.transformPoint m p
-   37         LineBezier ps -> LineBezier $ map (Transform.transformPoint m) ps
-   38         LineEnd p     -> LineEnd $ Transform.transformPoint m p
-   39     updPath m = lineToPath . map (updLineCmd m) . toLineCommands
-   40     updPoint m (Num a,Num b) =
-   41       case Transform.transformPoint m (V2 a b) of
-   42         V2 x y -> (Num x, Num y)
-   43     updPoint _ other = other -- XXX: Can we do better here?
-   44     worker hasPathified m t =
-   45       let m' = m * Transform.mkMatrix (t^.transform) in
-   46       case t of
-   47         PathTree path -> PathTree $
-   48           path & pathDefinition %~ updPath m'
-   49                & transform .~ Nothing
-   50         GroupTree g -> GroupTree $
-   51           g & groupChildren %~ map (worker hasPathified m')
-   52             & transform .~ Nothing
-   53         LineTree line ->
-   54           LineTree $
-   55             line & linePoint1 %~ updPoint m
-   56                  & linePoint2 %~ updPoint m
-   57         ClipPathTree{} -> t
-   58         -- If we encounter an unknown node and we've already tried to convert
-   59         -- to paths, give up and insert an explicit transformation.
-   60         _ | hasPathified ->
-   61           mkGroup [t] & transform ?~ [ Transform.toTransformation m ]
-   62         -- If we haven't tried to pathify, run pathify only once.
-   63         _ -> worker True m (pathify t)
-   64 
-   65 -- | Remove all @id@ attributes.
-   66 lowerIds :: Tree -> Tree
-   67 lowerIds = mapTree worker
-   68   where
-   69     worker t@GroupTree{} = t & attrId .~ Nothing
-   70     worker t@PathTree{}  = t & attrId .~ Nothing
-   71     worker t             = t
-   72 
-   73 -- | Optimize SVG tree without affecting how it is rendered.
-   74 simplify :: Tree -> Tree
-   75 simplify root =
-   76   case worker root of
-   77     []  -> None
-   78     [x] -> x
-   79     xs  -> mkGroup xs
-   80   where
-   81     worker None = []
-   82     worker (DefinitionTree d) =
-   83       concatMap dropNulls
-   84       [DefinitionTree $ d & groupChildren %~ concatMap worker]
-   85     worker (GroupTree g)
-   86       | g ^. drawAttributes == defaultSvg =
-   87         concatMap dropNulls $
-   88         concatMap worker (g^.groupChildren)
-   89       | otherwise =
-   90         dropNulls $
-   91         GroupTree $ g & groupChildren %~ concatMap worker
-   92     worker t = dropNulls t
-   93 
-   94     dropNulls None = []
-   95     dropNulls (DefinitionTree d)
-   96       | null (d^.groupChildren) = []
-   97     dropNulls (GroupTree g)
-   98       | null (g^.groupChildren) = []
-   99     dropNulls t = [t]
-  100 
-  101 -- | Separate grouped items. This is required by clip nodes.
-  102 --
-  103 -- @removeGroups (withFillColor "blue" $ mkGroup [mkCircle 1, mkRect 1 1])
-  104 --    = [ withFillColor "blue" $ mkCircle 1
-  105 --      , withFillColor "blue" $ mkRect 1 1 ]@
-  106 removeGroups :: Tree -> [Tree]
-  107 removeGroups = worker defaultSvg
-  108   where
-  109     worker _attr None = []
-  110     worker _attr (DefinitionTree d) =
-  111       concatMap dropNulls
-  112       [DefinitionTree $ d & groupChildren %~ concatMap (worker defaultSvg)]
-  113     worker attr (GroupTree g)
-  114       | g ^. drawAttributes == defaultSvg =
-  115         concatMap dropNulls $
-  116         concatMap (worker attr) (g^.groupChildren)
-  117       | otherwise =
-  118         concatMap (worker (attr <> g ^. drawAttributes)) (g^.groupChildren)
-  119     worker attr t = dropNulls (t & drawAttributes .~ attr)
-  120 
-  121     dropNulls None = []
-  122     dropNulls (DefinitionTree d)
-  123       | null (d^.groupChildren) = []
-  124     dropNulls (GroupTree g)
-  125       | null (g^.groupChildren) = []
-  126     dropNulls t = [t]
-  127 
-  128 -- | Extract all path commands from a node (and its children) and concatenate them.
-  129 extractPath :: Tree -> [PathCommand]
-  130 extractPath = worker . simplify . lowerTransformations . pathify
-  131   where
-  132     worker (GroupTree g) = concatMap worker (g^.groupChildren)
-  133     worker (PathTree p)  = p^.pathDefinition
-  134     worker _             = []
-  135 
-  136 withSubglyphs :: [Int] -> (Tree -> Tree) -> Tree -> Tree
-  137 withSubglyphs target fn = \t -> evalState (worker t) 0
-  138   where
-  139     worker :: Tree -> State Int Tree
-  140     worker t =
-  141       case t of
-  142         GroupTree g -> do
-  143           cs <- mapM worker (g ^. groupChildren)
-  144           return $ GroupTree $ g & groupChildren .~ cs
-  145         PathTree{} -> handleGlyph t
-  146         CircleTree{} -> handleGlyph t
-  147         PolyLineTree{} -> handleGlyph t
-  148         PolygonTree{} -> handleGlyph t
-  149         EllipseTree{} -> handleGlyph t
-  150         LineTree{} -> handleGlyph t
-  151         RectangleTree{} -> handleGlyph t
-  152         _ -> return t
-  153     handleGlyph :: Tree -> State Int Tree
-  154     handleGlyph svg = do
-  155       n <- get <* modify (+1)
-  156       if n `elem` target
-  157         then return $ fn svg
-  158         else return svg
-  159 
-  160 splitGlyphs :: [Int] -> Tree -> (Tree, Tree)
-  161 splitGlyphs target = \t ->
-  162     let (_, l, r) = execState (worker id t) (0, [], [])
-  163     in (mkGroup l, mkGroup r)
-  164   where
-  165     handleGlyph :: Tree -> State (Int, [Tree], [Tree]) ()
-  166     handleGlyph t = do
-  167       (n, l, r) <- get
-  168       if n `elem` target
-  169         then put (n+1, l, t:r)
-  170         else put (n+1, t:l, r)
-  171     worker :: (Tree -> Tree) -> Tree -> State (Int, [Tree], [Tree]) ()
-  172     worker acc t =
-  173       case t of
-  174         GroupTree g -> do
-  175           let acc' sub = acc (GroupTree $ g & groupChildren .~ [sub])
-  176           mapM_ (worker acc') (g ^. groupChildren)
-  177         PathTree{} -> handleGlyph $ acc t
-  178         CircleTree{} -> handleGlyph $ acc t
-  179         PolyLineTree{} -> handleGlyph $ acc t
-  180         PolygonTree{} -> handleGlyph $ acc t
-  181         EllipseTree{} -> handleGlyph $ acc t
-  182         LineTree{} -> handleGlyph $ acc t
-  183         RectangleTree{} -> handleGlyph $ acc t
-  184         DefinitionTree{} -> return ()
-  185         _ ->
-  186           modify $ \(n, l, r) -> (n, acc t:l, r)
-  187 {-
-  188 <g transform="translate(10,10)">
-  189   <g transform="scale(2)">
-  190     <circle/>
-  191   </g>
-  192   <g transform="scale(0.5)">
-  193     <rect/>
-  194   </g>
-  195 </g>
-  196 
-  197 [ (\svg -> <g transform="translate(10,10)"><g transform="scale(2)">svg</g></g>, <circle/>)
-  198 , (\svg -> <g transform="translate(10,10)"><g transform="scale(0.5)">svg</g></g>, <rect/>)]
-  199 -}
-  200 svgGlyphs :: Tree -> [(Tree -> Tree, DrawAttributes, Tree)]
-  201 svgGlyphs = worker id defaultSvg
-  202   where
-  203     worker acc attr =
-  204       \case
-  205         None -> []
-  206         GroupTree g ->
-  207           let acc' sub = acc (GroupTree $ g & groupChildren .~ [sub])
-  208               attr' = (g^.drawAttributes) `mappend` attr
-  209           in concatMap (worker acc' attr') (g ^. groupChildren)
-  210         t -> [(acc, (t^.drawAttributes) `mappend` attr, t)]
-  211 
-  212 {-| Convert primitive SVG shapes (like those created by 'mkCircle', 'mkRect', 'mkLine' or
-  213     'mkEllipse') into SVG path. This can be useful for creating animations of these shapes being
-  214     drawn progressively with 'partialSvg'.
-  215 
-  216     Example:
-  217 
-  218     > pathifyExample :: Animation
-  219     > pathifyExample = animate $ \t -> gridLayout
-  220     >     [ [ partialSvg t $ pathify $ mkCircle 1
-  221     >       , partialSvg t $ pathify $ mkRect 2 2
-  222     >       ]
-  223     >     , [ partialSvg t $ pathify $ mkEllipse 1 0.5
-  224     >       , partialSvg t $ pathify $ mkLine (-1, -1) (1, 1)
-  225     >       ]
-  226     >     ]
-  227 
-  228     <<docs/gifs/doc_pathify.gif>>
-  229  -}
-  230 pathify :: Tree -> Tree
-  231 pathify = mapTree worker
-  232   where
-  233     worker =
-  234       \case
-  235         RectangleTree rect | Just (x,y,w,h) <- unpackRect rect ->
-  236           PathTree $ defaultSvg
-  237             & drawAttributes .~ rect ^. drawAttributes
-  238             & strokeLineCap .~ pure CapSquare
-  239             & pathDefinition .~
-  240               [MoveTo OriginAbsolute [V2 x y]
-  241               ,HorizontalTo OriginRelative [w]
-  242               ,VerticalTo OriginRelative [h]
-  243               ,HorizontalTo OriginRelative [-w]
-  244               ,EndPath ]
-  245         LineTree line | Just (x1,y1, x2, y2) <- unpackLine line ->
-  246           PathTree $ defaultSvg
-  247             & drawAttributes .~ line ^. drawAttributes
-  248             & pathDefinition .~
-  249               [MoveTo OriginAbsolute [V2 x1 y1]
-  250               ,LineTo OriginAbsolute [V2 x2 y2] ]
-  251         CircleTree circ | Just (x, y, r) <- unpackCircle circ ->
-  252           PathTree $ defaultSvg
-  253             & drawAttributes .~ circ ^. drawAttributes
-  254             & pathDefinition .~
-  255               [MoveTo OriginAbsolute [V2 (x-r) y]
-  256               ,EllipticalArc OriginRelative [(r, r, 0,True,False,V2 (r*2) 0)
-  257                                             ,(r, r, 0,True,False,V2 (-r*2) 0)]]
-  258         PolyLineTree pl ->
-  259           let points = pl ^. polyLinePoints
-  260           in PathTree $ defaultSvg
-  261                & drawAttributes .~ pl ^. drawAttributes
-  262                & pathDefinition .~ pointsToPathCommands points
-  263         PolygonTree pg ->
-  264           let points = pg ^. polygonPoints
-  265           in PathTree $ defaultSvg
-  266                & drawAttributes .~ pg ^. drawAttributes
-  267                -- Polygon automatically connects the last point to the first. For path we must do
-  268                -- it explicitly
-  269                & pathDefinition .~ (pointsToPathCommands points ++ [EndPath])
-  270         EllipseTree elip | Just (cx,cy,rx,ry) <- unpackEllipse elip ->
-  271           PathTree $ defaultSvg
-  272              & drawAttributes .~ elip ^. drawAttributes
-  273              & pathDefinition .~
-  274                [ MoveTo OriginAbsolute [V2 (cx-rx) cy]
-  275                , EllipticalArc OriginRelative [(rx, ry, 0,True,False,V2 (rx*2) 0)
-  276                                               ,(rx, ry, 0,True,False,V2 (-rx*2) 0)]]
-  277         t -> t
-  278     unpackCircle circ = do
-  279       let (x,y) = circ ^. circleCenter
-  280       liftM3 (,,) (unpackNumber x) (unpackNumber y) (unpackNumber $ circ ^. circleRadius)
-  281     unpackEllipse elip = do
-  282       let (x,y) = elip ^. ellipseCenter
-  283       liftM4 (,,,) (unpackNumber x) (unpackNumber y) (unpackNumber $ elip ^. ellipseXRadius)
-  284                   (unpackNumber $ elip ^. ellipseYRadius)
-  285     unpackLine line = do
-  286       let (x1,y1) = line ^. linePoint1
-  287           (x2,y2) = line ^. linePoint2
-  288       liftM4 (,,,) (unpackNumber x1) (unpackNumber y1) (unpackNumber x2) (unpackNumber y2)
-  289     unpackRect rect = do
-  290       let (x', y') = rect ^. rectUpperLeftCorner
-  291       x <- unpackNumber x'
-  292       y <- unpackNumber y'
-  293       w <- unpackNumber =<< rect ^. rectWidth
-  294       h <- unpackNumber =<< rect ^. rectHeight
-  295       return (x,y,w,h)
-  296     pointsToPathCommands points = case points of
-  297       [] -> []
-  298       (p:ps) -> [ MoveTo OriginAbsolute [p]
-  299                 , LineTo OriginAbsolute ps ]
-  300     unpackNumber n =
-  301       case toUserUnit defaultDPI n of
-  302         Num d -> Just d
-  303         _     -> Nothing
-  304 
-  305 mapSvgPaths :: ([PathCommand] -> [PathCommand]) -> SVG -> SVG
-  306 mapSvgPaths fn = mapTree worker
-  307   where
-  308     worker =
-  309       \case
-  310         PathTree path -> PathTree $
-  311           path & pathDefinition %~ fn
-  312         t -> t
-  313 
-  314 mapSvgLines :: ([LineCommand] -> [LineCommand]) -> SVG -> SVG
-  315 mapSvgLines fn = mapSvgPaths (lineToPath . fn . toLineCommands)
-  316 
-  317 -- Only maps points in paths
-  318 mapSvgPoints :: (RPoint -> RPoint) -> SVG -> SVG
-  319 mapSvgPoints fn = mapSvgLines (map worker)
-  320   where
-  321     worker (LineMove p) = LineMove (fn p)
-  322     worker (LineBezier ps) = LineBezier (map fn ps)
-  323     worker (LineEnd p) = LineEnd (fn p)
-  324 
-  325 svgPointsToRadians :: SVG -> SVG
-  326 svgPointsToRadians = mapSvgPoints worker
+    2 {-|
+    3 Copyright   : Written by David Himmelstrup
+    4 License     : Unlicense
+    5 Maintainer  : lemmih@gmail.com
+    6 Stability   : experimental
+    7 Portability : POSIX
+    8 -}
+    9 module Reanimate.Svg
+   10   ( module Reanimate.Svg
+   11   , module Reanimate.Svg.Constructors
+   12   , module Reanimate.Svg.LineCommand
+   13   , module Reanimate.Svg.BoundingBox
+   14   , module Reanimate.Svg.Unuse
+   15   ) where
+   16 
+   17 import           Control.Lens                 ((%~), (&), (.~), (^.), (?~))
+   18 import           Control.Monad.State
+   19 import           Graphics.SvgTree             hiding (height, line, path, use,
+   20                                                width)
+   21 import           Linear.V2                    hiding (angle)
+   22 import           Reanimate.Constants
+   23 import           Reanimate.Animation (SVG)
+   24 import           Reanimate.Svg.Constructors
+   25 import           Reanimate.Svg.LineCommand
+   26 import           Reanimate.Svg.BoundingBox
+   27 import           Reanimate.Svg.Unuse
+   28 import qualified Reanimate.Transform          as Transform
+   29 
+   30 -- | Remove transformations (such as translations, rotations, scaling)
+   31 --   and apply them directly to the SVG nodes. Note, this function
+   32 --   may convert nodes (such as Circle or Rect) to paths. Also note
+   33 --   that /does/ change how the SVG is rendered. Particularly, stroke
+   34 --   width is affected by directly applying scaling.
+   35 --
+   36 --   @lowerTransformations (scale 2 (mkCircle 1)) = mkCircle 2@
+   37 lowerTransformations :: Tree -> Tree
+   38 lowerTransformations = worker False Transform.identity
+   39   where
+   40     updLineCmd m cmd =
+   41       case cmd of
+   42         LineMove p    -> LineMove $ Transform.transformPoint m p
+   43         -- LineDraw p -> LineDraw $ Transform.transformPoint m p
+   44         LineBezier ps -> LineBezier $ map (Transform.transformPoint m) ps
+   45         LineEnd p     -> LineEnd $ Transform.transformPoint m p
+   46     updPath m = lineToPath . map (updLineCmd m) . toLineCommands
+   47     updPoint m (Num a,Num b) =
+   48       case Transform.transformPoint m (V2 a b) of
+   49         V2 x y -> (Num x, Num y)
+   50     updPoint _ other = other -- XXX: Can we do better here?
+   51     worker hasPathified m t =
+   52       let m' = m * Transform.mkMatrix (t^.transform) in
+   53       case t of
+   54         PathTree path -> PathTree $
+   55           path & pathDefinition %~ updPath m'
+   56                & transform .~ Nothing
+   57         GroupTree g -> GroupTree $
+   58           g & groupChildren %~ map (worker hasPathified m')
+   59             & transform .~ Nothing
+   60         LineTree line ->
+   61           LineTree $
+   62             line & linePoint1 %~ updPoint m
+   63                  & linePoint2 %~ updPoint m
+   64         ClipPathTree{} -> t
+   65         -- If we encounter an unknown node and we've already tried to convert
+   66         -- to paths, give up and insert an explicit transformation.
+   67         _ | hasPathified ->
+   68           mkGroup [t] & transform ?~ [ Transform.toTransformation m ]
+   69         -- If we haven't tried to pathify, run pathify only once.
+   70         _ -> worker True m (pathify t)
+   71 
+   72 -- | Remove all @id@ attributes.
+   73 lowerIds :: Tree -> Tree
+   74 lowerIds = mapTree worker
+   75   where
+   76     worker t@GroupTree{} = t & attrId .~ Nothing
+   77     worker t@PathTree{}  = t & attrId .~ Nothing
+   78     worker t             = t
+   79 
+   80 -- | Optimize SVG tree without affecting how it is rendered.
+   81 simplify :: Tree -> Tree
+   82 simplify root =
+   83   case worker root of
+   84     []  -> None
+   85     [x] -> x
+   86     xs  -> mkGroup xs
+   87   where
+   88     worker None = []
+   89     worker (DefinitionTree d) =
+   90       concatMap dropNulls
+   91       [DefinitionTree $ d & groupChildren %~ concatMap worker]
+   92     worker (GroupTree g)
+   93       | g ^. drawAttributes == defaultSvg =
+   94         concatMap dropNulls $
+   95         concatMap worker (g^.groupChildren)
+   96       | otherwise =
+   97         dropNulls $
+   98         GroupTree $ g & groupChildren %~ concatMap worker
+   99     worker t = dropNulls t
+  100 
+  101     dropNulls None = []
+  102     dropNulls (DefinitionTree d)
+  103       | null (d^.groupChildren) = []
+  104     dropNulls (GroupTree g)
+  105       | null (g^.groupChildren) = []
+  106     dropNulls t = [t]
+  107 
+  108 -- | Separate grouped items. This is required by clip nodes.
+  109 --
+  110 -- @removeGroups (withFillColor "blue" $ mkGroup [mkCircle 1, mkRect 1 1])
+  111 --    = [ withFillColor "blue" $ mkCircle 1
+  112 --      , withFillColor "blue" $ mkRect 1 1 ]@
+  113 removeGroups :: Tree -> [Tree]
+  114 removeGroups = worker defaultSvg
+  115   where
+  116     worker _attr None = []
+  117     worker _attr (DefinitionTree d) =
+  118       concatMap dropNulls
+  119       [DefinitionTree $ d & groupChildren %~ concatMap (worker defaultSvg)]
+  120     worker attr (GroupTree g)
+  121       | g ^. drawAttributes == defaultSvg =
+  122         concatMap dropNulls $
+  123         concatMap (worker attr) (g^.groupChildren)
+  124       | otherwise =
+  125         concatMap (worker (attr <> g ^. drawAttributes)) (g^.groupChildren)
+  126     worker attr t = dropNulls (t & drawAttributes .~ attr)
+  127 
+  128     dropNulls None = []
+  129     dropNulls (DefinitionTree d)
+  130       | null (d^.groupChildren) = []
+  131     dropNulls (GroupTree g)
+  132       | null (g^.groupChildren) = []
+  133     dropNulls t = [t]
+  134 
+  135 -- | Extract all path commands from a node (and its children) and concatenate them.
+  136 extractPath :: Tree -> [PathCommand]
+  137 extractPath = worker . simplify . lowerTransformations . pathify
+  138   where
+  139     worker (GroupTree g) = concatMap worker (g^.groupChildren)
+  140     worker (PathTree p)  = p^.pathDefinition
+  141     worker _             = []
+  142 
+  143 withSubglyphs :: [Int] -> (Tree -> Tree) -> Tree -> Tree
+  144 withSubglyphs target fn = \t -> evalState (worker t) 0
+  145   where
+  146     worker :: Tree -> State Int Tree
+  147     worker t =
+  148       case t of
+  149         GroupTree g -> do
+  150           cs <- mapM worker (g ^. groupChildren)
+  151           return $ GroupTree $ g & groupChildren .~ cs
+  152         PathTree{} -> handleGlyph t
+  153         CircleTree{} -> handleGlyph t
+  154         PolyLineTree{} -> handleGlyph t
+  155         PolygonTree{} -> handleGlyph t
+  156         EllipseTree{} -> handleGlyph t
+  157         LineTree{} -> handleGlyph t
+  158         RectangleTree{} -> handleGlyph t
+  159         _ -> return t
+  160     handleGlyph :: Tree -> State Int Tree
+  161     handleGlyph svg = do
+  162       n <- get <* modify (+1)
+  163       if n `elem` target
+  164         then return $ fn svg
+  165         else return svg
+  166 
+  167 splitGlyphs :: [Int] -> Tree -> (Tree, Tree)
+  168 splitGlyphs target = \t ->
+  169     let (_, l, r) = execState (worker id t) (0, [], [])
+  170     in (mkGroup l, mkGroup r)
+  171   where
+  172     handleGlyph :: Tree -> State (Int, [Tree], [Tree]) ()
+  173     handleGlyph t = do
+  174       (n, l, r) <- get
+  175       if n `elem` target
+  176         then put (n+1, l, t:r)
+  177         else put (n+1, t:l, r)
+  178     worker :: (Tree -> Tree) -> Tree -> State (Int, [Tree], [Tree]) ()
+  179     worker acc t =
+  180       case t of
+  181         GroupTree g -> do
+  182           let acc' sub = acc (GroupTree $ g & groupChildren .~ [sub])
+  183           mapM_ (worker acc') (g ^. groupChildren)
+  184         PathTree{} -> handleGlyph $ acc t
+  185         CircleTree{} -> handleGlyph $ acc t
+  186         PolyLineTree{} -> handleGlyph $ acc t
+  187         PolygonTree{} -> handleGlyph $ acc t
+  188         EllipseTree{} -> handleGlyph $ acc t
+  189         LineTree{} -> handleGlyph $ acc t
+  190         RectangleTree{} -> handleGlyph $ acc t
+  191         DefinitionTree{} -> return ()
+  192         _ ->
+  193           modify $ \(n, l, r) -> (n, acc t:l, r)
+  194 {-
+  195 <g transform="translate(10,10)">
+  196   <g transform="scale(2)">
+  197     <circle/>
+  198   </g>
+  199   <g transform="scale(0.5)">
+  200     <rect/>
+  201   </g>
+  202 </g>
+  203 
+  204 [ (\svg -> <g transform="translate(10,10)"><g transform="scale(2)">svg</g></g>, <circle/>)
+  205 , (\svg -> <g transform="translate(10,10)"><g transform="scale(0.5)">svg</g></g>, <rect/>)]
+  206 -}
+  207 svgGlyphs :: Tree -> [(Tree -> Tree, DrawAttributes, Tree)]
+  208 svgGlyphs = worker id defaultSvg
+  209   where
+  210     worker acc attr =
+  211       \case
+  212         None -> []
+  213         GroupTree g ->
+  214           let acc' sub = acc (GroupTree $ g & groupChildren .~ [sub])
+  215               attr' = (g^.drawAttributes) `mappend` attr
+  216           in concatMap (worker acc' attr') (g ^. groupChildren)
+  217         t -> [(acc, (t^.drawAttributes) `mappend` attr, t)]
+  218 
+  219 {-| Convert primitive SVG shapes (like those created by 'mkCircle', 'mkRect', 'mkLine' or
+  220     'mkEllipse') into SVG path. This can be useful for creating animations of these shapes being
+  221     drawn progressively with 'partialSvg'.
+  222 
+  223     Example:
+  224 
+  225     > pathifyExample :: Animation
+  226     > pathifyExample = animate $ \t -> gridLayout
+  227     >     [ [ partialSvg t $ pathify $ mkCircle 1
+  228     >       , partialSvg t $ pathify $ mkRect 2 2
+  229     >       ]
+  230     >     , [ partialSvg t $ pathify $ mkEllipse 1 0.5
+  231     >       , partialSvg t $ pathify $ mkLine (-1, -1) (1, 1)
+  232     >       ]
+  233     >     ]
+  234 
+  235     <<docs/gifs/doc_pathify.gif>>
+  236  -}
+  237 pathify :: Tree -> Tree
+  238 pathify = mapTree worker
+  239   where
+  240     worker =
+  241       \case
+  242         RectangleTree rect | Just (x,y,w,h) <- unpackRect rect ->
+  243           PathTree $ defaultSvg
+  244             & drawAttributes .~ rect ^. drawAttributes
+  245             & strokeLineCap .~ pure CapSquare
+  246             & pathDefinition .~
+  247               [MoveTo OriginAbsolute [V2 x y]
+  248               ,HorizontalTo OriginRelative [w]
+  249               ,VerticalTo OriginRelative [h]
+  250               ,HorizontalTo OriginRelative [-w]
+  251               ,EndPath ]
+  252         LineTree line | Just (x1,y1, x2, y2) <- unpackLine line ->
+  253           PathTree $ defaultSvg
+  254             & drawAttributes .~ line ^. drawAttributes
+  255             & pathDefinition .~
+  256               [MoveTo OriginAbsolute [V2 x1 y1]
+  257               ,LineTo OriginAbsolute [V2 x2 y2] ]
+  258         CircleTree circ | Just (x, y, r) <- unpackCircle circ ->
+  259           PathTree $ defaultSvg
+  260             & drawAttributes .~ circ ^. drawAttributes
+  261             & pathDefinition .~
+  262               [MoveTo OriginAbsolute [V2 (x-r) y]
+  263               ,EllipticalArc OriginRelative [(r, r, 0,True,False,V2 (r*2) 0)
+  264                                             ,(r, r, 0,True,False,V2 (-r*2) 0)]]
+  265         PolyLineTree pl ->
+  266           let points = pl ^. polyLinePoints
+  267           in PathTree $ defaultSvg
+  268                & drawAttributes .~ pl ^. drawAttributes
+  269                & pathDefinition .~ pointsToPathCommands points
+  270         PolygonTree pg ->
+  271           let points = pg ^. polygonPoints
+  272           in PathTree $ defaultSvg
+  273                & drawAttributes .~ pg ^. drawAttributes
+  274                -- Polygon automatically connects the last point to the first. For path we must do
+  275                -- it explicitly
+  276                & pathDefinition .~ (pointsToPathCommands points ++ [EndPath])
+  277         EllipseTree elip | Just (cx,cy,rx,ry) <- unpackEllipse elip ->
+  278           PathTree $ defaultSvg
+  279              & drawAttributes .~ elip ^. drawAttributes
+  280              & pathDefinition .~
+  281                [ MoveTo OriginAbsolute [V2 (cx-rx) cy]
+  282                , EllipticalArc OriginRelative [(rx, ry, 0,True,False,V2 (rx*2) 0)
+  283                                               ,(rx, ry, 0,True,False,V2 (-rx*2) 0)]]
+  284         t -> t
+  285     unpackCircle circ = do
+  286       let (x,y) = circ ^. circleCenter
+  287       liftM3 (,,) (unpackNumber x) (unpackNumber y) (unpackNumber $ circ ^. circleRadius)
+  288     unpackEllipse elip = do
+  289       let (x,y) = elip ^. ellipseCenter
+  290       liftM4 (,,,) (unpackNumber x) (unpackNumber y) (unpackNumber $ elip ^. ellipseXRadius)
+  291                   (unpackNumber $ elip ^. ellipseYRadius)
+  292     unpackLine line = do
+  293       let (x1,y1) = line ^. linePoint1
+  294           (x2,y2) = line ^. linePoint2
+  295       liftM4 (,,,) (unpackNumber x1) (unpackNumber y1) (unpackNumber x2) (unpackNumber y2)
+  296     unpackRect rect = do
+  297       let (x', y') = rect ^. rectUpperLeftCorner
+  298       x <- unpackNumber x'
+  299       y <- unpackNumber y'
+  300       w <- unpackNumber =<< rect ^. rectWidth
+  301       h <- unpackNumber =<< rect ^. rectHeight
+  302       return (x,y,w,h)
+  303     pointsToPathCommands points = case points of
+  304       [] -> []
+  305       (p:ps) -> [ MoveTo OriginAbsolute [p]
+  306                 , LineTo OriginAbsolute ps ]
+  307     unpackNumber n =
+  308       case toUserUnit defaultDPI n of
+  309         Num d -> Just d
+  310         _     -> Nothing
+  311 
+  312 mapSvgPaths :: ([PathCommand] -> [PathCommand]) -> SVG -> SVG
+  313 mapSvgPaths fn = mapTree worker
+  314   where
+  315     worker =
+  316       \case
+  317         PathTree path -> PathTree $
+  318           path & pathDefinition %~ fn
+  319         t -> t
+  320 
+  321 mapSvgLines :: ([LineCommand] -> [LineCommand]) -> SVG -> SVG
+  322 mapSvgLines fn = mapSvgPaths (lineToPath . fn . toLineCommands)
+  323 
+  324 -- Only maps points in paths
+  325 mapSvgPoints :: (RPoint -> RPoint) -> SVG -> SVG
+  326 mapSvgPoints fn = mapSvgLines (map worker)
   327   where
-  328     worker (V2 x y) = V2 (x/180*pi) (y/180*pi)
+  328     worker (LineMove p) = LineMove (fn p)
+  329     worker (LineBezier ps) = LineBezier (map fn ps)
+  330     worker (LineEnd p) = LineEnd (fn p)
+  331 
+  332 svgPointsToRadians :: SVG -> SVG
+  333 svgPointsToRadians = mapSvgPoints worker
+  334   where
+  335     worker (V2 x y) = V2 (x/180*pi) (y/180*pi)
diff --git a/reanimate-0.4.1.0-inplace/Reanimate.Transition.hs.html b/reanimate-0.4.1.0-inplace/Reanimate.Transition.hs.html index 1732697..bf56491 100644 --- a/reanimate-0.4.1.0-inplace/Reanimate.Transition.hs.html +++ b/reanimate-0.4.1.0-inplace/Reanimate.Transition.hs.html @@ -17,75 +17,82 @@ span.spaces { background: white } never executed always true always false 
-    1 module Reanimate.Transition
-    2   ( Transition
-    3   , signalT
-    4   , mapT
-    5   , overlapT
-    6   , chainT
-    7   , effectT
-    8   , fadeT
-    9   ) where
-   10 
-   11 import Reanimate.Animation
-   12 import Reanimate.Ease
-   13 import Reanimate.Effect
-   14 
-   15 -- | A transition transforms one animation into another.
-   16 type Transition = Animation -> Animation -> Animation
+    1 {-|
+    2 Copyright   : Written by David Himmelstrup
+    3 License     : Unlicense
+    4 Maintainer  : lemmih@gmail.com
+    5 Stability   : experimental
+    6 Portability : POSIX
+    7 -}
+    8 module Reanimate.Transition
+    9   ( Transition
+   10   , signalT
+   11   , mapT
+   12   , overlapT
+   13   , chainT
+   14   , effectT
+   15   , fadeT
+   16   ) where
    17 
-   18 -- | Apply a signal to the timing of a transition.
-   19 signalT :: Signal -> Transition -> Transition
-   20 signalT = mapT . signalA
+   18 import Reanimate.Animation
+   19 import Reanimate.Ease
+   20 import Reanimate.Effect
    21 
-   22 -- | Map the result of a transition.
-   23 mapT :: (Animation -> Animation) -> Transition -> Transition
-   24 mapT fn t a b = fn (t a b)
-   25 
-   26 -- | Apply transition only to @N@ seconds of the first
-   27 --   animation and to the last @N@ seconds of the second animation.
-   28 --
-   29 --   Example:
-   30 --
-   31 --   > overlapT 0.5 fadeT drawBox drawCircle
-   32 --
-   33 --   <<docs/gifs/doc_overlapT.gif>>
-   34 overlapT :: Double -> Transition -> Transition
-   35 overlapT overlap t a b =
-   36     aBefore `seqA` t aOverlap bOverlap `seqA` bAfter
-   37   where
-   38     aBefore  = takeA (duration a - overlap) a
-   39     aOverlap = lastA overlap a
-   40     bOverlap = takeA overlap b
-   41     bAfter   = dropA overlap b
-   42 
-   43 
-   44 -- | Create a transition between two animations by applying an effect to each respective animation.
-   45 effectT :: Effect -- ^ Effect to be applied to the first animation.
-   46         -> Effect -- ^ Effect to be applied to the second animation.
-   47         -> Transition
-   48 effectT eA eB a b = applyE eA a `parA` applyE eB b
+   22 -- | A transition transforms one animation into another.
+   23 type Transition = Animation -> Animation -> Animation
+   24 
+   25 -- | Apply a signal to the timing of a transition.
+   26 signalT :: Signal -> Transition -> Transition
+   27 signalT = mapT . signalA
+   28 
+   29 -- | Map the result of a transition.
+   30 mapT :: (Animation -> Animation) -> Transition -> Transition
+   31 mapT fn t a b = fn (t a b)
+   32 
+   33 -- | Apply transition only to @N@ seconds of the first
+   34 --   animation and to the last @N@ seconds of the second animation.
+   35 --
+   36 --   Example:
+   37 --
+   38 --   > overlapT 0.5 fadeT drawBox drawCircle
+   39 --
+   40 --   <<docs/gifs/doc_overlapT.gif>>
+   41 overlapT :: Double -> Transition -> Transition
+   42 overlapT overlap t a b =
+   43     aBefore `seqA` t aOverlap bOverlap `seqA` bAfter
+   44   where
+   45     aBefore  = takeA (duration a - overlap) a
+   46     aOverlap = lastA overlap a
+   47     bOverlap = takeA overlap b
+   48     bAfter   = dropA overlap b
    49 
-   50 -- | Combine a list of animations using a given transition.
-   51 --
-   52 --   Example:
-   53 --
-   54 --   > chainT (overlapT 0.5 fadeT) [drawBox, drawCircle, drawProgress]
-   55 --
-   56 --   <<docs/gifs/doc_chainT.gif>>
-   57 chainT :: Transition -> [Animation] -> Animation
-   58 chainT _ [] = pause 0
-   59 chainT t (x:xs) = foldl t x xs
-   60 
-   61 -- | Fade out left-hand-side animation while fading in right-hand-side animation.
+   50 
+   51 -- | Create a transition between two animations by applying an effect to each respective animation.
+   52 effectT :: Effect -- ^ Effect to be applied to the first animation.
+   53         -> Effect -- ^ Effect to be applied to the second animation.
+   54         -> Transition
+   55 effectT eA eB a b = applyE eA a `parA` applyE eB b
+   56 
+   57 -- | Combine a list of animations using a given transition.
+   58 --
+   59 --   Example:
+   60 --
+   61 --   > chainT (overlapT 0.5 fadeT) [drawBox, drawCircle, drawProgress]
    62 --
-   63 --   Example:
-   64 --
-   65 --   > drawBox `fadeT` drawCircle
-   66 --
-   67 --   <<docs/gifs/doc_fadeT.gif>>
-   68 fadeT :: Transition
-   69 fadeT = effectT fadeOutE fadeInE
+   63 --   <<docs/gifs/doc_chainT.gif>>
+   64 chainT :: Transition -> [Animation] -> Animation
+   65 chainT _ [] = pause 0
+   66 chainT t (x:xs) = foldl t x xs
+   67 
+   68 -- | Fade out left-hand-side animation while fading in right-hand-side animation.
+   69 --
+   70 --   Example:
+   71 --
+   72 --   > drawBox `fadeT` drawCircle
+   73 --
+   74 --   <<docs/gifs/doc_fadeT.gif>>
+   75 fadeT :: Transition
+   76 fadeT = effectT fadeOutE fadeInE