diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,10 +1,34 @@ # Revision history for reanimate +## 0.4.0.0 + +* Show progress when running ffmpeg. +* Small improvements to the scene API. +* Bug fixes to the voice API. +* Support ImageMagick version 7. +* Improved Windows build support. +* Improved error reporting in web-viewer. +* Improved error messages when ffmpeg doesn't support SVGs. +* Improved filter-effect support. +* Generalized LaTeX support. +* New experimental object system. +* Discord bot capable of rendering animations in chat. +* Lots of assorted bug fixes and minor improvements. + +## 0.3.3.0 -- 2020-05-22 + +* Voice control via the Gentle forced-aligner. +* Rename Reanimate.Interpolate to Reanimate.ColorComponents +* Rename Reanimate.Signals to Reanimate.Ease +* Fix positioning of latex output such that the baseline starts at (0,0) + ## 0.3.2.0 -- 2020-05-16 * Fix bug that forced GIF width to 320 pixels. * Add helper for creating custom viewboxes, withViewBox. * Add newSprite_, newSpriteSVG_. +* Drop support for lts-11 and lts-12. Lts-15, lts-14 and lts-13 are supported. +* Add common interface for polygon morphing. ## 0.3.1.0 -- 2020-05-12 diff --git a/docs/gifs/doc_ctex.gif b/docs/gifs/doc_ctex.gif new file mode 100644 Binary files /dev/null and b/docs/gifs/doc_ctex.gif differ diff --git a/docs/gifs/doc_identityS.gif b/docs/gifs/doc_identityS.gif deleted file mode 100644 Binary files a/docs/gifs/doc_identityS.gif and /dev/null differ diff --git a/docs/gifs/doc_signalFlat.gif b/docs/gifs/doc_signalFlat.gif deleted file mode 100644 Binary files a/docs/gifs/doc_signalFlat.gif and /dev/null differ diff --git a/docs/gifs/doc_signalT.gif b/docs/gifs/doc_signalT.gif deleted file mode 100644 Binary files a/docs/gifs/doc_signalT.gif and /dev/null differ diff --git a/docs/gifs/doc_slideLeftT.gif b/docs/gifs/doc_slideLeftT.gif new file mode 100644 Binary files /dev/null and b/docs/gifs/doc_slideLeftT.gif differ diff --git a/docs/gifs/doc_xelatex.gif b/docs/gifs/doc_xelatex.gif deleted file mode 100644 Binary files a/docs/gifs/doc_xelatex.gif and /dev/null differ diff --git a/examples/blender_default_cube.hs b/examples/blender_default_cube.hs --- a/examples/blender_default_cube.hs +++ b/examples/blender_default_cube.hs @@ -4,35 +4,24 @@ {-# LANGUAGE QuasiQuotes #-} module Main (main) where -import Data.String.Here +import qualified Data.Text as T +import NeatInterpolation import Reanimate +import Reanimate.Builtin.Documentation main :: IO () -main = reanimate $ mkAnimation 5 $ \t -> - let s = t * pi in - mkGroup - [ mkBackground "black" - , blender (script s) - , withFillColor "white" $ - translate 0 2 $ - mkText "default cube" +main = reanimate $ docEnv $ mkAnimation 5 $ \t -> mkGroup + [ blender (script $ T.pack $ show $ t*pi) + , withFillOpacity 1 $ withFillColor "black" $ withStrokeWidth 0 $ + translate 0 3 $ scale 2 $ center $ + latex "\\textbf{default cube}" ] where - script s = [iTrim| -import bpy - -if __name__ == "__main__": - # Args - resolution_percentage = 40 - - # Setting - default_scene = bpy.context.scene - default_scene.render.resolution_percentage = resolution_percentage - default_scene.render.film_transparent = True + script s = [text| + import bpy - default_cube = bpy.data.objects["Cube"] - default_cube.rotation_euler = (0,0,${s}) + bpy.context.scene.render.film_transparent = True + bpy.data.objects["Cube"].rotation_euler = (0,0,${s}) - # Rendering bpy.ops.render.render(animation=False, write_still=True) |] diff --git a/examples/blender_sphere.hs b/examples/blender_sphere.hs --- a/examples/blender_sphere.hs +++ b/examples/blender_sphere.hs @@ -4,8 +4,8 @@ {-# LANGUAGE QuasiQuotes #-} module Main (main) where -import Data.String.Here import qualified Data.Text as T +import NeatInterpolation import Reanimate main :: IO () @@ -13,18 +13,18 @@ let s = t * pi * 2 in mkGroup [ mkBackground "black" - , blender (script s) + , blender (script $ T.pack $ show s) ] -texture :: FilePath -texture = svgAsPngFile (mkGroup +texture :: T.Text +texture = T.pack $ svgAsPngFile (mkGroup [ checker 10 10 , withFillColor "red" $ scale 2 $ center $ latexAlign "\\sum_{k=1}^\\infty {1 \\over k^2} = {\\pi^2 \\over 6}"]) -script :: Double -> T.Text -script s = [iTrim| +script :: T.Text -> T.Text +script s = [text| import os import bpy @@ -48,7 +48,7 @@ texture.inputs['Roughness'].default_value = 1 mat.node_tree.links.new(image_node.outputs['Color'], texture.inputs['Base Color']) -image_node.image = bpy.data.images.load('${T.pack texture}') +image_node.image = bpy.data.images.load('${texture}') scn = bpy.context.scene #scn.render.engine = 'CYCLES' diff --git a/examples/bug_latex.hs b/examples/bug_latex.hs new file mode 100644 --- /dev/null +++ b/examples/bug_latex.hs @@ -0,0 +1,11 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +{-# LANGUAGE OverloadedStrings #-} +module Main(main) where + +import Reanimate +import Reanimate.Builtin.Documentation + +main :: IO () +main = reanimate $ docEnv $ + staticFrame 1 $ latex "\\textbf{$\\textsf{2}^{\\textsf{16}}$}" diff --git a/examples/bug_play1.golden b/examples/bug_play1.golden --- a/examples/bug_play1.golden +++ b/examples/bug_play1.golden @@ -8,43 +8,3 @@ 7 8 9 -10 -11 -12 -13 -14 -15 -16 -17 -18 -19 -20 -21 -22 -23 -24 -25 -26 -27 -28 -29 -30 -31 -32 -33 -34 -35 -36 -37 -38 -39 -40 -41 -42 -43 -44 -45 -46 -47 -48 -49 diff --git a/examples/bug_play2.golden b/examples/bug_play2.golden --- a/examples/bug_play2.golden +++ b/examples/bug_play2.golden @@ -8,43 +8,3 @@ 7 8 9 -10 -11 -12 -13 -14 -15 -16 -17 -18 -19 -20 -21 -22 -23 -24 -25 -26 -27 -28 -29 -30 -31 -32 -33 -34 -35 -36 -37 -38 -39 -40 -41 -42 -43 -44 -45 -46 -47 -48 -49 diff --git a/examples/bug_play3.golden b/examples/bug_play3.golden --- a/examples/bug_play3.golden +++ b/examples/bug_play3.golden @@ -8,43 +8,3 @@ 7 8 9 -10 -11 -12 -13 -14 -15 -16 -17 -18 -19 -20 -21 -22 -23 -24 -25 -26 -27 -28 -29 -30 -31 -32 -33 -34 -35 -36 -37 -38 -39 -40 -41 -42 -43 -44 -45 -46 -47 -48 -49 diff --git a/examples/bug_quad.golden b/examples/bug_quad.golden new file mode 100644 --- /dev/null +++ b/examples/bug_quad.golden @@ -0,0 +1,10 @@ +0 +1 +2 +3 +4 +5 +6 +7 +8 +9 diff --git a/examples/bug_quad.hs b/examples/bug_quad.hs new file mode 100644 --- /dev/null +++ b/examples/bug_quad.hs @@ -0,0 +1,15 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +module Main(main) where + +import Reanimate +import Reanimate.Builtin.Documentation +import Reanimate.Morph.Common +import Reanimate.Morph.Linear + +main :: IO () +main = reanimate $ docEnv $ sceneAnimation $ do + play $ animate $ \t -> morph rawLinear src dst t + where + src = mkPathString "M 0 0 q 1 1, 2 0 z" + dst = mkPathString "M 0 0 q 1 2, 2 0 z" diff --git a/examples/bug_use.hs b/examples/bug_use.hs new file mode 100644 --- /dev/null +++ b/examples/bug_use.hs @@ -0,0 +1,11 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +{-# LANGUAGE OverloadedStrings #-} +module Main(main) where + +import Reanimate +import Reanimate.Builtin.Documentation + +main :: IO () +main = reanimate $ docEnv $ + staticFrame 1 $ latex "\\textbf{$\\textsf{2}^{\\textsf{16}}$}" diff --git a/examples/counter.golden b/examples/counter.golden --- a/examples/counter.golden +++ b/examples/counter.golden @@ -1,50 +1,10 @@ 0 -1 -2 -3 -4 -5 -6 -7 -8 -9 -10 -11 -12 -13 -14 -15 -16 -17 -18 -19 -20 -21 -22 -23 -24 -25 -26 -27 -28 -29 -30 -31 -32 -33 -34 -35 -36 -37 -38 -39 -40 -41 -42 -43 -44 -45 -46 -47 -48 -49 +1 +2 +3 +4 +5 +6 +7 +8 +9 diff --git a/examples/doc_addStatic.golden b/examples/doc_addStatic.golden --- a/examples/doc_addStatic.golden +++ b/examples/doc_addStatic.golden @@ -1,50 +1,10 @@ 0 -1 -2 -3 -4 -5 -6 -7 -8 -9 -10 -11 -12 -13 -14 -15 -16 -17 -18 -19 -20 -21 -22 -23 -24 -25 -26 -27 -28 -29 -30 -31 -32 -33 -34 -35 -36 -37 -38 -39 -40 -41 -42 -43 -44 -45 -46 -47 -48 -49 +1 +2 +3 +4 +5 +6 +7 +8 +9 diff --git a/examples/doc_andThen.golden b/examples/doc_andThen.golden --- a/examples/doc_andThen.golden +++ b/examples/doc_andThen.golden @@ -1,50 +1,10 @@ 0 -1 -2 -3 -4 -5 -6 -7 -8 -9 -10 -11 -12 -13 -14 -15 -16 -17 -18 -19 -20 -21 -22 -23 -24 -25 -26 -27 -28 -29 -30 -31 -32 -33 -34 -35 -36 -37 -38 -39 -40 -41 -42 -43 -44 -45 -46 -47 -48 -49 +1 +2 +3 +4 +5 +6 +7 +8 +9 diff --git a/examples/doc_applyVar.golden b/examples/doc_applyVar.golden --- a/examples/doc_applyVar.golden +++ b/examples/doc_applyVar.golden @@ -1,50 +1,10 @@ 0 -1 -2 -3 -4 -5 -6 -7 -8 -9 -10 -11 -12 -13 -14 -15 -16 -17 -18 -19 -20 -21 -22 -23 -24 -25 -26 -27 -28 -29 -30 -31 -32 -33 -34 -35 -36 -37 -38 -39 -40 -41 -42 -43 -44 -45 -46 -47 -48 -49 +1 +2 +3 +4 +5 +6 +7 +8 +9 diff --git a/examples/doc_bellS.golden b/examples/doc_bellS.golden --- a/examples/doc_bellS.golden +++ b/examples/doc_bellS.golden @@ -1,50 +1,10 @@ 0 -1 -2 -3 -4 -5 -6 -7 -8 -9 -10 -11 -12 -13 -14 -15 -16 -17 -18 -19 -20 -21 -22 -23 -24 -25 -26 -27 -28 -29 -30 -31 -32 -33 -34 -35 -36 -37 -38 -39 -40 -41 -42 -43 -44 -45 -46 -47 -48 -49 +1 +2 +3 +4 +5 +6 +7 +8 +9 diff --git a/examples/doc_chainT.golden b/examples/doc_chainT.golden --- a/examples/doc_chainT.golden +++ b/examples/doc_chainT.golden @@ -1,50 +1,10 @@ 0 -1 -2 -3 -4 -5 -6 -7 -8 -9 -10 -11 -12 -13 -14 -15 -16 -17 -18 -19 -20 -21 -22 -23 -24 -25 -26 -27 -28 -29 -30 -31 -32 -33 -34 -35 -36 -37 -38 -39 -40 -41 -42 -43 -44 -45 -46 -47 -48 -49 +1 +2 +3 +4 +5 +6 +7 +8 +9 diff --git a/examples/doc_cividis.golden b/examples/doc_cividis.golden --- a/examples/doc_cividis.golden +++ b/examples/doc_cividis.golden @@ -8,43 +8,3 @@ 7 8 9 -10 -11 -12 -13 -14 -15 -16 -17 -18 -19 -20 -21 -22 -23 -24 -25 -26 -27 -28 -29 -30 -31 -32 -33 -34 -35 -36 -37 -38 -39 -40 -41 -42 -43 -44 -45 -46 -47 -48 -49 diff --git a/examples/doc_constantS.golden b/examples/doc_constantS.golden --- a/examples/doc_constantS.golden +++ b/examples/doc_constantS.golden @@ -8,43 +8,3 @@ 7 8 9 -10 -11 -12 -13 -14 -15 -16 -17 -18 -19 -20 -21 -22 -23 -24 -25 -26 -27 -28 -29 -30 -31 -32 -33 -34 -35 -36 -37 -38 -39 -40 -41 -42 -43 -44 -45 -46 -47 -48 -49 diff --git a/examples/doc_ctex.hs b/examples/doc_ctex.hs new file mode 100644 --- /dev/null +++ b/examples/doc_ctex.hs @@ -0,0 +1,12 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +{-# LANGUAGE OverloadedStrings #-} +module Main (main) where + +import Reanimate +import Reanimate.Builtin.Documentation + +main :: IO () +main = reanimate $ docEnv $ animate $ const $ + withStrokeWidth 0 . withFillOpacity 1 . scale 4 . center $ + ctex "中文" diff --git a/examples/doc_cubicBezierS.golden b/examples/doc_cubicBezierS.golden --- a/examples/doc_cubicBezierS.golden +++ b/examples/doc_cubicBezierS.golden @@ -1,50 +1,10 @@ 0 -1 -2 -3 -4 -5 -6 -7 -8 -9 -10 -11 -12 -13 -14 -15 -16 -17 -18 -19 -20 -21 -22 -23 -24 -25 -26 -27 -28 -29 -30 -31 -32 -33 -34 -35 -36 -37 -38 -39 -40 -41 -42 -43 -44 -45 -46 -47 -48 -49 +1 +2 +3 +4 +5 +6 +7 +8 +9 diff --git a/examples/doc_curveS.golden b/examples/doc_curveS.golden --- a/examples/doc_curveS.golden +++ b/examples/doc_curveS.golden @@ -1,50 +1,10 @@ 0 -1 -2 -3 -4 -5 -6 -7 -8 -9 -10 -11 -12 -13 -14 -15 -16 -17 -18 -19 -20 -21 -22 -23 -24 -25 -26 -27 -28 -29 -30 -31 -32 -33 -34 -35 -36 -37 -38 -39 -40 -41 -42 -43 -44 -45 -46 -47 -48 -49 +1 +2 +3 +4 +5 +6 +7 +8 +9 diff --git a/examples/doc_destroySprite.golden b/examples/doc_destroySprite.golden --- a/examples/doc_destroySprite.golden +++ b/examples/doc_destroySprite.golden @@ -1,50 +1,10 @@ 0 -1 -2 -3 -4 -5 -6 -7 -8 -9 -10 -11 -12 -13 -14 -15 -16 -17 -18 -19 -20 -21 -22 -23 -24 -25 -26 -27 -28 -29 -30 -31 -32 -33 -34 -35 -36 -37 -38 -39 -40 -41 -42 -43 -44 -45 -46 -47 -48 -49 +1 +2 +3 +4 +5 +6 +7 +8 +9 diff --git a/examples/doc_drawBox.golden b/examples/doc_drawBox.golden --- a/examples/doc_drawBox.golden +++ b/examples/doc_drawBox.golden @@ -1,50 +1,10 @@ 0 -1 -2 -3 -4 -5 -6 -7 -8 -9 -10 -11 -12 -13 -14 -15 -16 -17 -18 -19 -20 -21 -22 -23 -24 -25 -26 -27 -28 -29 -30 -31 -32 -33 -34 -35 -36 -37 -38 -39 -40 -41 -42 -43 -44 -45 -46 -47 -48 -49 +1 +2 +3 +4 +5 +6 +7 +8 +9 diff --git a/examples/doc_drawCircle.golden b/examples/doc_drawCircle.golden --- a/examples/doc_drawCircle.golden +++ b/examples/doc_drawCircle.golden @@ -1,50 +1,10 @@ 0 -1 -2 -3 -4 -5 -6 -7 -8 -9 -10 -11 -12 -13 -14 -15 -16 -17 -18 -19 -20 -21 -22 -23 -24 -25 -26 -27 -28 -29 -30 -31 -32 -33 -34 -35 -36 -37 -38 -39 -40 -41 -42 -43 -44 -45 -46 -47 -48 -49 +1 +2 +3 +4 +5 +6 +7 +8 +9 diff --git a/examples/doc_drawProgress.golden b/examples/doc_drawProgress.golden --- a/examples/doc_drawProgress.golden +++ b/examples/doc_drawProgress.golden @@ -1,50 +1,10 @@ 0 -1 -2 -3 -4 -5 -6 -7 -8 -9 -10 -11 -12 -13 -14 -15 -16 -17 -18 -19 -20 -21 -22 -23 -24 -25 -26 -27 -28 -29 -30 -31 -32 -33 -34 -35 -36 -37 -38 -39 -40 -41 -42 -43 -44 -45 -46 -47 -48 -49 +1 +2 +3 +4 +5 +6 +7 +8 +9 diff --git a/examples/doc_fadeT.golden b/examples/doc_fadeT.golden --- a/examples/doc_fadeT.golden +++ b/examples/doc_fadeT.golden @@ -1,50 +1,10 @@ 0 -1 -2 -3 -4 -5 -6 -7 -8 -9 -10 -11 -12 -13 -14 -15 -16 -17 -18 -19 -20 -21 -22 -23 -24 -25 -26 -27 -28 -29 -30 -31 -32 -33 -34 -35 -36 -37 -38 -39 -40 -41 -42 -43 -44 -45 -46 -47 -48 -49 +1 +2 +3 +4 +5 +6 +7 +8 +9 diff --git a/examples/doc_fork.golden b/examples/doc_fork.golden --- a/examples/doc_fork.golden +++ b/examples/doc_fork.golden @@ -1,50 +1,10 @@ 0 -1 -2 -3 -4 -5 -6 -7 -8 -9 -10 -11 -12 -13 -14 -15 -16 -17 -18 -19 -20 -21 -22 -23 -24 -25 -26 -27 -28 -29 -30 -31 -32 -33 -34 -35 -36 -37 -38 -39 -40 -41 -42 -43 -44 -45 -46 -47 -48 -49 +1 +2 +3 +4 +5 +6 +7 +8 +9 diff --git a/examples/doc_fromToS.golden b/examples/doc_fromToS.golden --- a/examples/doc_fromToS.golden +++ b/examples/doc_fromToS.golden @@ -1,50 +1,10 @@ 0 -1 -2 -3 -4 -5 -6 -7 -8 -9 -10 -11 -12 -13 -14 -15 -16 -17 -18 -19 -20 -21 -22 -23 -24 -25 -26 -27 -28 -29 -30 -31 -32 -33 -34 -35 -36 -37 -38 -39 -40 -41 -42 -43 -44 -45 -46 -47 -48 -49 +1 +2 +3 +4 +5 +6 +7 +8 +9 diff --git a/examples/doc_githubIcon.golden b/examples/doc_githubIcon.golden --- a/examples/doc_githubIcon.golden +++ b/examples/doc_githubIcon.golden @@ -8,43 +8,3 @@ 7 8 9 -10 -11 -12 -13 -14 -15 -16 -17 -18 -19 -20 -21 -22 -23 -24 -25 -26 -27 -28 -29 -30 -31 -32 -33 -34 -35 -36 -37 -38 -39 -40 -41 -42 -43 -44 -45 -46 -47 -48 -49 diff --git a/examples/doc_greyscale.golden b/examples/doc_greyscale.golden --- a/examples/doc_greyscale.golden +++ b/examples/doc_greyscale.golden @@ -8,43 +8,3 @@ 7 8 9 -10 -11 -12 -13 -14 -15 -16 -17 -18 -19 -20 -21 -22 -23 -24 -25 -26 -27 -28 -29 -30 -31 -32 -33 -34 -35 -36 -37 -38 -39 -40 -41 -42 -43 -44 -45 -46 -47 -48 -49 diff --git a/examples/doc_haskellLogo.golden b/examples/doc_haskellLogo.golden --- a/examples/doc_haskellLogo.golden +++ b/examples/doc_haskellLogo.golden @@ -8,43 +8,3 @@ 7 8 9 -10 -11 -12 -13 -14 -15 -16 -17 -18 -19 -20 -21 -22 -23 -24 -25 -26 -27 -28 -29 -30 -31 -32 -33 -34 -35 -36 -37 -38 -39 -40 -41 -42 -43 -44 -45 -46 -47 -48 -49 diff --git a/examples/doc_hsv.golden b/examples/doc_hsv.golden --- a/examples/doc_hsv.golden +++ b/examples/doc_hsv.golden @@ -8,43 +8,3 @@ 7 8 9 -10 -11 -12 -13 -14 -15 -16 -17 -18 -19 -20 -21 -22 -23 -24 -25 -26 -27 -28 -29 -30 -31 -32 -33 -34 -35 -36 -37 -38 -39 -40 -41 -42 -43 -44 -45 -46 -47 -48 -49 diff --git a/examples/doc_hsvComponents.golden b/examples/doc_hsvComponents.golden --- a/examples/doc_hsvComponents.golden +++ b/examples/doc_hsvComponents.golden @@ -8,43 +8,3 @@ 7 8 9 -10 -11 -12 -13 -14 -15 -16 -17 -18 -19 -20 -21 -22 -23 -24 -25 -26 -27 -28 -29 -30 -31 -32 -33 -34 -35 -36 -37 -38 -39 -40 -41 -42 -43 -44 -45 -46 -47 -48 -49 diff --git a/examples/doc_hsvMatlab.golden b/examples/doc_hsvMatlab.golden --- a/examples/doc_hsvMatlab.golden +++ b/examples/doc_hsvMatlab.golden @@ -8,43 +8,3 @@ 7 8 9 -10 -11 -12 -13 -14 -15 -16 -17 -18 -19 -20 -21 -22 -23 -24 -25 -26 -27 -28 -29 -30 -31 -32 -33 -34 -35 -36 -37 -38 -39 -40 -41 -42 -43 -44 -45 -46 -47 -48 -49 diff --git a/examples/doc_inferno.golden b/examples/doc_inferno.golden --- a/examples/doc_inferno.golden +++ b/examples/doc_inferno.golden @@ -8,43 +8,3 @@ 7 8 9 -10 -11 -12 -13 -14 -15 -16 -17 -18 -19 -20 -21 -22 -23 -24 -25 -26 -27 -28 -29 -30 -31 -32 -33 -34 -35 -36 -37 -38 -39 -40 -41 -42 -43 -44 -45 -46 -47 -48 -49 diff --git a/examples/doc_jet.golden b/examples/doc_jet.golden --- a/examples/doc_jet.golden +++ b/examples/doc_jet.golden @@ -8,43 +8,3 @@ 7 8 9 -10 -11 -12 -13 -14 -15 -16 -17 -18 -19 -20 -21 -22 -23 -24 -25 -26 -27 -28 -29 -30 -31 -32 -33 -34 -35 -36 -37 -38 -39 -40 -41 -42 -43 -44 -45 -46 -47 -48 -49 diff --git a/examples/doc_labComponents.golden b/examples/doc_labComponents.golden --- a/examples/doc_labComponents.golden +++ b/examples/doc_labComponents.golden @@ -8,43 +8,3 @@ 7 8 9 -10 -11 -12 -13 -14 -15 -16 -17 -18 -19 -20 -21 -22 -23 -24 -25 -26 -27 -28 -29 -30 -31 -32 -33 -34 -35 -36 -37 -38 -39 -40 -41 -42 -43 -44 -45 -46 -47 -48 -49 diff --git a/examples/doc_latex.golden b/examples/doc_latex.golden --- a/examples/doc_latex.golden +++ b/examples/doc_latex.golden @@ -8,43 +8,3 @@ 7$e^{i\pi}+1=0$ 8$e^{i\pi}+1=0$ 9$e^{i\pi}+1=0$ -10$e^{i\pi}+1=0$ -11$e^{i\pi}+1=0$ -12$e^{i\pi}+1=0$ -13$e^{i\pi}+1=0$ -14$e^{i\pi}+1=0$ -15$e^{i\pi}+1=0$ -16$e^{i\pi}+1=0$ -17$e^{i\pi}+1=0$ -18$e^{i\pi}+1=0$ -19$e^{i\pi}+1=0$ -20$e^{i\pi}+1=0$ -21$e^{i\pi}+1=0$ -22$e^{i\pi}+1=0$ -23$e^{i\pi}+1=0$ -24$e^{i\pi}+1=0$ -25$e^{i\pi}+1=0$ -26$e^{i\pi}+1=0$ -27$e^{i\pi}+1=0$ -28$e^{i\pi}+1=0$ -29$e^{i\pi}+1=0$ -30$e^{i\pi}+1=0$ -31$e^{i\pi}+1=0$ -32$e^{i\pi}+1=0$ -33$e^{i\pi}+1=0$ -34$e^{i\pi}+1=0$ -35$e^{i\pi}+1=0$ -36$e^{i\pi}+1=0$ -37$e^{i\pi}+1=0$ -38$e^{i\pi}+1=0$ -39$e^{i\pi}+1=0$ -40$e^{i\pi}+1=0$ -41$e^{i\pi}+1=0$ -42$e^{i\pi}+1=0$ -43$e^{i\pi}+1=0$ -44$e^{i\pi}+1=0$ -45$e^{i\pi}+1=0$ -46$e^{i\pi}+1=0$ -47$e^{i\pi}+1=0$ -48$e^{i\pi}+1=0$ -49$e^{i\pi}+1=0$ diff --git a/examples/doc_latexAlign.golden b/examples/doc_latexAlign.golden --- a/examples/doc_latexAlign.golden +++ b/examples/doc_latexAlign.golden @@ -8,43 +8,3 @@ 7\begin{align*}R = \frac{{\Delta x}}{{kA}}\end{align*} 8\begin{align*}R = \frac{{\Delta x}}{{kA}}\end{align*} 9\begin{align*}R = \frac{{\Delta x}}{{kA}}\end{align*} -10\begin{align*}R = \frac{{\Delta x}}{{kA}}\end{align*} -11\begin{align*}R = \frac{{\Delta x}}{{kA}}\end{align*} -12\begin{align*}R = \frac{{\Delta x}}{{kA}}\end{align*} -13\begin{align*}R = \frac{{\Delta x}}{{kA}}\end{align*} -14\begin{align*}R = \frac{{\Delta x}}{{kA}}\end{align*} -15\begin{align*}R = \frac{{\Delta x}}{{kA}}\end{align*} -16\begin{align*}R = \frac{{\Delta x}}{{kA}}\end{align*} -17\begin{align*}R = \frac{{\Delta x}}{{kA}}\end{align*} -18\begin{align*}R = \frac{{\Delta x}}{{kA}}\end{align*} -19\begin{align*}R = \frac{{\Delta x}}{{kA}}\end{align*} -20\begin{align*}R = \frac{{\Delta x}}{{kA}}\end{align*} -21\begin{align*}R = \frac{{\Delta x}}{{kA}}\end{align*} -22\begin{align*}R = \frac{{\Delta x}}{{kA}}\end{align*} -23\begin{align*}R = \frac{{\Delta x}}{{kA}}\end{align*} -24\begin{align*}R = \frac{{\Delta x}}{{kA}}\end{align*} -25\begin{align*}R = \frac{{\Delta x}}{{kA}}\end{align*} -26\begin{align*}R = \frac{{\Delta x}}{{kA}}\end{align*} -27\begin{align*}R = \frac{{\Delta x}}{{kA}}\end{align*} -28\begin{align*}R = \frac{{\Delta x}}{{kA}}\end{align*} -29\begin{align*}R = \frac{{\Delta x}}{{kA}}\end{align*} -30\begin{align*}R = \frac{{\Delta x}}{{kA}}\end{align*} -31\begin{align*}R = \frac{{\Delta x}}{{kA}}\end{align*} -32\begin{align*}R = \frac{{\Delta x}}{{kA}}\end{align*} -33\begin{align*}R = \frac{{\Delta x}}{{kA}}\end{align*} -34\begin{align*}R = \frac{{\Delta x}}{{kA}}\end{align*} -35\begin{align*}R = \frac{{\Delta x}}{{kA}}\end{align*} -36\begin{align*}R = \frac{{\Delta x}}{{kA}}\end{align*} -37\begin{align*}R = \frac{{\Delta x}}{{kA}}\end{align*} -38\begin{align*}R = \frac{{\Delta x}}{{kA}}\end{align*} -39\begin{align*}R = \frac{{\Delta x}}{{kA}}\end{align*} -40\begin{align*}R = \frac{{\Delta x}}{{kA}}\end{align*} -41\begin{align*}R = \frac{{\Delta x}}{{kA}}\end{align*} -42\begin{align*}R = \frac{{\Delta x}}{{kA}}\end{align*} -43\begin{align*}R = \frac{{\Delta x}}{{kA}}\end{align*} -44\begin{align*}R = \frac{{\Delta x}}{{kA}}\end{align*} -45\begin{align*}R = \frac{{\Delta x}}{{kA}}\end{align*} -46\begin{align*}R = \frac{{\Delta x}}{{kA}}\end{align*} -47\begin{align*}R = \frac{{\Delta x}}{{kA}}\end{align*} -48\begin{align*}R = \frac{{\Delta x}}{{kA}}\end{align*} -49\begin{align*}R = \frac{{\Delta x}}{{kA}}\end{align*} diff --git a/examples/doc_lchComponents.golden b/examples/doc_lchComponents.golden --- a/examples/doc_lchComponents.golden +++ b/examples/doc_lchComponents.golden @@ -8,43 +8,3 @@ 7 8 9 -10 -11 -12 -13 -14 -15 -16 -17 -18 -19 -20 -21 -22 -23 -24 -25 -26 -27 -28 -29 -30 -31 -32 -33 -34 -35 -36 -37 -38 -39 -40 -41 -42 -43 -44 -45 -46 -47 -48 -49 diff --git a/examples/doc_magma.golden b/examples/doc_magma.golden --- a/examples/doc_magma.golden +++ b/examples/doc_magma.golden @@ -8,43 +8,3 @@ 7 8 9 -10 -11 -12 -13 -14 -15 -16 -17 -18 -19 -20 -21 -22 -23 -24 -25 -26 -27 -28 -29 -30 -31 -32 -33 -34 -35 -36 -37 -38 -39 -40 -41 -42 -43 -44 -45 -46 -47 -48 -49 diff --git a/examples/doc_mapA.golden b/examples/doc_mapA.golden --- a/examples/doc_mapA.golden +++ b/examples/doc_mapA.golden @@ -1,50 +1,10 @@ 0 -1 -2 -3 -4 -5 -6 -7 -8 -9 -10 -11 -12 -13 -14 -15 -16 -17 -18 -19 -20 -21 -22 -23 -24 -25 -26 -27 -28 -29 -30 -31 -32 -33 -34 -35 -36 -37 -38 -39 -40 -41 -42 -43 -44 -45 -46 -47 -48 -49 +1 +2 +3 +4 +5 +6 +7 +8 +9 diff --git a/examples/doc_mkBackground.golden b/examples/doc_mkBackground.golden --- a/examples/doc_mkBackground.golden +++ b/examples/doc_mkBackground.golden @@ -8,43 +8,3 @@ 7 8 9 -10 -11 -12 -13 -14 -15 -16 -17 -18 -19 -20 -21 -22 -23 -24 -25 -26 -27 -28 -29 -30 -31 -32 -33 -34 -35 -36 -37 -38 -39 -40 -41 -42 -43 -44 -45 -46 -47 -48 -49 diff --git a/examples/doc_mkText.golden b/examples/doc_mkText.golden --- a/examples/doc_mkText.golden +++ b/examples/doc_mkText.golden @@ -1,50 +1,10 @@ 0 -1 -2t -3t -4t -5te -6te -7te -8te -9tex -10tex -11tex -12text -13text -14text -15text -16text -17text -18text -19text -20text -21text -22text -23text -24text -25text -26text -27text -28text -29text -30text -31text -32text -33text -34text -35text -36text -37text -38text -39text -40text -41text -42text -43text -44text -45text -46text -47text -48text -49text +1te +2tex +3text +4text +5text +6text +7text +8text +9text diff --git a/examples/doc_newSprite.golden b/examples/doc_newSprite.golden --- a/examples/doc_newSprite.golden +++ b/examples/doc_newSprite.golden @@ -1,50 +1,10 @@ 0 -1 -2 -3 -4 -5 -6 -7 -8 -9 -10 -11 -12 -13 -14 -15 -16 -17 -18 -19 -20 -21 -22 -23 -24 -25 -26 -27 -28 -29 -30 -31 -32 -33 -34 -35 -36 -37 -38 -39 -40 -41 -42 -43 -44 -45 -46 -47 -48 -49 +1 +2 +3 +4 +5 +6 +7 +8 +9 diff --git a/examples/doc_newSpriteA'.golden b/examples/doc_newSpriteA'.golden --- a/examples/doc_newSpriteA'.golden +++ b/examples/doc_newSpriteA'.golden @@ -1,50 +1,10 @@ 0 -1 -2 -3 -4 -5 -6 -7 -8 -9 -10 -11 -12 -13 -14 -15 -16 -17 -18 -19 -20 -21 -22 -23 -24 -25 -26 -27 -28 -29 -30 -31 -32 -33 -34 -35 -36 -37 -38 -39 -40 -41 -42 -43 -44 -45 -46 -47 -48 -49 +1 +2 +3 +4 +5 +6 +7 +8 +9 diff --git a/examples/doc_newSpriteA.golden b/examples/doc_newSpriteA.golden --- a/examples/doc_newSpriteA.golden +++ b/examples/doc_newSpriteA.golden @@ -1,50 +1,10 @@ 0 -1 -2 -3 -4 -5 -6 -7 -8 -9 -10 -11 -12 -13 -14 -15 -16 -17 -18 -19 -20 -21 -22 -23 -24 -25 -26 -27 -28 -29 -30 -31 -32 -33 -34 -35 -36 -37 -38 -39 -40 -41 -42 -43 -44 -45 -46 -47 -48 -49 +1 +2 +3 +4 +5 +6 +7 +8 +9 diff --git a/examples/doc_newSpriteSVG.golden b/examples/doc_newSpriteSVG.golden --- a/examples/doc_newSpriteSVG.golden +++ b/examples/doc_newSpriteSVG.golden @@ -1,50 +1,10 @@ 0 -1 -2 -3 -4 -5 -6 -7 -8 -9 -10 -11 -12 -13 -14 -15 -16 -17 -18 -19 -20 -21 -22 -23 -24 -25 -26 -27 -28 -29 -30 -31 -32 -33 -34 -35 -36 -37 -38 -39 -40 -41 -42 -43 -44 -45 -46 -47 -48 -49 +1 +2 +3 +4 +5 +6 +7 +8 +9 diff --git a/examples/doc_oscillateS.golden b/examples/doc_oscillateS.golden --- a/examples/doc_oscillateS.golden +++ b/examples/doc_oscillateS.golden @@ -1,50 +1,10 @@ 0 -1 -2 -3 -4 -5 -6 -7 -8 -9 -10 -11 -12 -13 -14 -15 -16 -17 -18 -19 -20 -21 -22 -23 -24 -25 -26 -27 -28 -29 -30 -31 -32 -33 -34 -35 -36 -37 -38 -39 -40 -41 -42 -43 -44 -45 -46 -47 -48 -49 +1 +2 +3 +4 +5 +6 +7 +8 +9 diff --git a/examples/doc_overlapT.golden b/examples/doc_overlapT.golden --- a/examples/doc_overlapT.golden +++ b/examples/doc_overlapT.golden @@ -1,50 +1,10 @@ 0 -1 -2 -3 -4 -5 -6 -7 -8 -9 -10 -11 -12 -13 -14 -15 -16 -17 -18 -19 -20 -21 -22 -23 -24 -25 -26 -27 -28 -29 -30 -31 -32 -33 -34 -35 -36 -37 -38 -39 -40 -41 -42 -43 -44 -45 -46 -47 -48 -49 +1 +2 +3 +4 +5 +6 +7 +8 +9 diff --git a/examples/doc_parA.golden b/examples/doc_parA.golden --- a/examples/doc_parA.golden +++ b/examples/doc_parA.golden @@ -1,50 +1,10 @@ 0 -1 -2 -3 -4 -5 -6 -7 -8 -9 -10 -11 -12 -13 -14 -15 -16 -17 -18 -19 -20 -21 -22 -23 -24 -25 -26 -27 -28 -29 -30 -31 -32 -33 -34 -35 -36 -37 -38 -39 -40 -41 -42 -43 -44 -45 -46 -47 -48 -49 +1 +2 +3 +4 +5 +6 +7 +8 +9 diff --git a/examples/doc_parDropA.golden b/examples/doc_parDropA.golden --- a/examples/doc_parDropA.golden +++ b/examples/doc_parDropA.golden @@ -1,50 +1,10 @@ 0 -1 -2 -3 -4 -5 -6 -7 -8 -9 -10 -11 -12 -13 -14 -15 -16 -17 -18 -19 -20 -21 -22 -23 -24 -25 -26 -27 -28 -29 -30 -31 -32 -33 -34 -35 -36 -37 -38 -39 -40 -41 -42 -43 -44 -45 -46 -47 -48 -49 +1 +2 +3 +4 +5 +6 +7 +8 +9 diff --git a/examples/doc_parLoopA.golden b/examples/doc_parLoopA.golden --- a/examples/doc_parLoopA.golden +++ b/examples/doc_parLoopA.golden @@ -1,50 +1,10 @@ 0 -1 -2 -3 -4 -5 -6 -7 -8 -9 -10 -11 -12 -13 -14 -15 -16 -17 -18 -19 -20 -21 -22 -23 -24 -25 -26 -27 -28 -29 -30 -31 -32 -33 -34 -35 -36 -37 -38 -39 -40 -41 -42 -43 -44 -45 -46 -47 -48 -49 +1 +2 +3 +4 +5 +6 +7 +8 +9 diff --git a/examples/doc_parula.golden b/examples/doc_parula.golden --- a/examples/doc_parula.golden +++ b/examples/doc_parula.golden @@ -8,43 +8,3 @@ 7 8 9 -10 -11 -12 -13 -14 -15 -16 -17 -18 -19 -20 -21 -22 -23 -24 -25 -26 -27 -28 -29 -30 -31 -32 -33 -34 -35 -36 -37 -38 -39 -40 -41 -42 -43 -44 -45 -46 -47 -48 -49 diff --git a/examples/doc_pathify.golden b/examples/doc_pathify.golden --- a/examples/doc_pathify.golden +++ b/examples/doc_pathify.golden @@ -1,50 +1,10 @@ 0 -1 -2 -3 -4 -5 -6 -7 -8 -9 -10 -11 -12 -13 -14 -15 -16 -17 -18 -19 -20 -21 -22 -23 -24 -25 -26 -27 -28 -29 -30 -31 -32 -33 -34 -35 -36 -37 -38 -39 -40 -41 -42 -43 -44 -45 -46 -47 -48 -49 +1 +2 +3 +4 +5 +6 +7 +8 +9 diff --git a/examples/doc_pause.golden b/examples/doc_pause.golden --- a/examples/doc_pause.golden +++ b/examples/doc_pause.golden @@ -1,50 +1,10 @@ 0 1 2 -3 -4 -5 -6 -7 -8 -9 -10 -11 -12 -13 -14 -15 -16 -17 -18 -19 -20 -21 -22 -23 -24 -25 -26 -27 -28 -29 -30 -31 -32 -33 -34 -35 -36 -37 -38 -39 -40 -41 -42 -43 -44 -45 -46 -47 -48 -49 +3 +4 +5 +6 +7 +8 +9 diff --git a/examples/doc_pauseAround.golden b/examples/doc_pauseAround.golden --- a/examples/doc_pauseAround.golden +++ b/examples/doc_pauseAround.golden @@ -1,50 +1,10 @@ 0 1 2 -3 -4 -5 -6 -7 -8 -9 -10 -11 -12 -13 -14 -15 -16 -17 -18 -19 -20 -21 -22 -23 -24 -25 -26 -27 -28 -29 -30 -31 -32 -33 -34 -35 -36 -37 -38 -39 -40 -41 -42 -43 -44 -45 -46 -47 -48 -49 +3 +4 +5 +6 +7 +8 +9 diff --git a/examples/doc_pauseAtBeginning.golden b/examples/doc_pauseAtBeginning.golden --- a/examples/doc_pauseAtBeginning.golden +++ b/examples/doc_pauseAtBeginning.golden @@ -2,49 +2,9 @@ 1 2 3 -4 -5 -6 -7 -8 -9 -10 -11 -12 -13 -14 -15 -16 -17 -18 -19 -20 -21 -22 -23 -24 -25 -26 -27 -28 -29 -30 -31 -32 -33 -34 -35 -36 -37 -38 -39 -40 -41 -42 -43 -44 -45 -46 -47 -48 -49 +4 +5 +6 +7 +8 +9 diff --git a/examples/doc_pauseAtEnd.golden b/examples/doc_pauseAtEnd.golden --- a/examples/doc_pauseAtEnd.golden +++ b/examples/doc_pauseAtEnd.golden @@ -1,50 +1,10 @@ 0 -1 -2 -3 -4 -5 -6 -7 -8 -9 -10 -11 -12 -13 -14 -15 -16 -17 -18 -19 -20 -21 -22 -23 -24 -25 -26 -27 -28 -29 -30 -31 -32 -33 -34 -35 -36 -37 -38 -39 -40 -41 -42 -43 -44 -45 -46 -47 -48 -49 +1 +2 +3 +4 +5 +6 +7 +8 +9 diff --git a/examples/doc_plasma.golden b/examples/doc_plasma.golden --- a/examples/doc_plasma.golden +++ b/examples/doc_plasma.golden @@ -8,43 +8,3 @@ 7 8 9 -10 -11 -12 -13 -14 -15 -16 -17 -18 -19 -20 -21 -22 -23 -24 -25 -26 -27 -28 -29 -30 -31 -32 -33 -34 -35 -36 -37 -38 -39 -40 -41 -42 -43 -44 -45 -46 -47 -48 -49 diff --git a/examples/doc_play.golden b/examples/doc_play.golden --- a/examples/doc_play.golden +++ b/examples/doc_play.golden @@ -1,50 +1,10 @@ 0 -1 -2 -3 -4 -5 -6 -7 -8 -9 -10 -11 -12 -13 -14 -15 -16 -17 -18 -19 -20 -21 -22 -23 -24 -25 -26 -27 -28 -29 -30 -31 -32 -33 -34 -35 -36 -37 -38 -39 -40 -41 -42 -43 -44 -45 -46 -47 -48 -49 +1 +2 +3 +4 +5 +6 +7 +8 +9 diff --git a/examples/doc_playThenReverseA.golden b/examples/doc_playThenReverseA.golden --- a/examples/doc_playThenReverseA.golden +++ b/examples/doc_playThenReverseA.golden @@ -1,50 +1,10 @@ 0 -1 -2 -3 -4 -5 -6 -7 -8 -9 -10 -11 -12 -13 -14 -15 -16 -17 -18 -19 -20 -21 -22 -23 -24 -25 -26 -27 -28 -29 -30 -31 -32 -33 -34 -35 -36 -37 -38 -39 -40 -41 -42 -43 -44 -45 -46 -47 -48 -49 +1 +2 +3 +4 +5 +6 +7 +8 +9 diff --git a/examples/doc_queryNow.golden b/examples/doc_queryNow.golden --- a/examples/doc_queryNow.golden +++ b/examples/doc_queryNow.golden @@ -1,50 +1,10 @@ 0 -1 -2 -3 -4 -5 -6 -7 -8 -9 -10 -11 -12 -13 -14 -15 -16 -17 -18 -19 -20 -21 -22 -23 -24 -25 -26 -27 -28 -29 -30 -31 -32 -33Now=2.0 -34Now=2.0 -35Now=2.0 -36Now=2.0 -37Now=2.0 -38Now=2.0 -39Now=2.0 -40Now=2.0 -41Now=2.0 -42Now=2.0 -43Now=2.0 -44Now=2.0 -45Now=2.0 -46Now=2.0 -47Now=2.0 -48Now=2.0 -49Now=2.0 +1 +2 +3 +4 +5 +6Now=2.0 +7Now=2.0 +8Now=2.0 +9Now=2.0 diff --git a/examples/doc_repeatA.golden b/examples/doc_repeatA.golden --- a/examples/doc_repeatA.golden +++ b/examples/doc_repeatA.golden @@ -1,50 +1,10 @@ 0 -1 -2 -3 -4 -5 -6 -7 -8 -9 -10 -11 -12 -13 -14 -15 -16 -17 -18 -19 -20 -21 -22 -23 -24 -25 -26 -27 -28 -29 -30 -31 -32 -33 -34 -35 -36 -37 -38 -39 -40 -41 -42 -43 -44 -45 -46 -47 -48 -49 +1 +2 +3 +4 +5 +6 +7 +8 +9 diff --git a/examples/doc_reverseA.golden b/examples/doc_reverseA.golden --- a/examples/doc_reverseA.golden +++ b/examples/doc_reverseA.golden @@ -1,50 +1,10 @@ 0 -1 -2 -3 -4 -5 -6 -7 -8 -9 -10 -11 -12 -13 -14 -15 -16 -17 -18 -19 -20 -21 -22 -23 -24 -25 -26 -27 -28 -29 -30 -31 -32 -33 -34 -35 -36 -37 -38 -39 -40 -41 -42 -43 -44 -45 -46 -47 -48 -49 +1 +2 +3 +4 +5 +6 +7 +8 +9 diff --git a/examples/doc_reverseS.golden b/examples/doc_reverseS.golden --- a/examples/doc_reverseS.golden +++ b/examples/doc_reverseS.golden @@ -1,50 +1,10 @@ 0 -1 -2 -3 -4 -5 -6 -7 -8 -9 -10 -11 -12 -13 -14 -15 -16 -17 -18 -19 -20 -21 -22 -23 -24 -25 -26 -27 -28 -29 -30 -31 -32 -33 -34 -35 -36 -37 -38 -39 -40 -41 -42 -43 -44 -45 -46 -47 -48 -49 +1 +2 +3 +4 +5 +6 +7 +8 +9 diff --git a/examples/doc_rgbComponents.golden b/examples/doc_rgbComponents.golden --- a/examples/doc_rgbComponents.golden +++ b/examples/doc_rgbComponents.golden @@ -8,43 +8,3 @@ 7 8 9 -10 -11 -12 -13 -14 -15 -16 -17 -18 -19 -20 -21 -22 -23 -24 -25 -26 -27 -28 -29 -30 -31 -32 -33 -34 -35 -36 -37 -38 -39 -40 -41 -42 -43 -44 -45 -46 -47 -48 -49 diff --git a/examples/doc_seqA.golden b/examples/doc_seqA.golden --- a/examples/doc_seqA.golden +++ b/examples/doc_seqA.golden @@ -1,50 +1,10 @@ 0 -1 -2 -3 -4 -5 -6 -7 -8 -9 -10 -11 -12 -13 -14 -15 -16 -17 -18 -19 -20 -21 -22 -23 -24 -25 -26 -27 -28 -29 -30 -31 -32 -33 -34 -35 -36 -37 -38 -39 -40 -41 -42 -43 -44 -45 -46 -47 -48 -49 +1 +2 +3 +4 +5 +6 +7 +8 +9 diff --git a/examples/doc_signalA.golden b/examples/doc_signalA.golden --- a/examples/doc_signalA.golden +++ b/examples/doc_signalA.golden @@ -1,50 +1,10 @@ 0 -1 -2 -3 -4 -5 -6 -7 -8 -9 -10 -11 -12 -13 -14 -15 -16 -17 -18 -19 -20 -21 -22 -23 -24 -25 -26 -27 -28 -29 -30 -31 -32 -33 -34 -35 -36 -37 -38 -39 -40 -41 -42 -43 -44 -45 -46 -47 -48 -49 +1 +2 +3 +4 +5 +6 +7 +8 +9 diff --git a/examples/doc_simpleVar.golden b/examples/doc_simpleVar.golden --- a/examples/doc_simpleVar.golden +++ b/examples/doc_simpleVar.golden @@ -1,50 +1,10 @@ 0 -1 -2 -3 -4 -5 -6 -7 -8 -9 -10 -11 -12 -13 -14 -15 -16 -17 -18 -19 -20 -21 -22 -23 -24 -25 -26 -27 -28 -29 -30 -31 -32 -33 -34 -35 -36 -37 -38 -39 -40 -41 -42 -43 -44 -45 -46 -47 -48 -49 +1 +2 +3 +4 +5 +6 +7 +8 +9 diff --git a/examples/doc_sinebow.golden b/examples/doc_sinebow.golden --- a/examples/doc_sinebow.golden +++ b/examples/doc_sinebow.golden @@ -8,43 +8,3 @@ 7 8 9 -10 -11 -12 -13 -14 -15 -16 -17 -18 -19 -20 -21 -22 -23 -24 -25 -26 -27 -28 -29 -30 -31 -32 -33 -34 -35 -36 -37 -38 -39 -40 -41 -42 -43 -44 -45 -46 -47 -48 -49 diff --git a/examples/doc_slideLeftT.golden b/examples/doc_slideLeftT.golden new file mode 100644 --- /dev/null +++ b/examples/doc_slideLeftT.golden @@ -0,0 +1,10 @@ +0 +1 +2 +3 +4 +5 +6 +7 +8 +9 diff --git a/examples/doc_slideLeftT.hs b/examples/doc_slideLeftT.hs new file mode 100644 --- /dev/null +++ b/examples/doc_slideLeftT.hs @@ -0,0 +1,15 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +module Main(main) where + +import Reanimate +import Reanimate.Builtin.Documentation +import Reanimate.Builtin.Slide +import Reanimate.Transition + +main :: IO () +main = reanimate $ docEnv $ signalT (curveS 2) slideLeftT left right + where + left = drawCircle + right = staticFrame 1 (withFillOpacity 1 $ mkBackground "black") `parA` + mapA (flipXAxis . withStrokeColor "white") drawCircle diff --git a/examples/doc_spriteE.golden b/examples/doc_spriteE.golden --- a/examples/doc_spriteE.golden +++ b/examples/doc_spriteE.golden @@ -1,50 +1,10 @@ 0 -1 -2 -3 -4 -5 -6 -7 -8 -9 -10 -11 -12 -13 -14 -15 -16 -17 -18 -19 -20 -21 -22 -23 -24 -25 -26 -27 -28 -29 -30 -31 -32 -33 -34 -35 -36 -37 -38 -39 -40 -41 -42 -43 -44 -45 -46 -47 -48 -49 +1 +2 +3 +4 +5 +6 +7 +8 +9 diff --git a/examples/doc_spriteMap.golden b/examples/doc_spriteMap.golden --- a/examples/doc_spriteMap.golden +++ b/examples/doc_spriteMap.golden @@ -1,50 +1,10 @@ 0 -1 -2 -3 -4 -5 -6 -7 -8 -9 -10 -11 -12 -13 -14 -15 -16 -17 -18 -19 -20 -21 -22 -23 -24 -25 -26 -27 -28 -29 -30 -31 -32 -33 -34 -35 -36 -37 -38 -39 -40 -41 -42 -43 -44 -45 -46 -47 -48 -49 +1 +2 +3 +4 +5 +6 +7 +8 +9 diff --git a/examples/doc_spriteTween.golden b/examples/doc_spriteTween.golden --- a/examples/doc_spriteTween.golden +++ b/examples/doc_spriteTween.golden @@ -1,50 +1,10 @@ 0 -1 -2 -3 -4 -5 -6 -7 -8 -9 -10 -11 -12 -13 -14 -15 -16 -17 -18 -19 -20 -21 -22 -23 -24 -25 -26 -27 -28 -29 -30 -31 -32 -33 -34 -35 -36 -37 -38 -39 -40 -41 -42 -43 -44 -45 -46 -47 -48 -49 +1 +2 +3 +4 +5 +6 +7 +8 +9 diff --git a/examples/doc_spriteVar.golden b/examples/doc_spriteVar.golden --- a/examples/doc_spriteVar.golden +++ b/examples/doc_spriteVar.golden @@ -1,50 +1,10 @@ 0 -1 -2 -3 -4 -5 -6 -7 -8 -9 -10 -11 -12 -13 -14 -15 -16 -17 -18 -19 -20 -21 -22 -23 -24 -25 -26 -27 -28 -29 -30 -31 -32 -33 -34 -35 -36 -37 -38 -39 -40 -41 -42 -43 -44 -45 -46 -47 -48 -49 +1 +2 +3 +4 +5 +6 +7 +8 +9 diff --git a/examples/doc_spriteZ.golden b/examples/doc_spriteZ.golden --- a/examples/doc_spriteZ.golden +++ b/examples/doc_spriteZ.golden @@ -3,48 +3,8 @@ 2 3 4 -5 -6 -7 -8 -9 -10 -11 -12 -13 -14 -15 -16 -17 -18 -19 -20 -21 -22 -23 -24 -25 -26 -27 -28 -29 -30 -31 -32 -33 -34 -35 -36 -37 -38 -39 -40 -41 -42 -43 -44 -45 -46 -47 -48 -49 +5 +6 +7 +8 +9 diff --git a/examples/doc_svgLogo.golden b/examples/doc_svgLogo.golden --- a/examples/doc_svgLogo.golden +++ b/examples/doc_svgLogo.golden @@ -8,43 +8,3 @@ 7 8 9 -10 -11 -12 -13 -14 -15 -16 -17 -18 -19 -20 -21 -22 -23 -24 -25 -26 -27 -28 -29 -30 -31 -32 -33 -34 -35 -36 -37 -38 -39 -40 -41 -42 -43 -44 -45 -46 -47 -48 -49 diff --git a/examples/doc_turbo.golden b/examples/doc_turbo.golden --- a/examples/doc_turbo.golden +++ b/examples/doc_turbo.golden @@ -8,43 +8,3 @@ 7 8 9 -10 -11 -12 -13 -14 -15 -16 -17 -18 -19 -20 -21 -22 -23 -24 -25 -26 -27 -28 -29 -30 -31 -32 -33 -34 -35 -36 -37 -38 -39 -40 -41 -42 -43 -44 -45 -46 -47 -48 -49 diff --git a/examples/doc_unVar.golden b/examples/doc_unVar.golden --- a/examples/doc_unVar.golden +++ b/examples/doc_unVar.golden @@ -1,50 +1,10 @@ 0 -1 -2 -3 -4 -5 -6 -7 -8 -9 -10 -11 -12 -13 -14 -15 -16 -17 -18 -19 -20 -21 -22 -23 -24 -25 -26 -27 -28 -29 -30 -31 -32 -33 -34 -35 -36 -37 -38 -39 -40 -41 -42 -43 -44 -45 -46 -47 -48 -49 +1 +2 +3 +4 +5 +6 +7 +8 +9 diff --git a/examples/doc_viridis.golden b/examples/doc_viridis.golden --- a/examples/doc_viridis.golden +++ b/examples/doc_viridis.golden @@ -8,43 +8,3 @@ 7 8 9 -10 -11 -12 -13 -14 -15 -16 -17 -18 -19 -20 -21 -22 -23 -24 -25 -26 -27 -28 -29 -30 -31 -32 -33 -34 -35 -36 -37 -38 -39 -40 -41 -42 -43 -44 -45 -46 -47 -48 -49 diff --git a/examples/doc_wait.golden b/examples/doc_wait.golden --- a/examples/doc_wait.golden +++ b/examples/doc_wait.golden @@ -1,50 +1,10 @@ 0 -1 -2 -3 -4 -5 -6 -7 -8 -9 -10 -11 -12 -13 -14 -15 -16 -17 -18 -19 -20 -21 -22 -23 -24 -25 -26 -27 -28 -29 -30 -31 -32 -33 -34 -35 -36 -37 -38 -39 -40 -41 -42 -43 -44 -45 -46 -47 -48 -49 +1 +2 +3 +4 +5 +6 +7 +8 +9 diff --git a/examples/doc_waitOn.golden b/examples/doc_waitOn.golden --- a/examples/doc_waitOn.golden +++ b/examples/doc_waitOn.golden @@ -1,50 +1,10 @@ 0 -1 -2 -3 -4 -5 -6 -7 -8 -9 -10 -11 -12 -13 -14 -15 -16 -17 -18 -19 -20 -21 -22 -23 -24 -25 -26 -27 -28 -29 -30 -31 -32 -33 -34 -35 -36 -37 -38 -39 -40 -41 -42 -43 -44 -45 -46 -47 -48 -49 +1 +2 +3 +4 +5 +6 +7 +8 +9 diff --git a/examples/doc_withViewBox.golden b/examples/doc_withViewBox.golden --- a/examples/doc_withViewBox.golden +++ b/examples/doc_withViewBox.golden @@ -8,43 +8,3 @@ 7 8 9 -10 -11 -12 -13 -14 -15 -16 -17 -18 -19 -20 -21 -22 -23 -24 -25 -26 -27 -28 -29 -30 -31 -32 -33 -34 -35 -36 -37 -38 -39 -40 -41 -42 -43 -44 -45 -46 -47 -48 -49 diff --git a/examples/doc_writeVar.golden b/examples/doc_writeVar.golden --- a/examples/doc_writeVar.golden +++ b/examples/doc_writeVar.golden @@ -1,50 +1,10 @@ 0 1 2 -3 -4 -5 -6 -7 -8 -9 -10 -11 -12 -13 -14 -15 -16 -17 -18 -19 -20 -21 -22 -23 -24 -25 -26 -27 -28 -29 -30 -31 -32 -33 -34 -35 -36 -37 -38 -39 -40 -41 -42 -43 -44 -45 -46 -47 -48 -49 +3 +4 +5 +6 +7 +8 +9 diff --git a/examples/doc_xelatex.hs b/examples/doc_xelatex.hs deleted file mode 100644 --- a/examples/doc_xelatex.hs +++ /dev/null @@ -1,12 +0,0 @@ -#!/usr/bin/env stack --- stack runghc --package reanimate -{-# LANGUAGE OverloadedStrings #-} -module Main (main) where - -import Reanimate -import Reanimate.Builtin.Documentation - -main :: IO () -main = reanimate $ docEnv $ animate $ const $ - withStrokeWidth 0 . withFillOpacity 1 . scale 4 . center $ - xelatex "中文" diff --git a/examples/doc_xyzComponents.golden b/examples/doc_xyzComponents.golden --- a/examples/doc_xyzComponents.golden +++ b/examples/doc_xyzComponents.golden @@ -8,43 +8,3 @@ 7 8 9 -10 -11 -12 -13 -14 -15 -16 -17 -18 -19 -20 -21 -22 -23 -24 -25 -26 -27 -28 -29 -30 -31 -32 -33 -34 -35 -36 -37 -38 -39 -40 -41 -42 -43 -44 -45 -46 -47 -48 -49 diff --git a/examples/fe_bleed.hs b/examples/fe_bleed.hs new file mode 100644 --- /dev/null +++ b/examples/fe_bleed.hs @@ -0,0 +1,181 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ParallelListComp #-} +module Main(main) where + +{- FE articles/demos +scatter: https://codepen.io/mullany/pen/JmgbRB +distortion: https://codepen.io/mullany/pen/BWKePz +variable stroke width: https://codepen.io/mullany/pen/qaONQm +variable stroke gradient: https://codepen.io/mullany/pen/XXBMJd +heart: https://codepen.io/yoksel/pen/MLVjoB +elastic stroke: https://codepen.io/yoksel/pen/XJbzrO +-} + +import Codec.Picture.Types +import Control.Lens hiding (magma) +import Control.Monad +import Data.Fixed +import Data.Monoid +import Graphics.SvgTree +import Linear.V2 +import Linear.Vector +import Reanimate +import Reanimate.Builtin.Images +import System.Random + +seed1,seed2,seed3,seed4,seed5,seed6,seed7 :: StdGen +(seed1:seed2:seed3:seed4:seed5:seed6:seed7:_) = map mkStdGen (randoms (mkStdGen 23958)) + +spokes :: [(PixelRGB8, Double, Double, Double)] +spokes = take 30 + [ (turbo color, position, destination, offset) + | color <- randomRs (0,1) seed1 + | position <- randomRs (0,360) seed2 + | destination <- randomRs (-90,90) seed3 + | offset <- randomRs (0,1) seed4 + ] + +balls :: [(Double, Double, Double)] +balls = take 20 + [ (ang, offset, len) + | ang <- randomRs (0,pi*2) seed5 + , let degrees = ang/pi*180 :: Double + , degrees < (270-25) || degrees > (270+25) + | offset <- randomRs (0,1) seed6 + | len <- randomRs (1,3) seed7 + ] + +ctx :: SVG -> SVG +ctx = scale 0.7 + +-- = CoordUserSpace -- ^ `userSpaceOnUse` value +-- | CoordBoundingBox -- ^ `objectBoundingBox` value + +whiteGithub :: SVG +whiteGithub = withFillOpacity 1 $ withFillColor "white" $ + mkPath $ + extractPath $ + scaleToHeight screenHeight $ center $ unpackImage githubIcon + +main :: IO () +main = reanimate $ sceneAnimation $ do + newSpriteSVG_ $ mkBackground "white" + -- newSpriteSVG_ $ + -- mkClipPath "clip" $ + -- removeGroups $ scaleToHeight screenHeight $ center $ unpackImage githubIcon + -- newSpriteSVG_ $ + -- withId "circleMask" $ MaskTree $ defaultSvg + -- & maskContent .~ + -- [ mkBackground "white" + -- , translate 8 4.5 $ withFillOpacity 1 $ withFillColor "black" $ + -- mkCircle screenTop ] + -- & maskWidth .~ Percent 2 + -- & maskHeight .~ Percent 2 + newSpriteSVG_ $ + FilterTree $ mkFilter ("gooey") + [ FEGaussianBlur $ defaultSvg + & gaussianBlurStdDeviationX .~ Num 0.2 + & gaussianBlurEdgeMode .~ EdgeNone + & filterResult .~ Just "blur" + , FEColorMatrix $ defaultSvg + & colorMatrixType .~ Matrix + & colorMatrixValues .~ + "1 0 0 0 0 \ + \0 1 0 0 0 \ + \0 0 1 0 0 \ + \0 0 0 19 -10" + & colorMatrixIn .~ pure (SourceRef "blur") + & filterResult .~ Just "colormatrix" + ] + newSprite_ $ do + t <- spriteT + d <- spriteDuration + pure $ + withId "clip" $ MaskTree $ defaultSvg + -- & maskContent .~ [translate 8 4.5 $ withFillOpacity 1 $ withFillColor "white" $ mkCircle 1] + & maskContent .~ + [ mkGroup + [ whiteGithub + , withFillColor "white" $ mkGroup + [(translate x y $ mkCircle (r*2)) + | (ang, offset, len) <- balls + , let dir = angle ang + r = 1 - (mod' (t/d+offset) 1) + V2 x y = dir ^* (screenTop * len * (mod' (t/d+offset) 1)) ] + ] & filterRef .~ pure (Ref "gooey") + , withFillColor "black" $ mkCircle (screenTop*0.99) + , whiteGithub + ] + & maskWidth .~ Percent 2 + & maskHeight .~ Percent 2 + -- & maskPosition .~ (Num 0,Num 0) + -- & maskUnits .~ CoordBoundingBox + -- & maskContentUnits .~ CoordBoundingBox + newSpriteSVG_ $ + ctx $ + mkGroup [scale 2 $ mkBackground "white"] + & maskRef .~ (pure $ Ref "clip") + newSpriteSVG_ $ + FilterTree $ mkFilter ("blur") $ + [ FEGaussianBlur $ defaultSvg + & gaussianBlurStdDeviationX .~ Num 0.1 + & gaussianBlurEdgeMode .~ EdgeNone + & filterX .~ pure (Percent 0) + & filterY .~ pure (Percent 0) + & filterResult .~ Just "blur" + & filterWidth .~ pure (Percent 1) + & filterHeight .~ pure (Percent 1) + , FETurbulence $ defaultSvg + & turbulenceBaseFrequency .~ (2, Last Nothing) + & turbulenceType .~ FractalNoiseType + & turbulenceNumOctaves .~ 1 + & turbulenceSeed .~ 1 + & turbulenceStitchTiles .~ Stitch + & filterResult .~ Just "turbulence" + , FEDisplacementMap $ defaultSvg + & displacementMapScale .~ pure 2 + & displacementMapIn .~ pure (SourceRef "blur") + & displacementMapIn2 .~ pure (SourceRef "turbulence") + & displacementMapXChannelSelector .~ ChannelR + & displacementMapYChannelSelector .~ ChannelA + & filterResult .~ Just "displacementMap" + ] + + -- Color wheels: + forM_ spokes $ \(color, pos, dst, offset) -> + fork $ play $ mkAnimation 5 $ \t' -> + let t = (t' + offset) `mod'` 1 + in ctx $ mkGroup + [ mkGroup [(rotate (fromToS 0 dst $ curveS 2 $ oscillateS $ t) $ + rotate pos $ + withStrokeColorPixel (promotePixel color) slice)] + & filterRef .~ pure (Ref "blur") + ] & maskRef .~ (pure $ Ref "clip") + wait 5 + +slice :: SVG +slice = + withFillOpacity 0 $ withStrokeWidth 16 $ mkCircle 8 + & strokeDashArray .~ pure + [ Percent 0.10, Percent 1.90 ] + +-- colorWheel :: Int -> Int -> (Double -> PixelRGB8) -> SVG +-- colorWheel buckets repeats cm = +-- scale 1.1 $ circlePlot 1000 +-- (\ang _r -> +-- let idx = round (((ang+pi)/(2*pi)) * buckets' * repeats') `mod` buckets +-- in promotePixel $ cm (fromIntegral idx * recip buckets')) +-- where +-- buckets' = fromIntegral buckets +-- repeats' = fromIntegral repeats + +unpackImage :: SVG -> SVG +unpackImage (SvgTree doc) = unbox doc +unpackImage (GroupTree g) = GroupTree $ g & groupChildren %~ map unpackImage +unpackImage svg = svg + +mkFilter :: String -> [FilterElement] -> Filter +mkFilter ident fe = defaultSvg & filterChildren .~ fe & attrId ?~ ident diff --git a/examples/fonts_latex.hs b/examples/fonts_latex.hs new file mode 100644 --- /dev/null +++ b/examples/fonts_latex.hs @@ -0,0 +1,29 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +{-# LANGUAGE OverloadedStrings #-} +module Main + ( main + ) +where + +import Reanimate +import Reanimate.LaTeX +import Reanimate.Builtin.Documentation + +main :: IO () +main = + reanimate + $ docEnv + $ staticFrame 1 + $ withFillColor "black" + $ withFillOpacity 1 + $ mkGroup + [ latex "Computer Modern" + , translate 0 (-2) + $ latexWithHeaders ["\\usepackage{calligra}"] "\\calligra\nGalligra" + , translate (-6) (-2) + $ latexWithHeaders ["\\usepackage{noto}"] "\\normalfont\nNoto" + , translate (-6) 0 + $ latexWithHeaders ["\\usepackage{helvet}"] "Helvetica" + ] + diff --git a/examples/goo.golden b/examples/goo.golden --- a/examples/goo.golden +++ b/examples/goo.golden @@ -1,50 +1,10 @@ 0 -1 -2 -3 -4 -5 -6 -7 -8 -9 -10 -11 -12 -13 -14 -15 -16 -17 -18 -19 -20 -21 -22 -23 -24 -25 -26 -27 -28 -29 -30 -31 -32 -33 -34 -35 -36 -37 -38 -39 -40 -41 -42 -43 -44 -45 -46 -47 -48 -49 +1 +2 +3 +4 +5 +6 +7 +8 +9 diff --git a/examples/intro_canvas.golden b/examples/intro_canvas.golden --- a/examples/intro_canvas.golden +++ b/examples/intro_canvas.golden @@ -1,50 +1,10 @@ 016 units16 units9 units9 units0.0,0.00.0,0.0 -116 units16 units9 units9 units0.0,0.00.0,0.0 -216 units16 units9 units9 units0.0,0.00.0,0.0 -316 units16 units9 units9 units0.1,0.30.1,0.3 -416 units16 units9 units9 units0.4,0.70.4,0.7 -516 units16 units9 units9 units1.5,1.21.5,1.2 -616 units16 units9 units9 units2.7,1.72.7,1.7 -716 units16 units9 units9 units3.7,1.93.7,1.9 -816 units16 units9 units9 units4.0,2.04.0,2.0 -916 units16 units9 units9 units4.0,2.04.0,2.0 -1016 units16 units9 units9 units3.8,1.93.8,1.9 -1116 units16 units9 units9 units2.7,1.52.7,1.5 -1216 units16 units9 units9 units0.8,1.20.8,1.2 -1316 units16 units9 units9 units-1.4,1.4-1.4,1.4 -1416 units16 units9 units9 units-3.0,2.2-3.0,2.2 -1516 units16 units9 units9 units-3.8,2.8-3.8,2.8 -1616 units16 units9 units9 units-4.0,3.0-4.0,3.0 -1716 units16 units9 units9 units-4.0,3.0-4.0,3.0 -1816 units16 units9 units9 units-3.8,2.8-3.8,2.8 -1916 units16 units9 units9 units-3.0,2.1-3.0,2.1 -2016 units16 units9 units9 units-2.2,0.9-2.2,0.9 -2116 units16 units9 units9 units-2.1,-0.8-2.1,-0.8 -2216 units16 units9 units9 units-3.0,-2.1-3.0,-2.1 -2316 units16 units9 units9 units-3.8,-2.8-3.8,-2.8 -2416 units16 units9 units9 units-4.0,-3.0-4.0,-3.0 -2516 units16 units9 units9 units-4.0,-3.0-4.0,-3.0 -2616 units16 units9 units9 units-3.7,-2.8-3.7,-2.8 -2716 units16 units9 units9 units-2.7,-2.2-2.7,-2.2 -2816 units16 units9 units9 units-0.9,-1.5-0.9,-1.5 -2916 units16 units9 units9 units1.6,-1.21.6,-1.2 -3016 units16 units9 units9 units3.6,-1.53.6,-1.5 -3116 units16 units9 units9 units4.7,-1.94.7,-1.9 -3216 units16 units9 units9 units5.0,-2.05.0,-2.0 -3316 units16 units9 units9 units5.0,-2.05.0,-2.0 -3416 units16 units9 units9 units5.1,-1.75.1,-1.7 -3516 units16 units9 units9 units5.2,-0.85.2,-0.8 -3616 units16 units9 units9 units5.0,0.35.0,0.3 -3716 units16 units9 units9 units4.1,1.14.1,1.1 -3816 units16 units9 units9 units3.0,1.23.0,1.2 -3916 units16 units9 units9 units2.2,1.02.2,1.0 -4016 units16 units9 units9 units2.0,1.02.0,1.0 -4116 units16 units9 units9 units2.0,1.02.0,1.0 -4216 units16 units9 units9 units1.8,0.91.8,0.9 -4316 units16 units9 units9 units1.4,0.71.4,0.7 -4416 units16 units9 units9 units0.7,0.40.7,0.4 -4516 units16 units9 units9 units0.2,0.10.2,0.1 -4616 units16 units9 units9 units0.0,0.00.0,0.0 -4716 units16 units9 units9 units0.0,0.00.0,0.0 -4816 units16 units9 units9 units0.0,0.00.0,0.0 -4916 units16 units9 units9 units0.0,0.00.0,0.0 +116 units16 units9 units9 units2.0,1.42.0,1.4 +216 units16 units9 units9 units2.8,1.62.8,1.6 +316 units16 units9 units9 units-4.0,3.0-4.0,3.0 +416 units16 units9 units9 units-2.8,-1.8-2.8,-1.8 +516 units16 units9 units9 units-2.4,-2.0-2.4,-2.0 +616 units16 units9 units9 units5.0,-2.05.0,-2.0 +716 units16 units9 units9 units2.9,1.22.9,1.2 +816 units16 units9 units9 units1.0,0.51.0,0.5 +916 units16 units9 units9 units0.0,0.00.0,0.0 diff --git a/examples/intro_canvas_square.golden b/examples/intro_canvas_square.golden --- a/examples/intro_canvas_square.golden +++ b/examples/intro_canvas_square.golden @@ -1,50 +1,10 @@ 0 8 units 8 units 8 units 8 units 0.0,0.0 0.0,0.0 -1 8 units 8 units 8 units 8 units 0.0,0.1 0.0,0.1 -2 8 units 8 units 8 units 8 units 0.1,0.3 0.1,0.3 -3 8 units 8 units 8 units 8 units 0.3,0.6 0.3,0.6 -4 8 units 8 units 8 units 8 units 0.9,0.9 0.9,0.9 -5 8 units 8 units 8 units 8 units 1.5,1.0 1.5,1.0 -6 8 units 8 units 8 units 8 units 1.9,1.0 1.9,1.0 -7 8 units 8 units 8 units 8 units 2.0,1.0 2.0,1.0 -8 8 units 8 units 8 units 8 units 2.0,1.0 2.0,1.0 -9 8 units 8 units 8 units 8 units 1.8,0.9 1.8,0.9 -10 8 units 8 units 8 units 8 units 1.2,0.8 1.2,0.8 -11 8 units 8 units 8 units 8 units 0.3,0.6 0.3,0.6 -12 8 units 8 units 8 units 8 units -0.6,0.7 -0.6,0.7 -13 8 units 8 units 8 units 8 units -0.9,1.1 -0.9,1.1 -14 8 units 8 units 8 units 8 units -1.0,1.4 -1.0,1.4 -15 8 units 8 units 8 units 8 units -1.0,1.5 -1.0,1.5 -16 8 units 8 units 8 units 8 units -1.0,1.5 -1.0,1.5 -17 8 units 8 units 8 units 8 units -1.0,1.4 -1.0,1.4 -18 8 units 8 units 8 units 8 units -0.8,1.1 -0.8,1.1 -19 8 units 8 units 8 units 8 units -0.7,0.4 -0.7,0.4 -20 8 units 8 units 8 units 8 units -0.8,-0.7 -0.8,-0.7 -21 8 units 8 units 8 units 8 units -1.3,-1.9 -1.3,-1.9 -22 8 units 8 units 8 units 8 units -1.8,-2.7 -1.8,-2.7 -23 8 units 8 units 8 units 8 units -2.0,-3.0 -2.0,-3.0 -24 8 units 8 units 8 units 8 units -2.0,-3.0 -2.0,-3.0 -25 8 units 8 units 8 units 8 units -2.0,-2.9 -2.0,-2.9 -26 8 units 8 units 8 units 8 units -1.6,-2.5 -1.6,-2.5 -27 8 units 8 units 8 units 8 units -0.9,-1.7 -0.9,-1.7 -28 8 units 8 units 8 units 8 units 0.3,-0.9 0.3,-0.9 -29 8 units 8 units 8 units 8 units 1.4,-0.8 1.4,-0.8 -30 8 units 8 units 8 units 8 units 2.1,-0.9 2.1,-0.9 -31 8 units 8 units 8 units 8 units 2.5,-1.0 2.5,-1.0 -32 8 units 8 units 8 units 8 units 2.5,-1.0 2.5,-1.0 -33 8 units 8 units 8 units 8 units 2.5,-1.0 2.5,-1.0 -34 8 units 8 units 8 units 8 units 2.6,-0.6 2.6,-0.6 -35 8 units 8 units 8 units 8 units 2.6,0.0 2.6,0.0 -36 8 units 8 units 8 units 8 units 2.5,0.7 2.5,0.7 -37 8 units 8 units 8 units 8 units 2.2,1.1 2.2,1.1 -38 8 units 8 units 8 units 8 units 1.8,1.1 1.8,1.1 -39 8 units 8 units 8 units 8 units 1.5,1.0 1.5,1.0 -40 8 units 8 units 8 units 8 units 1.5,1.0 1.5,1.0 -41 8 units 8 units 8 units 8 units 1.5,1.0 1.5,1.0 -42 8 units 8 units 8 units 8 units 1.3,0.9 1.3,0.9 -43 8 units 8 units 8 units 8 units 1.0,0.6 1.0,0.6 -44 8 units 8 units 8 units 8 units 0.5,0.3 0.5,0.3 -45 8 units 8 units 8 units 8 units 0.1,0.1 0.1,0.1 -46 8 units 8 units 8 units 8 units 0.0,0.0 0.0,0.0 -47 8 units 8 units 8 units 8 units 0.0,0.0 0.0,0.0 -48 8 units 8 units 8 units 8 units 0.0,0.0 0.0,0.0 -49 8 units 8 units 8 units 8 units 0.0,0.0 0.0,0.0 +1 8 units 8 units 8 units 8 units 1.7,1.0 1.7,1.0 +2 8 units 8 units 8 units 8 units 0.4,0.6 0.4,0.6 +3 8 units 8 units 8 units 8 units -1.0,1.5 -1.0,1.5 +4 8 units 8 units 8 units 8 units -1.7,-2.5 -1.7,-2.5 +5 8 units 8 units 8 units 8 units -0.7,-1.5 -0.7,-1.5 +6 8 units 8 units 8 units 8 units 2.5,-1.0 2.5,-1.0 +7 8 units 8 units 8 units 8 units 1.7,1.1 1.7,1.1 +8 8 units 8 units 8 units 8 units 0.7,0.5 0.7,0.5 +9 8 units 8 units 8 units 8 units 0.0,0.0 0.0,0.0 diff --git a/examples/intro_hello.golden b/examples/intro_hello.golden --- a/examples/intro_hello.golden +++ b/examples/intro_hello.golden @@ -8,43 +8,3 @@ 7Hello world 8Hello world 9Hello world -10Hello world -11Hello world -12Hello world -13Hello world -14Hello world -15Hello world -16Hello world -17Hello world -18Hello world -19Hello world -20Hello world -21Hello world -22Hello world -23Hello world -24Hello world -25Hello world -26Hello world -27Hello world -28Hello world -29Hello world -30Hello world -31Hello world -32Hello world -33Hello world -34Hello world -35Hello world -36Hello world -37Hello world -38Hello world -39Hello world -40Hello world -41Hello world -42Hello world -43Hello world -44Hello world -45Hello world -46Hello world -47Hello world -48Hello world -49Hello world diff --git a/examples/knock_knock.hs b/examples/knock_knock.hs new file mode 100644 --- /dev/null +++ b/examples/knock_knock.hs @@ -0,0 +1,67 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +{-# LANGUAGE OverloadedStrings #-} +module Main(main) where + +import Control.Lens +import Control.Monad +import Data.Text (Text) +import Reanimate +import Reanimate.Builtin.Documentation +import Reanimate.LaTeX +import Reanimate.Scene + +main :: IO () +main = reanimate $ docEnv $ mapA (withFillOpacity 1) $ sceneAnimation $ do + line1 <- newLaTeX ["$>$ ", "knock!", " ", "knock!"] + oModifyMany line1 $ + oTopY .~ screenTop + + oFadeIn (line1!!0) 1 + oShow (line1!!1); wait 0.3 + oShow (line1!!3); wait 0.6 + + line2 <- newLaTeX ["$>$ ", "who's there?"] + mapM_ (`placeBelow` head line1) line2 + + oFadeIn (line2!!0) 1 + oDraw (line2!!1) 1 + + line3 <- newLaTeX ["$>$ ", "$(\\lambda x . x)$"] + mapM_ (`placeBelow` head line2) line3 + + oFadeIn (line3!!0) 1 + oFadeIn (line3!!1) 1 + + line4 <- newLaTeX ["$>$ ", "$(\\lambda x . x)$", " ", "who?"] + mapM_ (`placeBelow` head line3) line4 + + oFadeIn (line4!!0) 1 + oFadeIn (line4!!1) 1 + oDraw (line4!!3) 1 + + line5 <- newLaTeX ["$>$ ", "who?"] + mapM_ (`placeBelow` head line4) line5 + + oFadeIn (line5!!0) 1 + oDraw (line5!!1) 1 + + wait 1 + +oModifyMany :: [Object s a] -> (ObjectData a -> ObjectData a) -> Scene s () +oModifyMany os m = forM_ os $ \o -> oModify o m + +placeBelow :: Object s a -> Object s b -> Scene s () +placeBelow a b = do + bBot <- oRead b oBottomY + oModify a $ + oTopY .~ bBot + +newLaTeX :: [Text] -> Scene s [Object s SVG] +newLaTeX chunks = mapM newObject $ map (translate (-4) 0) $ latexChunks chunks + +oDraw :: Object s a -> Duration -> Scene s () +oDraw o d = do + oShow o + oTweenS o d $ \t -> + oContext .= withFillOpacity (max 0 $ t*10-9) . partialSvg t diff --git a/examples/latex_basic.golden b/examples/latex_basic.golden --- a/examples/latex_basic.golden +++ b/examples/latex_basic.golden @@ -1,50 +1,10 @@ 0\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*}\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*} -1\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*}\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*} -2\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*}\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*} -3\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*}\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*} -4\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*}\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*} -5\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*}\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*} -6\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*}\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*} -7\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*}\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*} -8\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*}\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*} -9\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*}\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*} -10\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*}\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*} -11\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*}\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*} -12\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*}\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*} -13\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*}\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*} -14\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*}\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*} -15\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*}\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*} -16\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*}\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*} -17\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*}\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*} -18\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*}\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*} -19\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*}\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*} -20\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*}\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*} -21\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*}\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*} -22\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*}\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*} -23\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*}\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*} -24\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*}\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*} -25\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*}\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*} -26\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*}\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*} -27\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*}\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*} -28\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*}\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*} -29\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*}\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*} -30\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*}\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*} -31\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*}\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*} -32\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*}\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*} -33\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*}\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*} -34\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*}\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*} -35\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*}\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*} -36\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*}\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*} -37\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*}\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*} -38\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*}\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*} -39\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*}\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*} -40\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*}\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*} -41\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*}\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*} -42\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*}\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*} -43\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*}\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*} -44\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*}\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*} -45\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*}\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*} -46\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*}\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*} -47\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*}\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*} -48\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*}\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*} -49\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*}\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*} +1\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*}\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*} +2\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*}\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*} +3\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*}\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*} +4\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*}\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*} +5\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*}\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*} +6\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*}\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*} +7\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*}\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*} +8\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*}\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*} +9\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*}\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*} diff --git a/examples/morphology_point_trajectory.hs b/examples/morphology_point_trajectory.hs --- a/examples/morphology_point_trajectory.hs +++ b/examples/morphology_point_trajectory.hs @@ -1,5 +1,5 @@ #!/usr/bin/env stack --- stack --resolver lts-15.04 runghc --package reanimate +-- stack runghc --package reanimate module Main where import Codec.Picture.Types diff --git a/examples/morphology_rigid.hs b/examples/morphology_rigid.hs new file mode 100644 --- /dev/null +++ b/examples/morphology_rigid.hs @@ -0,0 +1,66 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ParallelListComp #-} +module Main(main) where + +import Codec.Picture +import Codec.Picture.Types +import Control.Monad +import Graphics.SvgTree (LineJoin (..)) +import Reanimate +import Reanimate.Morph.Common +import Reanimate.Morph.Linear +import Reanimate.Morph.Rigid (rigidMorph) + +bgColor :: PixelRGBA8 +bgColor = PixelRGBA8 252 252 252 0xFF + +main :: IO () +main = reanimate $ + addStatic (mkBackgroundPixel bgColor) $ + mapA (withStrokeWidth defaultStrokeWidth) $ + mapA (withStrokeColor "black") $ + mapA (withStrokeLineJoin JoinRound) $ + mapA (withFillOpacity 1) $ + sceneAnimation $ do + _ <- newSpriteSVG $ + withStrokeWidth 0 $ translate (-3) 4 $ + center $ latex "linear" + _ <- newSpriteSVG $ + withStrokeWidth 0 $ translate (3) 4 $ + center $ latex "as-rigid-as-possible" + forM_ pairs $ uncurry showPair + where + showPair from to = + waitOn $ do + fork $ play $ mkAnimation 4 (morph linear from to) + # mapA (translate (-3) (-0.5) . lowerTransformations . scale 1) + # signalA (curveS 4) + fork $ play $ mkAnimation 4 (morph myMorph from to) + # mapA (translate (3) (-0.5) . lowerTransformations . scale 1) + # signalA (curveS 4) + + myMorph = linear{morphTrajectory = rigidMorph, morphTolerance = 0.001 } + pairs = zip stages (tail stages ++ [head stages]) + stages = map (lowerTransformations . scale 6 . pathify . center) $ colorize + [ latex "S" + , latex "C" + ] + -- [ latex "X" + -- , latex "$\\aleph$" + -- , latex "Y" + -- , latex "$\\infty$" + -- , latex "I" + -- , latex "$\\pi$" + -- , latex "1" + -- , latex "S" + -- , mkRect 0.5 0.5 + -- ] + +colorize :: [SVG] -> [SVG] +colorize lst = + [ withFillColorPixel (promotePixel $ parula (n/fromIntegral (length lst-1))) elt + | elt <- lst + | n <- [0..] + ] diff --git a/examples/raster.golden b/examples/raster.golden # file too large to diff: examples/raster.golden diff --git a/examples/scene_camera.hs b/examples/scene_camera.hs new file mode 100644 --- /dev/null +++ b/examples/scene_camera.hs @@ -0,0 +1,144 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +{-# LANGUAGE OverloadedStrings #-} +module Main(main) where + +import Reanimate +import Reanimate.Builtin.Documentation +import Reanimate.Scene +import Control.Lens + +main :: IO () +{- +main = reanimate $ docEnv $ mapA (withFillOpacity 1) $ sceneAnimation $ do + cam <- newObject Camera + + newSpriteSVG_ $ withStrokeWidth (defaultStrokeWidth*0.5) $ mkGroup + [ mkLine (0, screenBottom) (0, screenTop) + , mkLine (screenLeft, 0) (screenRight, 0) + ] + + box <- newObject $ Rectangle 1 1 + cameraAttach cam box + oModify box $ oContext .~ withFillColor "green" + oModify box $ oMargin .~ (0,0,0,0) + oModify box $ oLeftX .~ 0 + oModify box $ oBottomY .~ 0 + oModify box $ oContext .~ withStrokeWidth 0 + + box2 <- newObject $ Rectangle 1 1 + cameraAttach cam box2 + oModify box2 $ oContext .~ withFillColor "blue" + oModify box2 $ oMargin .~ (0,0,0,0) + oModify box2 $ oCenterXY .~ (-2,2) + oModify box2 $ oContext .~ withStrokeWidth 0 + + dot <- newObject $ Circle 0.05 + cameraAttach cam dot + oModify dot $ oContext .~ withFillColor "red" + oModify dot $ oMargin .~ (0,0,0,0) + oModify dot $ oCenterXY .~ (0.5,0.5) + oModify dot $ oContext .~ withStrokeWidth 0 + + dot2 <- newObject $ Circle 0.05 + cameraAttach cam dot2 + oModify dot2 $ oContext .~ withFillColor "red" + oModify dot2 $ oMargin .~ (0,0,0,0) + oModify dot2 $ oCenterXY .~ (-2,2) + oModify dot2 $ oContext .~ withStrokeWidth 0 + + oShow box + oShow box2 + oShow dot + oShow dot2 + + wait 1 + + cameraSetFocus cam (0.5, 0.5) + waitOn $ do + fork $ cameraPan cam 1 (0.5, 0.5) + fork $ cameraZoom cam 1 2 + wait 1 + cameraSetFocus cam (-2,2) + cameraZoom cam 0.5 1.5 + cameraZoom cam 0.5 2 + wait 1 + -- cameraSetFocus cam (-0.5,0.5) + waitOn $ do + fork $ cameraPan cam 1 (-2, 2) + fork $ cameraZoom cam 1 0.5 + -- oTweenS cam 2 $ \t -> do + -- oScale %= \v -> fromToS v 3 t + + -- cameraSetFocus cam (0.5,0.5) + + -- oTweenS cam 1 $ \t -> do + -- oScale %= \v -> fromToS v 1 t + -- wait 4 + -- oTweenS cam 2 $ \t -> do + -- oScaleOrigin .= (fromToS 0.5 (-2) t, fromToS 0.5 2 t) + -- oScale .= fromToS 2 1 t + -- oTranslate . _1 %= \v -> fromToS v (-2) t + -- oTranslate . _2 %= \v -> fromToS v 2 t + {- + Origin: (-2,2) + Translate: (3, -1) + New origin: (0.5, 0.5) + + (0.5, 0.5) + (0.5+2, 0.5-2) + (2.5, -1.5) origin move + (2.5*3, -1.5*3) + (7.5, -4.5) scale + (7.5-2, -4.5+2) + (5.5, -2.5) origin move back + (5.5-3, -2.5+1) + (2.5, -1.5) translate + + (0.5-2.5, 0.5-(-1.5)) + (-2, 2) + -} + + wait 1 +-} +main = reanimate $ docEnv $ mapA (withFillOpacity 1) $ sceneAnimation $ do + cam <- newObject Camera + + txt <- newObject $ center $ latex "Fixed (non-cam)" + oModify txt $ + oTopY .~ screenTop + + circle <- newObject $ Circle 1 + cameraAttach cam circle + oModify circle $ oContext .~ withFillColor "blue" + circleRight <- oRead circle oRightX + + box <- newObject $ Rectangle 2 2 + cameraAttach cam box + oModify box $ oContext .~ withFillColor "green" + oModify box $ oLeftX .~ circleRight + boxCenter <- oRead box oCenterXY + + small <- newObject $ center $ latex "This text is very small" + cameraAttach cam small + oModifyS small $ do + oCenterXY .= boxCenter + oScale .= 0.1 + + oShow txt + oShow small + oShow circle + oShow box + + wait 1 + + cameraFocus cam boxCenter + waitOn $ do + fork $ cameraPan cam 3 boxCenter + fork $ cameraZoom cam 3 15 + + wait 2 + waitOn $ do + fork $ cameraZoom cam 3 1 + waitOn $ do + fork $ cameraPan cam 1 (0,0) diff --git a/examples/simulate_gravity.golden b/examples/simulate_gravity.golden --- a/examples/simulate_gravity.golden +++ b/examples/simulate_gravity.golden @@ -1,50 +1,10 @@ 0 -1 -2 -3 -4 -5 -6 -7 -8 -9 -10 -11 -12 -13 -14 -15 -16 -17 -18 -19 -20 -21 -22 -23 -24 -25 -26 -27 -28 -29 -30 -31 -32 -33 -34 -35 -36 -37 -38 -39 -40 -41 -42 -43 -44 -45 -46 -47 -48 -49 +1 +2 +3 +4 +5 +6 +7 +8 +9 diff --git a/examples/sphere.hs b/examples/sphere.hs --- a/examples/sphere.hs +++ b/examples/sphere.hs @@ -1,20 +1,21 @@ #!/usr/bin/env stack -- stack runghc --package reanimate {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE QuasiQuotes #-} module Main (main) where +import qualified Data.Text as T +import NeatInterpolation import Reanimate -import Data.String.Here main :: IO () main = reanimate $ mkAnimation 5 $ \t -> let s = fromToS 0 360 t in mkGroup [ mkBackground "black" - , povray [] (script s) ] + , povray [] (script $ T.pack $ show s) ] where - script s = [iTrim| + script s = [text| //EXAMPLE OF SPHERE //Files with predefined colors and textures diff --git a/examples/tut_glue_blender.hs b/examples/tut_glue_blender.hs --- a/examples/tut_glue_blender.hs +++ b/examples/tut_glue_blender.hs @@ -1,8 +1,8 @@ #!/usr/bin/env stack -- stack runghc --package reanimate +{-# LANGUAGE ApplicativeDo #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE ApplicativeDo #-} module Main (main) where import Reanimate @@ -11,9 +11,9 @@ import Control.Lens ((^.)) import Control.Monad import Data.Monoid -import Data.String.Here import qualified Data.Text as T -import Graphics.SvgTree +import Graphics.SvgTree hiding (text) +import NeatInterpolation import System.Random import System.Random.Shuffle @@ -25,7 +25,7 @@ trans <- newVar 0 rotX <- newVar 0 rotY <- newVar 0 - _ <- newSprite $ do + newSprite_ $ do getBend <- unVar bend getTrans <- unVar trans getRotX <- unVar rotX @@ -35,17 +35,16 @@ return $ seq (texture (t/dur)) $ blender (script (texture (t/dur)) getBend getTrans getRotX getRotY) wait 2 - tweenVar trans 5 (\t v -> fromToS v (-2) $ curveS 2 t) - tweenVar bend 5 (\t v -> fromToS v 1 $ curveS 2 t) - tweenVar rotY 15 (\t v -> fromToS v (pi*2*2) $ curveS 2 t) + fork $ tweenVar trans 5 $ \v -> fromToS v (-2) . curveS 2 + fork $ tweenVar bend 5 $ \v -> fromToS v 1 . curveS 2 + fork $ tweenVar rotY 15 $ \v -> fromToS v (pi*2*2) . curveS 2 fork $ do - tweenVar rotX 5 (\t v -> fromToS v (-pi/5) $ curveS 2 t) - wait 5 - tweenVar rotX 5 (\t v -> fromToS v (pi/5) $ curveS 2 t) + tweenVar rotX 5 $ \v -> fromToS v (-pi/5) . curveS 2 + tweenVar rotX 5 $ \v -> fromToS v (pi/5) . curveS 2 wait (15-5) - tweenVar bend 5 (\t v -> fromToS v 0 $ curveS 2 t) - tweenVar rotX 5 (\t v -> fromToS v 0 $ curveS 2 t) - tweenVar trans 5 (\t v -> fromToS v 0 $ curveS 2 t) + fork $ tweenVar bend 5 $ \v -> fromToS v 0 . curveS 2 + fork $ tweenVar rotX 5 $ \v -> fromToS v 0 . curveS 2 + fork $ tweenVar trans 5 $ \v -> fromToS v 0 . curveS 2 wait 4 -- tweenVar trans 1 (\t v -> fromToS v 0 $ curveS 2 t) wait 1 @@ -60,14 +59,21 @@ ] script :: FilePath -> Double -> Double -> Double -> Double -> T.Text -script img bend transZ rotX rotY = [iTrim| +script img bend transZ rotX rotY = + let img_ = T.pack img + bend_ = T.pack $ show bend + transZ_ = T.pack $ show transZ + rotX_ = T.pack $ show rotX + rotY_ = T.pack $ show rotY + yScale_ = T.pack $ show (fromToS (9/2) 4 bend) + in [text| import os import math import bpy cam = bpy.data.objects['Camera'] -cam.location = (0,0,22.25 + ${transZ}) +cam.location = (0,0,22.25 + ${transZ_}) cam.rotation_euler = (0, 0, 0) bpy.ops.object.empty_add(location=(0.0, 0, 0)) focus_target = bpy.context.object @@ -76,7 +82,7 @@ focus_target.select_set(True) bpy.ops.object.parent_set() -focus_target.rotation_euler = (${rotX}, 0, 0) +focus_target.rotation_euler = (${rotX_}, 0, 0) origin = bpy.data.objects['Cube'] @@ -84,10 +90,10 @@ origin.select_set(True) bpy.ops.object.delete() -x = ${bend} +x = ${bend_} bpy.ops.mesh.primitive_plane_add() plane = bpy.context.object -plane.scale = (16/2,${fromToS (9/2) 4 bend},1) +plane.scale = (16/2,${yScale_},1) bpy.ops.object.shade_smooth() bpy.context.object.active_material = bpy.data.materials['Material'] @@ -97,7 +103,7 @@ texture.inputs['Roughness'].default_value = 1 mat.node_tree.links.new(image_node.outputs['Color'], texture.inputs['Base Color']) -image_node.image = bpy.data.images.load('${T.pack img}') +image_node.image = bpy.data.images.load('${img_}') modifier = plane.modifiers.new(name='Subsurf', type='SUBSURF') @@ -131,7 +137,7 @@ bpy.ops.object.origin_clear() bpy.ops.object.origin_set(type='GEOMETRY_ORIGIN') -plane.rotation_euler = (0, ${rotY}, 0) +plane.rotation_euler = (0, ${rotY_}, 0) scn = bpy.context.scene @@ -180,7 +186,7 @@ -- Draw equation play $ drawAnimation strokedSvg sprites <- forM glyphs $ \(fn, _, elt) -> - newSpriteA $ animate $ const $ fn elt + newSpriteSVG $ fn elt -- Yoink each glyph forM_ (reverse sprites) $ \sprite -> do spriteE sprite (overBeginning 1 $ aroundCenterE $ highlightE) diff --git a/examples/tut_glue_keyframe.hs b/examples/tut_glue_keyframe.hs --- a/examples/tut_glue_keyframe.hs +++ b/examples/tut_glue_keyframe.hs @@ -51,7 +51,7 @@ svgCAF = center $ latex "\\LaTeX" getNth n = snd (splitGlyphs [n] svgCAF) svgs = [ - withStrokeWidth 0.01 $ + withStrokeWidth defaultStrokeWidth $ scale 2 $ translate 0 (tickLength*2) $ withStrokeColor "black" $ diff --git a/examples/tut_glue_potrace.hs b/examples/tut_glue_potrace.hs --- a/examples/tut_glue_potrace.hs +++ b/examples/tut_glue_potrace.hs @@ -5,12 +5,13 @@ module Main (main) where import Reanimate -import Reanimate.Povray (povraySlow') +import Reanimate.Povray (povraySlow') import Codec.Picture import Control.Monad -import Data.String.Here -import Data.Text (Text) +import Data.Text (Text) +import qualified Data.Text as T +import NeatInterpolation main :: IO () main = reanimate $ parA bg $ sceneAnimation $ do @@ -50,7 +51,11 @@ texture = checker 10 10 script :: FilePath -> Double -> Double -> Text -script png rotX rotY = [iTrim| +script png rotX rotY = + let png_ = T.pack png + rotX_ = T.pack $ show rotX + rotY_ = T.pack $ show rotY + in [text| #include "colors.inc" //Place the camera @@ -73,11 +78,11 @@ <0,0,0>, 3 texture { uv_mapping pigment{ - image_map{ png ${png} } + image_map{ png "${png_}" } } } - rotate <0,${rotY},0> - rotate <${rotX},0,0> + rotate <0,${rotY_},0> + rotate <${rotX_},0,0> } |] diff --git a/examples/tut_glue_povray.hs b/examples/tut_glue_povray.hs --- a/examples/tut_glue_povray.hs +++ b/examples/tut_glue_povray.hs @@ -12,10 +12,11 @@ import Codec.Picture.Types import Control.Lens ((^.)) import Control.Monad +import qualified Data.Text as T import Data.Monoid -import Data.String.Here +import NeatInterpolation import Data.Text (Text) -import Graphics.SvgTree hiding (Text) +import Graphics.SvgTree hiding (Text,text) import System.Random import System.Random.Shuffle @@ -46,7 +47,12 @@ texture t = frameAt (t*duration latexExample) latexExample script :: FilePath -> Double -> Double -> Double -> Text -script png transZ rotX rotZ = [iTrim| +script png transZ rotX rotZ = + let png_ = T.pack png + rotX_ = T.pack $ show rotX + transZ_ = T.pack $ show transZ + rotZ_ = T.pack $ show rotZ + in [text| #include "colors.inc" //Place the camera @@ -69,13 +75,13 @@ <0, 0>, <0, 1>, <1, 1>, <1, 0> texture { pigment{ - image_map{ png ${png} } + image_map{ png "${png_}" } } } translate <-1/2,-1/2> scale <16,9> - rotate <0,${rotX},${rotZ}> - translate <0,0,${transZ}> + rotate <0,${rotX_},${rotZ_}> + translate <0,0,${transZ_}> } |] diff --git a/examples/tut_glue_povray_ortho.hs b/examples/tut_glue_povray_ortho.hs --- a/examples/tut_glue_povray_ortho.hs +++ b/examples/tut_glue_povray_ortho.hs @@ -1,8 +1,8 @@ #!/usr/bin/env stack -- stack runghc --package reanimate +{-# LANGUAGE ApplicativeDo #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE ApplicativeDo #-} module Main (main) where import Reanimate @@ -13,9 +13,10 @@ import Control.Lens ((^.)) import Control.Monad import Data.Monoid -import Data.String.Here import Data.Text (Text) -import Graphics.SvgTree hiding (Text) +import qualified Data.Text as T +import Graphics.SvgTree hiding (Text,text) +import NeatInterpolation import System.Random import System.Random.Shuffle @@ -25,7 +26,7 @@ xRot <- newVar (-30) yRot <- newVar 180 zRot <- newVar 0 - _ <- newSprite $ do + newSprite_ $ do getX <- unVar xRot getY <- unVar yRot getZ <- unVar zRot @@ -36,11 +37,11 @@ script (svgAsPngFile (texture (t/dur))) getX getY getZ wait 2 let tDuration = 10 - tweenVar yRot tDuration (\t v -> fromToS v (v+180) $ curveS 2 (t/tDuration)) - tweenVar xRot (tDuration/2) (\t v -> fromToS v (v+60) $ curveS 2 (t/(tDuration/2))) + fork $ tweenVar yRot tDuration $ \v -> fromToS v (v+180) . curveS 2 + fork $ tweenVar xRot (tDuration/2) $ \v -> fromToS v (v+60) . curveS 2 fork $ do wait (tDuration/2) - tweenVar xRot (tDuration/2) (\t v -> fromToS v (v-60) $ curveS 2 (t/(tDuration/2))) + tweenVar xRot (tDuration/2) $ \v -> fromToS v (v-60) . curveS 2 wait tDuration wait 2 where @@ -53,7 +54,12 @@ ] script :: FilePath -> Double -> Double -> Double -> Text -script png rotX rotY rotZ = [iTrim| +script png rotX rotY rotZ = + let png_ = T.pack png + rotX_ = T.pack $ show rotX + rotY_ = T.pack $ show rotY + rotZ_ = T.pack $ show rotZ + in [text| //Files with predefined colors and textures #include "colors.inc" @@ -82,11 +88,11 @@ <0,0,0>, 4 texture { uv_mapping pigment{ - image_map{ png ${png} } + image_map{ png "${png_}" } } } - rotate <0,${rotY},${rotZ}> - rotate <${rotX},0,0> + rotate <0,${rotY_},${rotZ_}> + rotate <${rotX_},0,0> } |] @@ -128,7 +134,7 @@ -- Draw equation play $ drawAnimation strokedSvg sprites <- forM glyphs $ \(fn, _, elt) -> - newSpriteA $ animate $ const $ fn elt + newSpriteSVG $ fn elt -- Yoink each glyph forM_ (reverse sprites) $ \sprite -> do spriteE sprite (overBeginning 1 $ aroundCenterE $ highlightE) diff --git a/examples/tut_glue_svg.hs b/examples/tut_glue_svg.hs --- a/examples/tut_glue_svg.hs +++ b/examples/tut_glue_svg.hs @@ -32,7 +32,7 @@ comp4 = svgComponent "Images" (scale 0.5 svgLogo) comp5 = svgComponent "Paths" $ withFillOpacity 0 $ - scale 8 $ withStrokeWidth (defaultStrokeWidth*0.3) $ + scale 8 $ withStrokeWidth defaultStrokeWidth $ center $ latex "$\\pi$" comp6 = svgComponent "Blurs" mkBlur comp7 = svgComponent "Blobs" mkBlob diff --git a/examples/voice_advanced.hs b/examples/voice_advanced.hs --- a/examples/voice_advanced.hs +++ b/examples/voice_advanced.hs @@ -1,5 +1,5 @@ #!/usr/bin/env stack --- stack --resolver lts-15.04 runghc --package reanimate +-- stack runghc --package reanimate {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ApplicativeDo #-} module Main where diff --git a/examples/voice_fake.hs b/examples/voice_fake.hs --- a/examples/voice_fake.hs +++ b/examples/voice_fake.hs @@ -1,5 +1,5 @@ #!/usr/bin/env stack --- stack --resolver lts-15.04 runghc --package reanimate +-- stack runghc --package reanimate {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ApplicativeDo #-} module Main where diff --git a/examples/voice_transcript.hs b/examples/voice_transcript.hs --- a/examples/voice_transcript.hs +++ b/examples/voice_transcript.hs @@ -1,5 +1,5 @@ #!/usr/bin/env stack --- stack --resolver lts-15.04 runghc --package reanimate +-- stack runghc --package reanimate {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ApplicativeDo #-} module Main where @@ -18,15 +18,13 @@ main = reanimate $ sceneAnimation $ do newSpriteSVG_ $ mkBackgroundPixel rtfdBackgroundColor waitOn $ forM_ (splitTranscript transcript) $ \(svg, tword) -> fork $ do - highlighted <- newVar 0 - newSprite_ $ do - v <- unVar highlighted - pure $ centerUsing (latex $ transcriptText transcript) $ masked - (wordKey tword) - v - svg - (withFillColor "grey" $ mkRect 1 1) - (withFillColor "black" $ mkRect 1 1) + let render v = centerUsing (latex $ transcriptText transcript) $ masked + (wordKey tword) + v + svg + (withFillColor "grey" $ mkRect 1 1) + (withFillColor "black" $ mkRect 1 1) + highlighted <- simpleVar render 0 wait (wordStart tword) let dur = wordEnd tword - wordStart tword tweenVar highlighted dur $ \v -> fromToS v 1 diff --git a/examples/voice_triggers.hs b/examples/voice_triggers.hs --- a/examples/voice_triggers.hs +++ b/examples/voice_triggers.hs @@ -1,5 +1,5 @@ #!/usr/bin/env stack --- stack --resolver lts-15.04 runghc --package reanimate +-- stack runghc --package reanimate {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ApplicativeDo #-} module Main where @@ -15,20 +15,19 @@ transcript = loadTranscript "voice_triggers.txt" transformer :: SVG -> SVG -transformer = scale 1 . translate (-4) 0 . centerUsing (latex $ transcriptText transcript) +transformer = + translate (-4) 0 . centerUsing (latex $ transcriptText transcript) main :: IO () main = reanimate $ sceneAnimation $ do newSpriteSVG_ $ mkBackgroundPixel rtfdBackgroundColor waitOn $ forM_ (splitTranscript transcript) $ \(svg, tword) -> do - highlighted <- newVar 0 - void $ newSprite $ do - v <- unVar highlighted - pure $ transformer $ masked (wordKey tword) - v - svg - (withFillColor "grey" $ mkRect 1 1) - (withFillColor "black" $ mkRect 1 1) + let render v = transformer $ masked (wordKey tword) + v + svg + (withFillColor "grey" $ mkRect 1 1) + (withFillColor "black" $ mkRect 1 1) + highlighted <- simpleVar render 0 let dur = wordEnd tword - wordStart tword fork $ do wait (wordStart tword) @@ -45,11 +44,15 @@ _ -> return () wait 2 where - wordKey tword = T.unpack (wordReference tword) ++ show (wordStartOffset tword) + wordKey tword = + T.unpack (wordReference tword) ++ show (wordStartOffset tword) highlight dur img = play $ animate - (\t -> translate (screenWidth / 4) 0 $ scale t $ scaleToHeight 4 $ center img) + (\t -> + translate (screenWidth / 4) 0 $ scale t $ scaleToHeight 4 $ center + img + ) # signalA (bellS 2) # setDuration dur diff --git a/reanimate.cabal b/reanimate.cabal --- a/reanimate.cabal +++ b/reanimate.cabal @@ -3,7 +3,7 @@ -- see http://haskell.org/cabal/users-guide/ name: reanimate -version: 0.3.3.0 +version: 0.4.0.0 -- synopsis: -- description: license: PublicDomain @@ -11,7 +11,8 @@ maintainer: lemmih@gmail.com category: Graphics synopsis: Animation library based on SVGs. -homepage: https://github.com/Lemmih/reanimate +homepage: https://github.com/reanimate/reanimate#readme +bug-reports: https://github.com/reanimate/reanimate/issues build-type: Simple extra-source-files: ChangeLog.md, examples/*.hs, examples/*.golden extra-doc-files: docs/gifs/*.gif @@ -36,11 +37,18 @@ Type: git Location: git://github.com/lemmih/reanimate.git -Flag hmatrix - Description: Enable hmatrix dependency (requires blas and lapack) - Default: True +-- If both 'enable-hmatrix' and 'disable-hmatrix' are false, then use +-- hmatrix on Macos and Linux but not Windows. +Flag enable-hmatrix + Description: Enable hmatrix dependency on Windows (requires openblas) + Default: False Manual: True +Flag disable-hmatrix + Description: Force disable hmatrix dependency + Default: False + Manual: True + Flag test Description: Enable testing (requires stack) Default: False @@ -66,7 +74,6 @@ Reanimate.Math.Common Reanimate.Math.Polygon Reanimate.Math.Triangulate - Reanimate.Math.DCEL Reanimate.Math.EarClip Reanimate.Math.Visibility Reanimate.Math.SSSP @@ -92,6 +99,7 @@ Reanimate.Builtin.TernaryPlot Reanimate.Builtin.CirclePlot Reanimate.Builtin.Flip + Reanimate.Builtin.Slide Reanimate.Constants Reanimate.Parameters Reanimate.Chiphunk @@ -99,28 +107,32 @@ Reanimate.GeoProjection Reanimate.Builtin.Documentation Reanimate.Builtin.Images + Reanimate.Debug Reanimate.Voice other-modules: Reanimate.Cache Reanimate.Driver Reanimate.Driver.Check Reanimate.Driver.CLI + Reanimate.Driver.Magick Reanimate.Driver.Server Reanimate.Driver.Compile Paths_reanimate build-depends: base >=4.10 && <5, time, text, filepath, process, directory, - containers, reanimate-svg >= 0.9.7.0, xml, bytestring, lens, linear, mtl, matrix, - JuicyPixels, attoparsec, parallel, + containers, reanimate-svg >= 0.10.0.0, xml, bytestring, lens, linear, mtl, matrix, + JuicyPixels >= 3.3.3, attoparsec, parallel, cubicbezier, websockets >= 0.12.7.0, hashable, fsnotify, open-browser, random, random-shuffle, base64-bytestring, - vector >= 0.12.0.0, colour, cassava, ansi-wl-pprint, here, temporary, + vector >= 0.12.0.0, colour, cassava, ansi-terminal, temporary, optparse-applicative, chiphunk >= 0.1.2.1, - geojson, aeson >= 1.3.0.0, - split, fingertree, array, cereal, vector-space - if flag(hmatrix) { + geojson, aeson >= 1.3.0.0, earcut >= 0.1.0.4, + split, array, cereal, vector-space, + neat-interpolation >= 0.3 + if (flag(enable-hmatrix) || !os(windows)) && !flag(disable-hmatrix) { build-depends: hmatrix >= 0.20.0.0 exposed-modules: Reanimate.Morph.Rigid Reanimate.Math.Smooth + Reanimate.Math.DCEL } ghc-options: -Wall -fno-ignore-asserts @@ -145,5 +157,4 @@ reanimate, vector, linear, QuickCheck >= 2.1.0, text, tasty, tasty-golden, tasty-hunit, - tasty-quickcheck, - ansi-wl-pprint + tasty-quickcheck, tasty-rerun >= 1.1.17 diff --git a/src/Reanimate.hs b/src/Reanimate.hs --- a/src/Reanimate.hs +++ b/src/Reanimate.hs @@ -38,6 +38,7 @@ -- * Animations SVG, Time, + Duration, Animation(..), mkAnimation, animate, @@ -157,6 +158,7 @@ latex, latexAlign, xelatex, + ctex, -- * External 3D renderers povray, povray', @@ -178,6 +180,10 @@ -- * Constants screenWidth, screenHeight, + screenTop, + screenBottom, + screenLeft, + screenRight, defaultDPI, defaultStrokeWidth, -- * Parameters diff --git a/src/Reanimate/Builtin/Flip.hs b/src/Reanimate/Builtin/Flip.hs --- a/src/Reanimate/Builtin/Flip.hs +++ b/src/Reanimate/Builtin/Flip.hs @@ -18,7 +18,7 @@ import Reanimate.Transition import Reanimate.Svg.Constructors -import Data.String.Here +import NeatInterpolation (text) import qualified Data.Text as T data FlipSprite s = FlipSprite @@ -33,21 +33,21 @@ bend <- newVar 0 trans <- newVar 0 rotX <- newVar 0 - s <- newSprite $ do + sprite <- newSprite $ do getBend <- unVar bend getTrans <- unVar trans getRotX <- unVar rotX - t <- spriteT + time <- spriteT dur <- spriteDuration return $ - let rotY = fromToS 0 pi (t/dur) - frontTexture = svgAsPngFile (frameAt t $ setDuration dur front) - backTexture = svgAsPngFile (flipXAxis $ frameAt t $ setDuration dur back) + let rotY = fromToS 0 pi (time/dur) + frontTexture = svgAsPngFile (frameAt time $ setDuration dur front) + backTexture = svgAsPngFile (flipXAxis $ frameAt time $ setDuration dur back) -- seq'ing frontTexture and backTexture is required to avoid segfaults. :( in frontTexture `seq` backTexture `seq` blender (script frontTexture backTexture getBend getTrans getRotX rotY) return FlipSprite - { fsSprite = s + { fsSprite = sprite , fsBend = bend , fsZoom = trans , fsWobble = rotX } @@ -69,7 +69,15 @@ wobble = -pi*0.10 script :: FilePath -> FilePath -> Double -> Double -> Double -> Double -> T.Text -script frontImage backImage bend transZ rotX rotY = [iTrim| +script frontImage backImage bend transZ rotX rotY = + let transZ_ = T.pack (show transZ) + rotX_ = T.pack (show rotX) + bend_ = T.pack (show bend) + yScale_ = T.pack (show $ fromToS (9/2) 4 bend) + frontImage_ = T.pack frontImage + backImage_ = T.pack backImage + rotY_ = T.pack (show rotY) + in [text| import os import math @@ -82,7 +90,7 @@ cam = bpy.data.objects['Camera'] -cam.location = (0,0,22.22 + ${transZ}) +cam.location = (0,0,22.22 + $transZ_) cam.rotation_euler = (0, 0, 0) bpy.ops.object.empty_add(location=(0.0, 0, 0)) focus_target = bpy.context.object @@ -91,7 +99,7 @@ focus_target.select_set(True) bpy.ops.object.parent_set() -focus_target.rotation_euler = (${rotX}, 0, 0) +focus_target.rotation_euler = ($rotX_, 0, 0) origin = bpy.data.objects['Cube'] @@ -99,10 +107,10 @@ origin.select_set(True) bpy.ops.object.delete() -x = ${bend} +x = $bend_ bpy.ops.mesh.primitive_plane_add() plane = bpy.context.object -plane.scale = (16/2,${fromToS (9/2) 4 bend},1) +plane.scale = (16/2,$yScale_,1) bpy.ops.object.shade_smooth() bpy.context.object.active_material = bpy.data.materials['Material'] @@ -129,10 +137,10 @@ mat.node_tree.links.new(transparent.outputs['BSDF'], gh_mix.inputs[1]) mat.node_tree.links.new(gh_mix.outputs['Shader'], mix.inputs[2]) -image_node.image = bpy.data.images.load('${T.pack frontImage}') +image_node.image = bpy.data.images.load('${frontImage_}') image_node.interpolation = 'Closest' -gh_node.image = bpy.data.images.load('${T.pack backImage}') +gh_node.image = bpy.data.images.load('${backImage_}') gh_node.interpolation = 'Closest' @@ -166,7 +174,7 @@ bpy.ops.object.origin_clear() bpy.ops.object.origin_set(type='GEOMETRY_ORIGIN') -plane.rotation_euler = (0, ${rotY}, 0) +plane.rotation_euler = (0, $rotY_, 0) scn = bpy.context.scene diff --git a/src/Reanimate/Builtin/Images.hs b/src/Reanimate/Builtin/Images.hs --- a/src/Reanimate/Builtin/Images.hs +++ b/src/Reanimate/Builtin/Images.hs @@ -2,6 +2,7 @@ ( svgLogo , haskellLogo , githubIcon + , githubWhiteIcon , smallEarth ) where @@ -43,6 +44,10 @@ -- | <> githubIcon :: SVG githubIcon = unsafePerformIO $ embedImage "data/github-icon.svg" + +{-# NOINLINE githubWhiteIcon #-} +githubWhiteIcon :: SVG +githubWhiteIcon = unsafePerformIO $ embedImage "data/github-icon-white.svg" -- | 300x150 equirectangular earth -- diff --git a/src/Reanimate/Builtin/Slide.hs b/src/Reanimate/Builtin/Slide.hs new file mode 100644 --- /dev/null +++ b/src/Reanimate/Builtin/Slide.hs @@ -0,0 +1,28 @@ +module Reanimate.Builtin.Slide where + +import Reanimate.Transition +import Reanimate.Constants +import Reanimate.Svg +import Reanimate.Effect + +-- | <> +slideLeftT :: Transition +slideLeftT = effectT slideLeft (andE slideLeft moveRight) + where + slideLeft = translateE (-screenWidth) 0 + moveRight = constE (translate screenWidth 0) + andE a b d t = a d t . b d t + +slideDownT :: Transition +slideDownT = effectT slideDown (andE slideDown moveUp) + where + slideDown = translateE 0 (-screenHeight) + moveUp = constE (translate 0 screenHeight) + andE a b d t = a d t . b d t + +slideUpT :: Transition +slideUpT = effectT slideUp (andE slideUp moveDown) + where + slideUp = translateE 0 screenHeight + moveDown = constE (translate 0 (-screenHeight)) + andE a b d t = a d t . b d t diff --git a/src/Reanimate/Constants.hs b/src/Reanimate/Constants.hs --- a/src/Reanimate/Constants.hs +++ b/src/Reanimate/Constants.hs @@ -1,16 +1,25 @@ module Reanimate.Constants ( screenWidth , screenHeight + , screenTop + , screenBottom + , screenLeft + , screenRight , defaultDPI , defaultStrokeWidth ) where import Graphics.SvgTree -screenWidth, screenHeight :: Num a => a +screenWidth, screenHeight, screenTop :: Fractional a => a +screenBottom, screenLeft, screenRight :: Fractional a => a screenWidth = 16 screenHeight = 9 +screenTop = screenHeight/2 +screenBottom = -screenHeight/2 +screenLeft = -screenWidth/2 +screenRight = screenWidth/2 defaultDPI :: Dpi defaultDPI = 96 diff --git a/src/Reanimate/Debug.hs b/src/Reanimate/Debug.hs new file mode 100644 --- /dev/null +++ b/src/Reanimate/Debug.hs @@ -0,0 +1,58 @@ +module Reanimate.Debug + ( traceSVG + , traceA + , playTraces + ) +where + +import Data.IORef +import System.IO.Unsafe +import Control.Exception +import Reanimate.Animation +import Reanimate.Svg +import Reanimate.LaTeX +import Reanimate.Constants +import Text.Printf +import qualified Data.Text as T + +{-# NOINLINE traceBuffer #-} +traceBuffer :: IORef [Animation] +traceBuffer = unsafePerformIO (newIORef []) + +{-# NOINLINE traceSVG #-} +traceSVG :: SVG -> a -> a +traceSVG = traceA . staticFrame (recip 60) + +{-# NOINLINE traceA #-} +traceA :: Animation -> a -> a +traceA a v = unsafePerformIO $ do + modifyIORef' traceBuffer (a :) + evaluate v + +{-# NOINLINE playTraces #-} +playTraces :: a -> Animation +playTraces v = unsafePerformIO $ do + _ <- evaluate v + lst <- atomicModifyIORef' traceBuffer (\x -> ([], reverse x)) + let n = length lst :: Int + return $ foldr + seqA + (pause 0) + [ f `parA` staticFrame (duration f) (counter i n) | (i, f) <- zip [1 :: Int ..] lst ] + where + counter a b = mkGroup + [ withStrokeWidth defaultStrokeWidth + $ withStrokeColor "black" + $ translate 6.5 4 + $ center + $ latex + $ T.pack + $ printf "%d/%d" a b + , withStrokeWidth 0 + $ withFillColor "white" + $ translate 6.5 4 + $ center + $ latex + $ T.pack + $ printf "%d/%d" a b + ] diff --git a/src/Reanimate/Driver.hs b/src/Reanimate/Driver.hs --- a/src/Reanimate/Driver.hs +++ b/src/Reanimate/Driver.hs @@ -5,21 +5,22 @@ ) where -import Control.Applicative ( (<|>) ) +import Control.Applicative ((<|>)) +import Control.Monad import Data.Maybe -import Reanimate.Animation ( Animation ) +import Data.Either +import Reanimate.Animation (Animation) import Reanimate.Driver.Check import Reanimate.Driver.CLI import Reanimate.Driver.Compile import Reanimate.Driver.Server import Reanimate.Parameters -import Reanimate.Render ( render - , renderSnippets - , renderSvgs - , selectRaster - ) +import Reanimate.Render (render, renderSnippets, renderSvgs, + selectRaster) import System.Directory +import System.Exit import System.FilePath +import System.IO import Text.Printf presetFormat :: Preset -> Format @@ -109,7 +110,7 @@ -- hSetBinaryMode stdout True renderSnippets animation Check -> checkEnvironment - View -> serve + View {..} -> serve viewVerbose viewGHCPath viewGHCOpts viewOrigin Render {..} -> do let fmt = guessParameter renderFormat (fmap presetFormat renderPreset) @@ -141,8 +142,23 @@ ) (userPreferredDimensions renderWidth renderHeight) + raster <- + if renderRaster == RasterNone || renderRaster == RasterAuto then do + svgSupport <- hasFFmpegRSvg + if isRight svgSupport + then selectRaster renderRaster + else do + raster <- selectRaster RasterAuto + when (raster == RasterNone) $ do + hPutStrLn stderr $ + "Error: your FFmpeg was built without SVG support and no raster engines \ + \are available. Please install either inkscape, imagemagick, or rsvg." + exitWith (ExitFailure 1) + return raster + else selectRaster renderRaster + if renderCompile - then compile + then compile $ [ "render" , "--fps" , show fps @@ -153,15 +169,14 @@ , "--format" , showFormat fmt , "--raster" - , showRaster renderRaster + , showRaster raster , "--target" , target , "+RTS" , "-N" , "-RTS" - ] + ] ++ [ "--partial" | renderPartial ] else do - raster <- selectRaster renderRaster setRaster raster setFPS fps setWidth width @@ -181,7 +196,7 @@ target (show raster) - render animation target raster fmt width height fps + render animation target raster fmt width height fps renderPartial guessParameter :: Maybe a -> Maybe a -> a -> a guessParameter a b def = fromMaybe def (a <|> b) diff --git a/src/Reanimate/Driver/CLI.hs b/src/Reanimate/Driver/CLI.hs --- a/src/Reanimate/Driver/CLI.hs +++ b/src/Reanimate/Driver/CLI.hs @@ -25,6 +25,11 @@ | Test | Check | View + { viewVerbose :: Bool + , viewGHCPath :: Maybe FilePath + , viewGHCOpts :: [String] + , viewOrigin :: Maybe FilePath + } | Render { renderTarget :: Maybe String , renderFPS :: Maybe FPS @@ -34,6 +39,7 @@ , renderFormat :: Maybe Format , renderPreset :: Maybe Preset , renderRaster :: Raster + , renderPartial :: Bool } deriving (Show) @@ -43,19 +49,19 @@ readRaster :: String -> Maybe Raster readRaster raster = case map toLower raster of - "none" -> Just RasterNone - "auto" -> Just RasterAuto - "inkscape" -> Just RasterInkscape - "rsvg" -> Just RasterRSvg - "convert" -> Just RasterConvert - _ -> Nothing + "none" -> Just RasterNone + "auto" -> Just RasterAuto + "inkscape" -> Just RasterInkscape + "rsvg" -> Just RasterRSvg + "imagemagick" -> Just RasterMagick + _ -> Nothing showRaster :: Raster -> String showRaster RasterNone = "none" showRaster RasterAuto = "auto" showRaster RasterInkscape = "inkscape" showRaster RasterRSvg = "rsvg" -showRaster RasterConvert = "convert" +showRaster RasterMagick = "imagemagick" readFormat :: String -> Maybe Format readFormat fmt = @@ -112,7 +118,7 @@ testCommand :: ParserInfo Command testCommand = info (parse <**> helper) - (progDesc "Generate 50 frames spread out evenly across the animation. Used \ + (progDesc "Generate 10 frames spread out evenly across the animation. Used \ \internally by the test-suite.") where parse = pure Test @@ -127,7 +133,18 @@ viewCommand = info parse (progDesc "Play animation in browser window.") where - parse = pure View + parse = View + <$> switch + (long "verbose" <> short 'v') + <*> optional (strOption (long "ghc" + <> metavar "PATH" + <> help "Path to GHC binary")) + <*> many (strOption (long "ghc-opt" + <> short 'G' + <> help "Additional option to pass to ghc")) + <*> optional (strOption (long "self" + <> metavar "PATH" + <> help "Source file used for live-reloading")) renderCommand :: ParserInfo Command renderCommand = info parse @@ -169,7 +186,11 @@ (long "raster" <> showDefaultWith showRaster <> metavar "RASTER" <> value RasterNone - <> help "Raster engine: none, auto, inkscape, rsvg, convert") + <> help "Raster engine: none, auto, inkscape, rsvg, imagemagick") + <*> switch + (long "partial" + <> help "Produce partial animation even if frame generation was \ + \interrupted by ctrl-c") opts :: ParserInfo Options opts = info (options <**> helper ) diff --git a/src/Reanimate/Driver/Check.hs b/src/Reanimate/Driver/Check.hs --- a/src/Reanimate/Driver/Check.hs +++ b/src/Reanimate/Driver/Check.hs @@ -3,7 +3,8 @@ ( checkEnvironment , hasRSvg , hasInkscape - , hasConvert + , hasMagick + , hasFFmpegRSvg ) where import Control.Exception (SomeException, handle) @@ -11,11 +12,12 @@ import Data.Maybe import Data.Version import Reanimate.Misc (runCmd_) +import Reanimate.Driver.Magick (magickCmd) +import System.Console.ANSI.Codes import System.Directory (findExecutable) import System.IO import System.IO.Temp import Text.ParserCombinators.ReadP -import qualified Text.PrettyPrint.ANSI.Leijen as Doc import Text.Printf -------------------------------------------------------------------------- @@ -25,12 +27,13 @@ checkEnvironment = do putStrLn "reanimate checks:" runCheck "Has ffmpeg" hasFFmpeg + runCheck "Has ffmpeg(rsvg)" hasFFmpegRSvg runCheck "Has dvisvgm" hasDvisvgm runCheck "Has povray" hasPovray runCheck "Has blender" hasBlender runCheck "Has rsvg-convert" hasRSvg runCheck "Has inkscape" hasInkscape - runCheck "Has convert" hasConvert + runCheck "Has imagemagick" hasMagick runCheck "Has LaTeX" hasLaTeX runCheck ("Has LaTeX package '"++ "babel" ++ "'") $ hasTeXPackage "latex" "[english]{babel}" @@ -66,9 +69,13 @@ printf " %-35s" (msg ++ ":") val <- fn case val of - Left err -> print $ Doc.red $ Doc.text err - Right ok -> print $ Doc.green $ Doc.text ok + Left err -> putStrLnColor Red err + Right ok -> putStrLnColor Green ok +putStrLnColor :: Color -> String -> IO () +putStrLnColor color msg = + putStrLn $ setSGRCode [SetColor Foreground Vivid color] ++ msg ++ setSGRCode [Reset] + -- latex, dvisvgm, xelatex hasLaTeX :: IO (Either String String) @@ -88,6 +95,18 @@ where minVersion = Version [4,1,3] [] +hasFFmpegRSvg :: IO (Either String String) +hasFFmpegRSvg = do + mbPath <- findExecutable "ffmpeg" + case mbPath of + Nothing -> return $ Left "n/a" + Just path -> do + ret <- runCmd_ path ["-version"] + pure $ case ret of + Right out | "--enable-librsvg" `elem` words out + -> Right "yes" + _ -> Left "no" + hasBlender :: IO (Either String String) hasBlender = checkMinVersion minVersion <$> blenderVersion where @@ -103,8 +122,8 @@ where minVersion = Version [0,92] [] -hasConvert :: IO (Either String String) -hasConvert = checkMinVersion minVersion <$> convertVersion +hasMagick :: IO (Either String String) +hasMagick = checkMinVersion minVersion <$> magickVersion where minVersion = Version [6,0,0] [] @@ -112,31 +131,31 @@ ffmpegVersion = extractVersion "ffmpeg" ["-version"] $ \line -> case take 3 $ words line of ["ffmpeg", "version", vs] -> vs - _ -> "" + _ -> "" blenderVersion :: IO (Maybe Version) blenderVersion = extractVersion "blender" ["--version"] $ \line -> case take 2 (words line) of ["Blender", vs] -> vs - _ -> "" + _ -> "" rsvgVersion :: IO (Maybe Version) rsvgVersion = extractVersion "rsvg-convert" ["--version"] $ \line -> case words line of ["rsvg-convert", "version", vs] -> vs - _ -> "" + _ -> "" inkscapeVersion :: IO (Maybe Version) inkscapeVersion = extractVersion "inkscape" ["--version"] $ \line -> case take 2 $ words line of ["Inkscape", vs] -> vs - _ -> "" + _ -> "" -convertVersion :: IO (Maybe Version) -convertVersion = extractVersion "convert" ["-version"] $ \line -> +magickVersion :: IO (Maybe Version) +magickVersion = extractVersion magickCmd ["-version"] $ \line -> case take 3 $ words line of ["Version:", "ImageMagick", vs] -> vs - _ -> "" + _ -> "" checkMinVersion :: Version -> Maybe Version -> Either String String checkMinVersion _minVersion Nothing = Left "no" diff --git a/src/Reanimate/Driver/Magick.hs b/src/Reanimate/Driver/Magick.hs new file mode 100644 --- /dev/null +++ b/src/Reanimate/Driver/Magick.hs @@ -0,0 +1,18 @@ +module Reanimate.Driver.Magick + ( magickCmd + ) where + +import System.IO.Unsafe (unsafePerformIO) +import System.Directory (findExecutable) + +-- |The name of the ImageMagick command. On Unix-like operating systems, the +-- command 'convert' does not conflict with the name of other commands. On +-- Windows, ImageMagick version 7 is readily available, the command 'magick' +-- should be present, and is preferred over 'convert'. If it is not present, +-- 'convert' is assumed to be the relevant command. +magickCmd :: String +-- The use of 'unsafeperformIO' is justified on the basis that if 'magick' is +-- found once, it will always be present. +magickCmd = unsafePerformIO $ do + mPath <- findExecutable "magick" + pure $ maybe "convert" (const "magick") mPath diff --git a/src/Reanimate/Driver/Server.hs b/src/Reanimate/Driver/Server.hs --- a/src/Reanimate/Driver/Server.hs +++ b/src/Reanimate/Driver/Server.hs @@ -23,6 +23,7 @@ withCurrentDirectory) import System.Environment (getProgName) import System.Exit +import System.Process import System.FilePath import System.FSNotify import System.IO @@ -33,10 +34,12 @@ opts = defaultConnectionOptions { connectionCompressionOptions = PermessageDeflateCompression defaultPermessageDeflate } -serve :: IO () -serve = withManager $ \watch -> do +serve :: Bool -> Maybe FilePath -> [String] -> Maybe FilePath -> IO () +serve verbose mbGHCPath extraGHCOpts mbSelfPath = withManager $ \watch -> do hSetBuffering stdin NoBuffering - self <- findOwnSource + self <- maybe findOwnSource pure mbSelfPath + when verbose $ + putStrLn $ "Found own source code at: " ++ self hasConnectionVar <- newMVar False -- There might already browser window open. Wait 2s to see if that window @@ -66,7 +69,7 @@ let handler = modifyMVar_ slave $ \tid -> do putStrLn "Reloading code..." killThread tid - forkIO $ ignoreErrors $ slaveHandler conn self tmpDir + forkIO $ ignoreErrors $ slaveHandler verbose mbGHCPath extraGHCOpts conn self tmpDir killSlave = do tid <- takeMVar slave killThread tid @@ -92,8 +95,8 @@ then putStrLn "Browser opened." else hPutStrLn stderr $ "Failed to open browser. Manually visit: " ++ url -slaveHandler :: Connection -> FilePath -> FilePath -> IO () -slaveHandler conn self svgDir = +slaveHandler :: Bool -> Maybe FilePath -> [String] -> Connection -> FilePath -> FilePath -> IO () +slaveHandler verbose mbGHCPath extraGHCOpts conn self svgDir = withCurrentDirectory (takeDirectory self) $ withSystemTempDirectory "reanimate" $ \tmpDir -> withTempFile tmpDir "reanimate.exe" $ \tmpExecutable handle -> do @@ -103,10 +106,20 @@ hClose handle lock <- newMVar () sendTextData conn (T.pack "status\nCompiling") - ret <- runCmd_ "stack" $ ["ghc", "--"] ++ ghcOptions tmpDir ++ [takeFileName self, "-o", tmpExecutable] + ret <- case mbGHCPath of + Nothing -> do + let args = ["ghc", "--"] ++ ghcOptions tmpDir ++ extraGHCOpts ++ [takeFileName self, "-o", tmpExecutable] + when verbose $ + putStrLn $ "Running: " ++ showCommandForUser "stack" args + runCmd_ "stack" args + Just ghc -> do + let args = ghcOptions tmpDir ++ extraGHCOpts ++ [takeFileName self, "-o", tmpExecutable] + when verbose $ + putStrLn $ "Running: " ++ showCommandForUser ghc args + runCmd_ ghc args case ret of Left err -> - sendTextData conn $ T.pack $ "error\n" ++ unlines (drop 3 (lines err)) + sendTextData conn $ T.pack $ "error\n" ++ unlines (lines err) Right{} -> runCmdLazy tmpExecutable execOpts $ \getFrame -> do (frameCount,_) <- expectFrame sem =<< getFrame sendTextData conn (T.pack $ "frame_count\n" ++ show frameCount) @@ -135,7 +148,7 @@ sendTextData conn (T.pack "status\nDone") exitSuccess expectFrame _ (Left err) = do - sendTextData conn $ T.pack $ "Error" ++ err + sendTextData conn $ T.pack $ "error\n" ++ err exitWith (ExitFailure 1) expectFrame _ (Right frame) = case T.decimal frame of diff --git a/src/Reanimate/LaTeX.hs b/src/Reanimate/LaTeX.hs --- a/src/Reanimate/LaTeX.hs +++ b/src/Reanimate/LaTeX.hs @@ -2,8 +2,12 @@ {-# LANGUAGE ScopedTypeVariables #-} module Reanimate.LaTeX ( latex + , latexWithHeaders , latexChunks , xelatex + , xelatexWithHeaders + , ctex + , ctexWithHeaders , latexAlign ) where @@ -11,7 +15,7 @@ import qualified Data.ByteString as B import Data.Text ( Text ) import qualified Data.Text as T -import qualified Data.Text.IO as T +import qualified Data.Text.Encoding as T import Graphics.SvgTree ( Tree(..) , parseSvgFile ) @@ -34,14 +38,18 @@ -- -- <> latex :: T.Text -> Tree -latex tex | pNoExternals = mkText tex -latex tex = - (unsafePerformIO . (cacheMem . cacheDiskSvg) (latexToSVG "dvi" exec args)) +latex = latexWithHeaders [] + +latexWithHeaders :: [T.Text] -> T.Text -> Tree +latexWithHeaders = someTexWithHeaders "latex" "dvi" [] + +someTexWithHeaders :: String -> String -> [String] -> [T.Text] -> T.Text -> Tree +someTexWithHeaders _exec _dvi _args _headers tex | pNoExternals = mkText tex +someTexWithHeaders exec dvi args headers tex = + (unsafePerformIO . (cacheMem . cacheDiskSvg) (latexToSVG dvi exec args)) script where - exec = "latex" - args = [] - script = mkTexScript exec args [] tex + script = mkTexScript exec args headers tex latexChunks :: [T.Text] -> [Tree] latexChunks chunks | pNoExternals = map mkText chunks @@ -56,23 +64,27 @@ -- | Invoke xelatex and import the result as an SVG object. SVG objects are -- cached to improve performance. Xelatex has support for non-western scripts. +xelatex :: Text -> Tree +xelatex = xelatexWithHeaders [] + +xelatexWithHeaders :: [T.Text] -> T.Text -> Tree +xelatexWithHeaders = someTexWithHeaders "xelatex" "xdv" ["-no-pdf"] + +-- | Invoke xelatex with "\usepackage[UTF8]{ctex}" and import the result as an +-- SVG object. SVG objects are cached to improve performance. Xelatex has +-- support for non-western scripts. -- -- Example: -- --- > xelatex "中文" +-- > ctex "中文" -- --- <> -xelatex :: Text -> Tree -xelatex tex | pNoExternals = mkText tex -xelatex tex = - (unsafePerformIO . (cacheMem . cacheDiskSvg) (latexToSVG "xdv" exec args)) - script - where - exec = "xelatex" - args = ["-no-pdf"] - headers = ["\\usepackage[UTF8]{ctex}"] - script = mkTexScript exec args headers tex +-- <> +ctex :: T.Text -> Tree +ctex = ctexWithHeaders [] +ctexWithHeaders :: [T.Text] -> T.Text -> Tree +ctexWithHeaders headers = xelatexWithHeaders ("\\usepackage[UTF8]{ctex}" : headers) + -- | Invoke latex and import the result as an SVG object. SVG objects are -- cached to improve performance. This wraps the TeX code in an 'align*' -- context. @@ -97,7 +109,7 @@ withTempFile "svg" $ \svg_file -> do let dvi_file = tmp_dir replaceExtension (takeFileName tex_file) dviExt - T.writeFile tex_file tex + B.writeFile tex_file (T.encodeUtf8 tex) runCmd latexBin ( latexArgs diff --git a/src/Reanimate/Math/Common.hs b/src/Reanimate/Math/Common.hs --- a/src/Reanimate/Math/Common.hs +++ b/src/Reanimate/Math/Common.hs @@ -72,43 +72,48 @@ (V3 c1 c2 1)) epsilon :: Fractional a => a -epsilon = 1e-9 +epsilon = 1e-13 epsEq :: (Ord a, Fractional a) => a -> a -> Bool epsEq a b = abs (a-b) < epsilon +{-# INLINE isLeftTurn #-} -- Left turn. isLeftTurn :: (Fractional a, Ord a) => V2 a -> V2 a -> V2 a -> Bool isLeftTurn p1 p2 p3 = - let d = direction p1 p2 p3 in - case compare d 0 of + case compare (direction p1 p2 p3) 0 of LT -> True EQ -> False -- colnear GT -> False +{-# INLINE isLeftTurnOrLinear #-} isLeftTurnOrLinear :: (Fractional a, Ord a) => V2 a -> V2 a -> V2 a -> Bool isLeftTurnOrLinear p1 p2 p3 = - let d = direction p1 p2 p3 in - case compare d 0 of + case compare (direction p1 p2 p3) 0 of LT -> True EQ -> True -- colnear GT -> False +{-# INLINE isRightTurn #-} isRightTurn :: (Fractional a, Ord a) => V2 a -> V2 a -> V2 a -> Bool isRightTurn a b c = not (isLeftTurnOrLinear a b c) +{-# INLINE isRightTurnOrLinear #-} isRightTurnOrLinear :: (Fractional a, Ord a) => V2 a -> V2 a -> V2 a -> Bool isRightTurnOrLinear a b c = not (isLeftTurn a b c) +{-# INLINE direction #-} direction :: Fractional a => V2 a -> V2 a -> V2 a -> a direction p1 p2 p3 = crossZ (p3-p1) (p2-p1) +{-# INLINE isInside #-} isInside :: (Fractional a, Ord a) => V2 a -> V2 a -> V2 a -> V2 a -> Bool isInside a b c d = s >= 0 && s <= 1 && t >= 0 && t <= 1 where (s, t, _) = barycentricCoords a b c d +{-# INLINE barycentricCoords #-} barycentricCoords :: Fractional a => V2 a -> V2 a -> V2 a -> V2 a -> (a, a, a) barycentricCoords (V2 x1 y1) (V2 x2 y2) (V2 x3 y3) (V2 x y) = (lam1, lam2, lam3) diff --git a/src/Reanimate/Math/Compatible.hs b/src/Reanimate/Math/Compatible.hs --- a/src/Reanimate/Math/Compatible.hs +++ b/src/Reanimate/Math/Compatible.hs @@ -9,140 +9,155 @@ import Linear.Vector import Reanimate.Math.Common import Reanimate.Math.Polygon +import Reanimate.Debug +import Reanimate.Math.Render +import Reanimate.Svg +import Reanimate.Animation -import Debug.Trace +-- import Debug.Trace +truncateP :: V2 Rational -> V2 Rational +truncateP = fmap (realToFrac . (realToFrac :: Rational -> Double)) + mkSteinerPoints :: V2 Rational -> V2 Rational -> Int -> [V2 Rational] -mkSteinerPoints a b s_ = [ lerp (i/(s+1)) b a | i <- [1..s]] - where - s = fromIntegral s_ +mkSteinerPoints a b s_ = [ lerp (i / (s + 1)) b a | i <- [1 .. s] ] + where s = fromIntegral s_ -- 0..i,j..n-1 -- i..j split1Link :: Polygon -> Int -> Int -> Int -> (Polygon, Polygon) split1Link p i j s | j < i = split1Link p j i s split1Link p i j s = - (mkPolygon $ V.fromList left - ,mkPolygon $ V.fromList right) - where - n = pSize p - sp = mkSteinerPoints (pAccess p i) (pAccess p j) s - left = map (pAccess p) [0..i] ++ sp ++ map (pAccess p) [j..n-1] - right = map (pAccess p) [i..j] ++ reverse sp + (mkPolygon $ V.fromList left, mkPolygon $ V.fromList right) + where + n = pSize p + sp = mkSteinerPoints (pAccess p i) (pAccess p j) s + left = map (pAccess p) [0 .. i] ++ sp ++ map (pAccess p) [j .. n - 1] + right = map (pAccess p) [i .. j] ++ reverse sp steiner2Link :: Polygon -> Int -> Int -> V2 Rational steiner2Link p i j | j < i = steiner2Link p j i steiner2Link p i j - | isNeighbour = error "steiner2Link: Points are neighbours" - | isParent = error "steiner2Link: Points can directly see each other." - | not (isStraightLine || isGrandparent || oneBendBetween p i j) = - error $ "steiner2Link: Cannot construct 2-link chain between points: " ++ show (i,j,pParent p i j,pParent p i (pParent p i j)) - | otherwise = - lerp 0.5 (fst vect) (intersects!!0) - where - distToV = approxDist (fst vect) - isNeighbour = i == pNext p j || i == pPrev p j - isParent = pParent p i j == i - isGrandparent = pParent p i (pParent p i j) == i - isStraightLine = - direction - (pAccess p j) - (pAccess p $ pParent p i j) - (pAccess p i) == 0 - intersects = sortOn distToV $ - snd vect : - [ u - | n <- [0..pSize p-1] - , let edge = (pAccess p n, pAccess p $ pNext p n) - , u <- case rayIntersect vect edge of - Nothing -> [] - Just u -> [u] - , isBetween u edge - , u /= fst vect - , isForward vect u - ] - iP = pAdjustOffset p i - jP = pAdjustOffset p j - vect - | isStraightLine = - let p1 = lerp 0.5 (pAccess p i) (pAccess p j) - p2 = - case p1-pAccess p i of - V2 x y -> p1 + V2 (-y) x -- rotate 90 degrees. - in (p1,p2) - | otherwise = fromMaybe (error $ "No window overlap: " ++ show (isStraightLine, isGrandparent, oneBendBetween p i j)) $ listToMaybe $ - [ (p1, p1+(p2-p1) + (p3-p1)) - | (a,b) <- ssspWindows iP - , (c,d) <- ssspWindows jP - , (p1,p2,p3) <- - if | a == c -> pure (a, b, d) - | a == d -> pure (a, b, c) - | b == c -> pure (b, a, d) - | b == d -> pure (b, a, c) - | otherwise -> [] + | isNeighbour + = error "steiner2Link: Points are neighbours" + | isParent + = error "steiner2Link: Points can directly see each other." + | not (isStraightLine || isGrandparent || oneBendBetween p i j) + = error + $ "steiner2Link: Cannot construct 2-link chain between points: " + ++ show (i, j, pParent p i j, pParent p i (pParent p i j)) + | otherwise + = truncateP $ lerp 0.5 (fst vect) (intersects !! 0) + where + distToV = approxDist (fst vect) + isNeighbour = i == pNext p j || i == pPrev p j + isParent = pParent p i j == i + isGrandparent = pParent p i (pParent p i j) == i + isStraightLine = + direction (pAccess p j) (pAccess p $ pParent p i j) (pAccess p i) == 0 + intersects = + sortOn distToV + $ snd vect + : [ u + | n <- [0 .. pSize p - 1] + , let edge = (pAccess p n, pAccess p $ pNext p n) + , u <- case rayIntersect vect edge of + Nothing -> [] + Just u -> [u] + , isBetween u edge + , u /= fst vect + , isForward vect u ] - isForward (a,b) v = - not (isBetween a (b,v)) + iP = pAdjustOffset p i + jP = pAdjustOffset p j + vect + | isStraightLine + = let p1 = lerp 0.5 (pAccess p i) (pAccess p j) + p2 = case p1 - pAccess p i of + V2 x y -> p1 + V2 (-y) x -- rotate 90 degrees. + in (p1, p2) + | otherwise + = fromMaybe + (error $ "No window overlap: " ++ show + (isStraightLine, isGrandparent, oneBendBetween p i j) + ) + $ listToMaybe + $ [ (p1, p1 + (p2 - p1) + (p3 - p1)) + | (a, b) <- ssspWindows iP + , (c, d) <- ssspWindows jP + , (p1, p2, p3) <- if + | a == c -> pure (a, b, d) + | a == d -> pure (a, b, c) + | b == c -> pure (b, a, d) + | b == d -> pure (b, a, c) + | otherwise -> [] + ] + isForward (a, b) v = not (isBetween a (b, v)) -- 0..i,s,j..n-1 -- i..j,s split2Link :: Polygon -> Int -> Int -> (Polygon, Polygon) split2Link p i j | j < i = split2Link p j i -split2Link p i j = - (mkPolygon $ V.fromList left - ,mkPolygon $ V.fromList right) - where - s = steiner2Link p i j - n = pSize p - left = map (pAccess p) [0..i] ++ [s] ++ map (pAccess p) [j..n-1] - right = map (pAccess p) [i..j] ++ [s] +split2Link p i j = (mkPolygon $ V.fromList left, mkPolygon $ V.fromList right) + where + s = steiner2Link p i j + n = pSize p + left = map (pAccess p) [0 .. i] ++ [s] ++ map (pAccess p) [j .. n - 1] + right = map (pAccess p) [i .. j] ++ [s] data Link = OneLink | TwoLink -splitNLink :: Polygon -> Int -> [(Link,Int)] -> (Polygon, Polygon) -splitNLink p i js = - (mkPolygon $ V.fromList left - ,mkPolygon $ V.fromList right) - where - n = pSize p - left = map (pAccess p) [0..i] ++ steiners ++ map (pAccess p) [j..n-1] - right = map (pAccess p) [i..j] ++ reverse steiners - j = snd (last js) - steiners = splitNLinks p i js +splitNLink :: Polygon -> Int -> [(Link, Int)] -> (Polygon, Polygon) +splitNLink p i js = (mkPolygon $ V.fromList left, mkPolygon $ V.fromList right) + where + n = pSize p + left = map (pAccess p) [0 .. i] ++ steiners ++ map (pAccess p) [j .. n - 1] + right = map (pAccess p) [i .. j] ++ reverse steiners + j = snd (last js) + steiners = splitNLinks p i js -- 0, [(TwoLink,2),(OneLink,3)] -- 0, [(OneLink,5),(TwoLink,3)] -splitNLinks :: Polygon -> Int -> [(Link,Int)] -> [V2 Rational] -splitNLinks _p _i [] = [] -splitNLinks p i [(TwoLink,j)] = [steiner2Link p i j] -splitNLinks _p _i [(OneLink,_j)] = [] -splitNLinks p i ((TwoLink,j):(OneLink,j'):xs) = - let (l,r) = split2Link p i j - p' = selectContains l r (pAccess p j') - s = steiner2Link p i j - sIdx = fromMaybe (error "missing steiner") $ V.elemIndex s (polygonPoints p') - in s : splitNLinks p' sIdx ((TwoLink,j') : xs) -splitNLinks p i ((TwoLink,j):(TwoLink,j'):xs) = - let (l,r) = split2Link p i j - p' = selectContains l r (pAccess p j') - s = steiner2Link p i j - sIdx = fromMaybe (error "missing steiner") $ V.elemIndex s (polygonPoints p') - in s : splitNLinks p' sIdx ((OneLink,j):(TwoLink,j') : xs) -splitNLinks p i ((OneLink,j):(TwoLink,j'):xs) = - let (l,r) = split2Link p j j' - p' = selectContains l r (pAccess p i) - p'' = selectContains l r (pAccess p j') - s = steiner2Link p j j' - s' = steiner2Link p' i sIdx - sIdx = fromMaybe (error "missing steiner sIdx") $ V.elemIndex s (polygonPoints p') - sIdx' = fromMaybe (error "missing steiner sIdx'") $ V.elemIndex s' (polygonPoints p'') - in s' : s : splitNLinks p'' sIdx' ((OneLink,j') : xs) +splitNLinks :: Polygon -> Int -> [(Link, Int)] -> [V2 Rational] +splitNLinks _p _i [] = [] +splitNLinks p i [(TwoLink, j )] = [steiner2Link p i j] +splitNLinks _p _i [(OneLink, _j)] = [] +splitNLinks p i ((TwoLink, j) : (OneLink, j') : xs) = + let + (l, r) = split2Link p i j + p' = selectContains l r (pAccess p j') + s = steiner2Link p i j + sIdx = + fromMaybe (error "missing steiner") $ V.elemIndex s (polygonPoints p') + in + s : splitNLinks p' sIdx ((TwoLink, j') : xs) +splitNLinks p i ((TwoLink, j) : (TwoLink, j') : xs) = + let + (l, r) = split2Link p i j + p' = selectContains l r (pAccess p j') + s = steiner2Link p i j + sIdx = + fromMaybe (error "missing steiner") $ V.elemIndex s (polygonPoints p') + in + s : splitNLinks p' sIdx ((OneLink, j) : (TwoLink, j') : xs) +splitNLinks p i ((OneLink, j) : (TwoLink, j') : xs) = + let + (l, r) = split2Link p j j' + p' = selectContains l r (pAccess p i) + p'' = selectContains l r (pAccess p j') + s = steiner2Link p j j' + s' = steiner2Link p' i sIdx + sIdx = fromMaybe (error "missing steiner sIdx") + $ V.elemIndex s (polygonPoints p') + sIdx' = fromMaybe (error "missing steiner sIdx'") + $ V.elemIndex s' (polygonPoints p'') + in + s' : s : splitNLinks p'' sIdx' ((OneLink, j') : xs) splitNLinks _p _i _ = error "splitNLinks: invalid input" selectContains :: Polygon -> Polygon -> V2 Rational -> Polygon -selectContains p1 p2 elt - | V.elem elt (polygonPoints p1) = p1 - | V.elem elt (polygonPoints p2) = p2 - | otherwise = error "elt not member of either polygons" +selectContains p1 p2 elt | V.elem elt (polygonPoints p1) = p1 + | V.elem elt (polygonPoints p2) = p2 + | otherwise = error "elt not member of either polygons" -- [(P, Vis)] -> Polygon -> [P] {- If there is a 1-link path, connect it. @@ -206,46 +221,71 @@ compatiblyTriangulateP :: Polygon -> Polygon -> [(Polygon, Polygon)] compatiblyTriangulateP a b | pSize a /= pSize b = error "polygon size mismatch" - | otherwise = compatiblyTriangulateP' (pSetOffset a 0) (pSetOffset a 0) (pSetOffset b 0) + | otherwise = traceSVG (showStep a b) $ compatiblyTriangulateP' + (pSetOffset a 0) + (pSetOffset a 0) + (pSetOffset b 0) +showStep :: Polygon -> Polygon -> SVG +showStep a b = mkGroup + [ translate (-3) 0 + $ mkGroup [withFillColor "grey" $ polygonShape a, polygonNumDots a] + , translate 3 0 + $ mkGroup [withFillColor "grey" $ polygonShape b, polygonNumDots b] + ] + compatiblyTriangulateP' :: Polygon -> Polygon -> Polygon -> [(Polygon, Polygon)] compatiblyTriangulateP' aOrigin a b - | trace ("Polygon size: " ++ show (pSize a)) False = undefined - | n == 3 = trace ("Done") $ - [(a,b)] + | n == 3 = traceSVG (showStep a b) $ {- trace ("Done") $ -} [(a, b)] | otherwise = - case bestOneLink of - Nothing -> - case bestTwoLink of - Nothing -> error $ "no 2-links" - Just (nodeL, nodeR) -> trace (show ("two link"::String, toOriginIndex nodeL, toOriginIndex nodeR)) $ - let (aL, aR) = - if (nodeL, nodeR) `elem` aOneLink - then split1Link a nodeL nodeR 1 - else split2Link a nodeL nodeR - (bL, bR) = - if (nodeL, nodeR) `elem` bOneLink - then split1Link b nodeL nodeR 1 - else split2Link b nodeL nodeR - in compatiblyTriangulateP' aOrigin aL bL ++ compatiblyTriangulateP' aOrigin aR bR - Just (nodeL,nodeR) -> trace (show ("one link"::String, toOriginIndex nodeL, toOriginIndex nodeR)) $ - let (aL, aR) = split1Link a nodeL nodeR 0 - (bL, bR) = split1Link b nodeL nodeR 0 - in compatiblyTriangulateP' aOrigin aL bL ++ compatiblyTriangulateP' aOrigin aR bR - where - toOriginIndex idx = - (idx,fromMaybe (-1) (V.elemIndex (pAccess a idx) (polygonPoints aOrigin)) + - polygonOffset aOrigin) - n = pSize a - bestOneLink = listToMaybe (sortOn (Down . nodeDist) - (aOneLink `intersect` bOneLink)) - bestTwoLink = listToMaybe (sortOn (Down . nodeDist) - ((aOneLink++aTwoLink) `intersect` (bOneLink++bTwoLink))) - aOneLink = polygonOneLinks a - bOneLink = polygonOneLinks b - aTwoLink = polygonTwoLinks a - bTwoLink = polygonTwoLinks b - nodeDist (i,j) = min (j-i) (n-j+i) + -- trace ("aOneLink: " ++ show aOneLink) $ + -- trace ("bOneLink: " ++ show bOneLink) $ + -- trace ("aTwoLink: " ++ show aTwoLink) $ + -- trace ("bTwoLink: " ++ show bTwoLink) $ + traceSVG (showStep a b) $ case bestOneLink of + Nothing -> case bestTwoLink of + Nothing -> error $ "no 2-links" + Just (nodeL, nodeR) -> + {-trace + (show + ("two link" :: String, toOriginIndex nodeL, toOriginIndex nodeR) + ) + $ -} + let (aL, aR) = if (nodeL, nodeR) `elem` aOneLink + then split1Link a nodeL nodeR 1 + else split2Link a nodeL nodeR + (bL, bR) = if (nodeL, nodeR) `elem` bOneLink + then split1Link b nodeL nodeR 1 + else split2Link b nodeL nodeR + in compatiblyTriangulateP' aOrigin aL bL + ++ compatiblyTriangulateP' aOrigin aR bR + Just (nodeL, nodeR) -> + {-trace + (show ("one link" :: String, toOriginIndex nodeL, toOriginIndex nodeR) + ) + $ -} + let (aL, aR) = split1Link a nodeL nodeR 0 + (bL, bR) = split1Link b nodeL nodeR 0 + in compatiblyTriangulateP' aOrigin aL bL + ++ compatiblyTriangulateP' aOrigin aR bR + where + -- toOriginIndex idx = + -- ( idx + -- , fromMaybe (-1) (V.elemIndex (pAccess a idx) (polygonPoints aOrigin)) + -- + polygonOffset aOrigin + -- ) + n = pSize a + bestOneLink = + listToMaybe (sortOn (Down . nodeDist) (aOneLink `intersect` bOneLink)) + bestTwoLink = listToMaybe + (sortOn (Down . nodeDist) + ((aOneLink ++ aTwoLink) `intersect` (bOneLink ++ bTwoLink)) + ) + aOneLink = polygonOneLinks a + bOneLink = polygonOneLinks b + aTwoLink = polygonTwoLinks a + bTwoLink = polygonTwoLinks b + nodeDist (i, j) = min (j - i) (n - j + i) oneBendBetween :: Polygon -> Int -> Int -> Bool oneBendBetween _p _a _b = False @@ -260,25 +300,26 @@ -- case pParent p a n of -- i -> if i == a then n else obstructedBy i -polygonTwoLinks :: Polygon -> [(Int,Int)] +polygonTwoLinks :: Polygon -> [(Int, Int)] polygonTwoLinks p = [ (i, j) - | i <- [0 .. n-1] - , j <- [i+2 .. n-1] - , not (i==0 && j == n-1) + | i <- [0 .. n - 1] + , j <- [i + 2 .. n - 1] + , not (i == 0 && j == n - 1) , pParent p i j /= i -- check for 1-link - , let isTwoLink = pParent p i (pParent p i j) == i + , let isTwoLink = pParent p i (pParent p i j) == i isStraightLine = oneBendBetween p i j - -- Points on a straight line should be 2-link even though they are not - -- direct grandparents. +-- Points on a straight line should be 2-link even though they are not +-- direct grandparents. , isTwoLink || isStraightLine - ] where n = pSize p + ] + where n = pSize p -polygonOneLinks :: Polygon -> [(Int,Int)] +polygonOneLinks :: Polygon -> [(Int, Int)] polygonOneLinks p = [ (i, j) - | i <- [0 .. pSize p-1] - , j <- [i+2 .. pSize p-1] - , not (i==0 && j == pSize p-1) + | i <- [0 .. pSize p - 1] + , j <- [i + 2 .. pSize p - 1] + , not (i == 0 && j == pSize p - 1) , pParent p i j == i ] diff --git a/src/Reanimate/Math/DCEL.hs b/src/Reanimate/Math/DCEL.hs --- a/src/Reanimate/Math/DCEL.hs +++ b/src/Reanimate/Math/DCEL.hs @@ -1,136 +1,891 @@ {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +-- Code originally from: https://github.com/wereHamster/haskell-half-edge-mesh module Reanimate.Math.DCEL where -{- -import Control.Applicative -import Data.List.Split -import Data.Vector (Vector) -import qualified Data.Vector as V -import Linear.Matrix + +import Codec.Picture.Types +import Control.Lens +import Control.Monad.State +import Control.Monad.Writer +import Data.List +import qualified Data.List as L +import Data.Map (Map) +import qualified Data.Map as M +import Data.Maybe +import qualified Data.Set as S +import qualified Data.Text as T +import qualified Data.Vector as V +-- import Debug.Trace +import Linear.Metric import Linear.V2 -import Linear.V3 +import Linear.Vector (lerp, (^/)) +import Reanimate +import Reanimate.Math.Common (isInside, lineIntersect, triangleAngles) +import Reanimate.Math.Polygon +import qualified Reanimate.Morph.Rigid as Rigid import Text.Printf -import Reanimate.Math.Common +type VertexId = Int +type EdgeId = Int +type FaceId = Int -type EdgeIdx = Int -type VertexIdx = Int -type FaceIdx = Int +-- Invariants: +-- No duplicate positions +-- All edges have an opposite twin +-- Edge prev/next keep the same direction (CW or CCW) +-- twin (twin edge) = edge +-- All next/prev links have the same face +data Mesh a = Mesh + { _meshIdCounter :: Int + , _meshOuterFace :: FaceId + , _meshVertices :: Map VertexId (Vertex a) + , _meshEdges :: Map EdgeId Edge + , _meshFaces :: Map FaceId Face + } deriving (Show) -data DCEL = DCEL - { dcelFaces :: Vector EdgeIdx - , dcelVertices :: Vector EdgeIdx - , dcelEdges :: Vector Edge - , dcelPoints :: Vector P - } deriving (Show) +data Vertex a = Vertex + { _vertexId :: VertexId + , _vertexPosition :: a + -- , _vertexEdge :: EdgeId -- Index to CCW edge pointing to this vertex. + } deriving (Show) data Edge = Edge - { edgeVertex :: VertexIdx - , edgeFace :: FaceIdx - , edgeTwin :: EdgeIdx - , edgeNext :: EdgeIdx - , edgePrev :: EdgeIdx - } deriving (Show) + { _edgeId :: EdgeId + , _edgeVertex :: VertexId + , _edgeTwin :: EdgeId + , _edgeNext :: EdgeId + , _edgePrev :: EdgeId + , _edgeFace :: FaceId + } deriving (Show) -getPoint :: Int -> DCEL -> P -getPoint i DCEL{..} = dcelPoints V.! (i `mod` V.length dcelPoints) +data Face = Face + { _faceId :: FaceId + , _faceEdge :: EdgeId + } deriving (Show) -dcelSize :: DCEL -> Int -dcelSize DCEL{..} = V.length dcelPoints +type MeshM position a = State (Mesh position) a +validMesh :: Mesh a -> [String] +validMesh Mesh{..} = execWriter $ do + return () +makeLenses ''Mesh +makeLenses ''Vertex +makeLenses ''Edge +makeLenses ''Face -isValidDCEL :: DCEL -> Maybe String -isValidDCEL DCEL{..} = foldr (<|>) empty $ - [ V.all (< V.length dcelEdges) dcelFaces ~> "Bad face" - , V.all (< V.length dcelEdges) dcelVertices ~> "Bad vertice" - , V.all (< V.length dcelEdges) (V.map edgeNext dcelEdges) ~> "Bad next" - , V.all (< V.length dcelEdges) (V.map edgePrev dcelEdges) ~> "Bad prev" - , V.all (< V.length dcelEdges) (V.map edgeTwin dcelEdges) ~> "Bad twin" - , V.all (< V.length dcelPoints) (V.map edgeVertex dcelEdges) ~> "Bad edge vertex" - , V.all (< V.length dcelFaces) (V.map edgeFace dcelEdges) ~> "Bad edge face" - , V.length dcelVertices == V.length dcelPoints ~> "Vertex/Point mismatch" +meshGetEdge :: EdgeId -> Mesh a -> Edge +meshGetEdge eid Mesh{..} = M.findWithDefault err eid _meshEdges + where + err = error $ "Edge not found: " ++ show eid + +meshGetVertex :: VertexId -> Mesh a -> Vertex a +meshGetVertex vid Mesh{..} = M.findWithDefault err vid _meshVertices + where + err = error $ "Vertex not found: " ++ show vid + +meshGetFace :: FaceId -> Mesh a -> Face +meshGetFace fid Mesh{..} = M.findWithDefault err fid _meshFaces + where + err = error $ "Face not found: " ++ show fid + +meshAngles :: Mesh (V2 Double) -> [Double] +meshAngles mesh@Mesh{..} = + [ faceMinAngle fid mesh + | fid <- M.keys _meshFaces ] + +meshEdgeAngle :: Mesh (V2 Double) -> EdgeId -> Double +meshEdgeAngle m eId = + ang where - infix 0 ~> - True ~> _ = Nothing - False ~> msg = Just msg + edge = meshGetEdge eId m + next = meshGetEdge (edge ^. edgeNext) m + prev = meshGetEdge (edge ^. edgePrev) m + v1 = meshGetVertex (prev ^. edgeVertex) m ^. vertexPosition + v2 = meshGetVertex (edge ^. edgeVertex) m ^. vertexPosition + v3 = meshGetVertex (next ^. edgeVertex) m ^. vertexPosition + (_, ang, _) = triangleAngles v1 v2 v3 -ppDCEL :: DCEL -> String -ppDCEL DCEL{..} = - unlines - [ "Faces: Edge" - , unlines - [ printf "%3d: %3d" face edge - | (face, edge) <- zip [0::Int .. ] (V.toList dcelFaces) - ] - , "Vertices: Edge" +facePositions :: FaceId -> Mesh a -> [a] +facePositions fid m = + [ meshGetVertex (edge^.edgeVertex) m ^. vertexPosition + | eid <- faceEdges fid m + , let edge = meshGetEdge eid m + ] + +faceEdges :: FaceId -> Mesh a -> [EdgeId] +faceEdges fid m = worker (meshGetEdge lastEdge m ^.edgeNext) + where + face = meshGetFace fid m + lastEdge = face^.faceEdge + worker eid + | eid == lastEdge = [eid] + | otherwise = eid : worker (meshGetEdge eid m ^. edgeNext) + +faceMinAngle :: FaceId -> Mesh (V2 Double) -> Double +faceMinAngle fid m = minimum (map (meshEdgeAngle m) (faceEdges fid m)) + +ppMesh :: Show a => Mesh a -> String +ppMesh Mesh{..} = unlines + [ printf "Outer face: %d" _meshOuterFace + , "" + , "Vertices:" + , printf "%4s %5s %10s" ("ID"::String) ("Edge"::String) ("Position"::String) , unlines - [ printf "%3d: %3d" vertex edge - | (vertex, edge) <- zip [0::Int ..] (V.toList dcelVertices) + [ printf "%4d %10s" _vertexId (show _vertexPosition) + | Vertex{..} <- M.elems _meshVertices ] - , "Edges: Vertex Face Twin Next Prev" + , "Edges:" + , printf "%4s %3s %4s %4s %4s %4s" + ("ID"::String) ("Vtx"::String) ("Twin"::String) ("Next"::String) + ("Prev"::String) ("Face"::String) , unlines - [ printf "%3d: %3d %3d %3d %3d %3d" - edge edgeVertex edgeFace edgeTwin edgeNext edgePrev - | (edge, Edge{..}) <- zip [0::Int ..] (V.toList dcelEdges) + [ printf "%4d %3d %4d %4d %4d %4d" _edgeId _edgeVertex _edgeTwin _edgeNext _edgePrev _edgeFace + | Edge{..} <- M.elems _meshEdges ] - , "Points:" + , "Faces:" , unlines - [ printf "%3d: " (idx*chunkSize) ++ - unwords [ printf "<%.1f,%.1f>" x y | V2 x y <- chunk ] - | (idx, chunk) <- zip [0::Int ..] (chunksOf chunkSize (V.toList dcelPoints)) + [ printf "%4d %4d" _faceId _faceEdge + | Face{..} <- M.elems _meshFaces ] ] - where chunkSize = 5 -emptyDCEL :: DCEL -emptyDCEL = undefined +emptyMesh :: Mesh a +emptyMesh = Mesh 1 0 M.empty M.empty M.empty +-- addFace :: FaceId -> [a] -> MeshM a () +-- addFace parentFace subPoly = do +-- innerFace <- createFace +-- vIds <- mapM getVertex pts +-- edges <- forM (zip vIds (tail vIds ++ take 1 vIds)) $ \(v0, v1) -> do +-- e <- do +-- mbEdge <- findEdge' v0 v1 +-- case mbEdge of +-- Just e -> pure (e ^. edgeId) +-- Nothing -> do +-- e <- createEdge v1 +-- twin <- createEdge v0 +-- setTwinEdge e twin +-- setFace twin parentFace +-- return e +-- setFace e innerFace +-- modifyVertex (vertexEdge .~ e) v0 +-- pure e + +-- setFaceEdge innerFace (head edges) +-- forM_ (zip edges (tail edges ++ take 1 edges)) $ \(e0, e1) -> +-- linkEdges e0 e1 + +polygonsMesh :: Eq a => [a] -> [[a]] -> MeshM a () +polygonsMesh outer trigs = do + polygonMeshOuter (reverse outer) + modify $ meshFaces .~ M.empty + forM_ trigs $ \pts -> do + innerFace <- createFace + vIds <- mapM getVertex pts + edges <- forM (zip vIds (tail vIds ++ take 1 vIds)) $ \(_v0, v1) -> do + e <- createEdge v1 + setFace e innerFace + -- modifyVertex (vertexEdge .~ e) v0 + pure e + + setFaceEdge innerFace (head edges) + forM_ (zip edges (tail edges ++ take 1 edges)) $ \(e0, e1) -> + linkEdges e0 e1 + forM edges $ \e -> do + edge <- getEdge e + prev <- getEdge (edge ^. edgePrev) + mbTwin <- findEdge' (edge ^. edgeVertex) (prev ^. edgeVertex) + case mbTwin of + Nothing -> return () + Just twin -> + setTwinEdge e (twin^.edgeId) + +-- Positions must be in CW order +polygonMesh :: [a] -> MeshM a () +polygonMesh vs = do + outerFace <- gets _meshOuterFace + innerFace <- createFace + vIds <- mapM createVertex vs + edges <- forM (zip vIds (tail vIds ++ take 1 vIds)) $ \(v0, v1) -> do + e <- createEdge v1 -- Edge from v0 to v1 + e' <- createEdge v0 -- Twin edge from v1 to v0 + setFace e innerFace + setFace e' outerFace + -- modifyVertex (vertexEdge .~ e) v0 + setTwinEdge e e' + pure e + + outerEdge <- _edgeTwin <$> getEdge (head edges) + setFaceEdge innerFace (head edges) + setFaceEdge outerFace outerEdge + + forM_ (zip edges (tail edges ++ take 1 edges)) $ \(e0, e1) -> do + linkEdges e0 e1 + e0' <- _edgeTwin <$> getEdge e0 + e1' <- _edgeTwin <$> getEdge e1 + linkEdges e1' e0' + +polygonMeshOuter :: [a] -> MeshM a () +polygonMeshOuter vs = do + outerFace <- gets _meshOuterFace + vIds <- mapM createVertex vs + edges <- forM vIds $ \v0 -> do + e' <- createEdge v0 + setFace e' outerFace + pure e' + + setFaceEdge outerFace (head edges) + + let f = Face outerFace (head edges) + modify $ meshFaces %~ M.insert outerFace f + + forM_ (zip edges (tail edges ++ take 1 edges)) $ \(e0, e1) -> do + linkEdges e0 e1 + + +newId :: MeshM a Int +newId = do + counter <- gets _meshIdCounter + modify $ meshIdCounter %~ succ + return counter + +createVertex :: a -> State (Mesh a) VertexId +createVertex position = do + k <- newId + let v = Vertex k position -- (error "_vertexEdge not set") + modify $ meshVertices %~ M.insert k v + return k + +getVertex :: Eq a => a -> State (Mesh a) VertexId +getVertex position = do + vs <- gets _meshVertices + case L.find comparingPosition (M.assocs vs) of + Nothing -> createVertex position + Just (k, _) -> return k + where comparingPosition (_k, v) = (_vertexPosition v) == position + +requireVertex :: VertexId -> MeshM a (Vertex a) +requireVertex vid = do + ret <- gets (M.lookup vid . _meshVertices) + case ret of + Nothing -> error "Invalid vertex id" + Just v -> pure v + +modifyVertex :: (Vertex a -> Vertex a) -> VertexId -> State (Mesh a) () +modifyVertex f k = modify $ meshVertices %~ M.adjust f k + +getEdge :: EdgeId -> State (Mesh a) Edge +getEdge e = do + edges <- gets _meshEdges + maybe (bug edges) return $ M.lookup e edges + --return $ fromJust $ M.lookup e edges + where bug _edges = error $ "Can't find edge with id " ++ (show e) + +withEdge :: EdgeId -> (Edge -> State (Mesh a) ()) -> State (Mesh a) () +withEdge e f = f =<< getEdge e + +-- findEdge :: VertexId -> VertexId -> State (Mesh a) EdgeId +-- findEdge v0 v1 = do +-- edges <- gets _meshEdges +-- case L.find comparingVertices (M.assocs edges) of +-- Nothing -> error $ "No edge between: " ++ show (v0, v1) +-- Just (k, _) -> return k +-- where comparingVertices (k, e) = (k, _edgeNext e) == (v0, v1) + +createEdge :: VertexId -> State (Mesh a) EdgeId +createEdge v = do + k <- newId + let e = Edge k + v + (error $ "_edgeTwin not set " ++ show (k,v)) + (error $ "_edgeNext not set " ++ show (k,v)) + (error $ "_edgePrev not set " ++ show (k,v)) + (error $ "_edgeFace not set " ++ show (k,v)) + modify $ meshEdges %~ M.insert k e + return k + +modifyEdge :: (Edge -> Edge) -> EdgeId -> State (Mesh a) () +modifyEdge f k = modify $ meshEdges %~ M.adjust f k + +linkEdges :: EdgeId -> EdgeId -> State (Mesh a) () +linkEdges e0 e1 = do + setNextEdge e0 e1 + setPreviousEdge e1 e0 + +setNextEdge :: EdgeId -> EdgeId -> State (Mesh a) () +setNextEdge e0 e1 = modifyEdge (edgeNext .~ e1) e0 + +setPreviousEdge :: EdgeId -> EdgeId -> State (Mesh a) () +setPreviousEdge e0 e1 = modifyEdge (edgePrev .~ e1) e0 + +setTwinEdge :: EdgeId -> EdgeId -> MeshM a () +setTwinEdge e0 e1 = do + modifyEdge (edgeTwin .~ e1) e0 + modifyEdge (edgeTwin .~ e0) e1 + +setFace :: EdgeId -> FaceId -> State (Mesh a) () +setFace e0 f0 = modifyEdge (edgeFace .~ f0) e0 + +updateFaces :: EdgeId -> FaceId -> State (Mesh a) () +updateFaces e0 f0 = do + e <- getEdge e0 + setFace e0 f0 + worker (e ^. edgeNext) + where + worker e1 + | e0 == e1 = return () + | otherwise = do + e <- getEdge e1 + setFace e1 f0 + worker (e ^. edgeNext) + +createFace :: State (Mesh a) FaceId +createFace = do + k <- newId + let f = Face k (error "_faceEdge not set") + modify $ meshFaces %~ M.insert k f + return k + +modifyFace :: (Face -> Face) -> FaceId -> State (Mesh a) () +modifyFace f k = modify $ meshFaces %~ M.adjust f k + +setFaceEdge :: FaceId -> EdgeId -> MeshM a () +setFaceEdge f0 e0 = modifyFace (\f -> f { _faceEdge = e0 }) f0 + +deleteFace :: FaceId -> MeshM a () +deleteFace f0 = modify $ meshFaces %~ M.delete f0 + +getFace :: FaceId -> State (Mesh a) Face +getFace f = do + faces <- gets _meshFaces + maybe bug return (M.lookup f faces) + where bug = error $ "Can't find face with id " ++ (show f) + + +buildMesh :: State (Mesh a) b -> Mesh a +buildMesh f = execState f emptyMesh + +numVertices :: Mesh a -> Int +numVertices = M.size . _meshVertices + +numEdges :: Mesh a -> Int +numEdges = M.size . _meshEdges + +numFaces :: Mesh a -> Int +numFaces = M.size . _meshFaces + +vertices :: Mesh a -> [Vertex a] +vertices = M.elems . _meshVertices + +outgoingEdges :: VertexId -> Mesh a -> [Edge] +outgoingEdges v mesh = + [ meshGetEdge (edge ^. edgeTwin) mesh + | edge <- M.elems (_meshEdges mesh) + , _edgeVertex edge == v + ] + + +-- for each inner node: +-- get all neighbour nodes. sort by CCW +-- compute laplacian +-- compute angle-based +-- check correctness +-- move vertex + +-- p e +-- _ -> u -> v +-- p' e' +-- _ <- u <- v +-- +-- p e1 e +-- _ -> u -> t -> v +-- p' e1' e' +-- _ <- u <- t <- v +-- +-- faces stay the same +splitEdge :: VertexId -> EdgeId -> MeshM a EdgeId +splitEdge t e = do + eEdge <- getEdge e + eEdgeTwin <- getEdge (eEdge ^. edgeTwin) + + e1 <- createEdge t + setFace e1 (eEdge ^. edgeFace) + -- modifyVertex (vertexEdge .~ e1) t + + e1' <- createEdge (eEdgeTwin ^. edgeVertex) + setFace e1' (eEdgeTwin ^. edgeFace) + setTwinEdge e1 e1' + + let oldPrev = eEdge ^. edgePrev + oldNext = eEdgeTwin ^. edgeNext + + linkEdges oldPrev e1 + linkEdges (eEdge ^. edgeTwin) e1' + linkEdges e1 e + linkEdges e1' oldNext + + modifyEdge (edgeVertex .~ t) (eEdge ^. edgeTwin) + + return e1 + +splitTriangle :: V2 Double -> EdgeId -> MeshM (V2 Double) (FaceId, FaceId, FaceId, FaceId) +splitTriangle vertex e = do + -- outer <- gets _meshOuterFace + edge <- getEdge e + next <- getEdge (edge^.edgeNext) + twin <- getEdge (edge^.edgeTwin) + next' <- getEdge (twin^.edgeNext) + + t <- createVertex vertex + _ <- splitEdge t e + + smoothVertex t + + (f1,f2) <- insertEdge (edge^.edgeFace) t (next^.edgeVertex) + (f3,f4) <- insertEdge (twin^.edgeFace) t (next'^.edgeVertex) + return (f1,f2,f3,f4) + +splitOuterTriangle :: V2 Double -> EdgeId -> MeshM (V2 Double) (FaceId, FaceId) +splitOuterTriangle vertex e = do + -- outer <- gets _meshOuterFace + edge <- getEdge e + twin <- getEdge (edge^.edgeTwin) + next' <- getEdge (twin^.edgeNext) + + t <- createVertex vertex + _ <- splitEdge t e + + (f1,f2) <- insertEdge (twin^.edgeFace) t (next'^.edgeVertex) + return (f1,f2) + -- return (outer, outer) + +findEdge :: FaceId -> VertexId -> MeshM a Edge +findEdge f v = do + edges <- gets (M.elems . _meshEdges) + case + listToMaybe [ e | e <- edges, e ^. edgeFace == f, e ^. edgeVertex == v ] + of + Nothing -> error $ "Edge not found: " ++ show (f, v) + Just e -> pure e + +findEdge' :: VertexId -> VertexId -> MeshM a (Maybe Edge) +findEdge' v0 v1 = do + m <- get + pure $ listToMaybe + [ e + | e <- M.elems (m^.meshEdges) + , e ^. edgeVertex == v1 + , let prev = meshGetEdge (e ^. edgePrev) m + , prev ^. edgeVertex == v0 + ] + +findEdge'' :: [FaceId] -> VertexId -> MeshM a (Maybe Edge) +findEdge'' fs v = do + edges <- gets (M.elems . _meshEdges) + pure $ + listToMaybe [ e | e <- edges, e ^. edgeFace `notElem` fs, e ^. edgeVertex == v ] + {- -faces: [0,1] -- 0 is outside, 1 is inside. -vertices: [0..n-1] -edges: - i: vertex=i - face=1 - twin=i+n - next=(i+1)%n - prev=(i-1)%n - i: j=i-n - vertex=edge[j].prev.vertex - face=0 - twin=j - next=(j-1)%n + i - prev=(j+1)%n +i -points: pts + -} -fromSimplePolygon :: [V2 Double] -> DCEL -fromSimplePolygon [] = error "empty polygon" -fromSimplePolygon pts | not (isCCW $ V.fromList pts) = error "Polygon not counter-clockwise" -fromSimplePolygon pts = DCEL - { dcelFaces = V.fromList [0,1] - , dcelVertices = V.fromList [0..n-1] - , dcelEdges = V.fromList $ - [ Edge - { edgeVertex = i - , edgeFace = 1 - , edgeTwin = i+n - , edgeNext = (i+1) `mod` n - , edgePrev = (i-1) `mod` n } - | i <- [0..n-1] ] ++ - [ Edge - { edgeVertex = (i-1) `mod` n - , edgeFace = 0 - , edgeTwin = i - , edgeNext = (i-1) `mod` n + i - , edgePrev = (i-1) `mod` n + i } - | i <- [0..n-1] ] - , dcelPoints = V.fromList pts - } +deleteEdge :: EdgeId -> MeshM a () +deleteEdge e0 = do + e <- getEdge e0 + e' <- getEdge (e^.edgeTwin) + linkEdges (e^.edgePrev) (e'^.edgeNext) + linkEdges (e'^.edgePrev) (e^.edgeNext) + updateFaces (e^.edgeNext) (e^.edgeFace) + setFaceEdge (e^.edgeFace) (e^.edgeNext) + deleteFace (e'^.edgeFace) + modify $ meshEdges %~ M.delete (e^.edgeId) + modify $ meshEdges %~ M.delete (e'^.edgeId) + +insertEdge :: FaceId -> VertexId -> VertexId -> MeshM a (FaceId, FaceId) +insertEdge f0 v0 v1 = do + hv0 <- findEdge f0 v0 + hv1 <- findEdge f0 v1 + f1 <- createFace + f2 <- createFace + h1 <- createEdge v1 + h2 <- createEdge v0 + setFaceEdge f1 h1 + setFaceEdge f2 h2 + setTwinEdge h1 h2 + linkEdges (hv0 ^. edgeId) h1 + linkEdges (hv1 ^. edgeId) h2 + linkEdges h1 (hv1 ^. edgeNext) + linkEdges h2 (hv0 ^. edgeNext) + updateFaces (hv0 ^. edgeId) f1 + updateFaces (hv1 ^. edgeId) f2 + modify $ meshFaces %~ M.delete f0 + return (f1,f2) + +steinerNodes :: Mesh a -> [VertexId] +steinerNodes Mesh{..} = + [ v + | v <- M.keys _meshVertices + , S.notMember v notSteiner + ] where - n = length pts + notSteiner = S.fromList + [ _edgeVertex edge + | edge <- M.elems _meshEdges + , _edgeFace edge == _meshOuterFace ] --- addEdge :: VertexIdx -> VertexIdx -> DCEL -> DCEL -> --- addEdge a b dcel = --- add edge, vertex=a, face=a --- add twin +-- findNeighbours :: VertexId -> Mesh a -> [Edge] +-- findNeighbours vertex Mesh{..} = +-- [ edge +-- | edge <- M.elems _meshEdges +-- , _edgeVertex edge == vertex +-- ] + +{- +For each internal node: + * Find neighbours + * Compute angle-based position + * Compute laplacian position + * Update if possible -} +meshSmoothPosition :: Mesh (V2 Double) -> Mesh (V2 Double) +meshSmoothPosition = execState worker + where + worker = gets steinerNodes >>= mapM_ smoothVertex + +smoothVertex :: VertexId -> MeshM (V2 Double) () +smoothVertex steiner = do + self <- _vertexPosition <$> requireVertex steiner + es <- gets (outgoingEdges steiner) + vs <- mapM (requireVertex . _edgeVertex) es + let ps = V.fromList (sortEdges self (map _vertexPosition vs)) + angleBased = angleSmooth self ps + laplacian = sum ps ^/ (fromIntegral $ length ps) -- laplacian + if isValidLocation self ps angleBased + then modifyVertex (vertexPosition .~ angleBased) steiner + else if isValidLocation self ps laplacian + then modifyVertex (vertexPosition .~ laplacian) steiner + else return () + where + sortEdges :: V2 Double -> [V2 Double] -> [V2 Double] + sortEdges = sortOn . dir + -- Direction from south of 'a', to 'a', to 'b'. + dir :: V2 Double -> V2 Double -> Double + dir a b = (atan2 (crossZ (V2 0 1) (b - a)) (dot (V2 0 1) (b - a))) + + +angleSmooth :: V2 Double -> V.Vector (V2 Double) -> V2 Double +angleSmooth origin js = V.sum (V.generate n nth) ^/ V.sum (V.generate n factor) + where + n = length js + factor i = + let n_self = js V.! i + n_origin = origin - n_self + n_prev = js V.! mod (i - 1) n - n_self + n_next = js V.! mod (i + 1) n - n_self + a1 = acos (dot n_origin n_next / (norm n_origin * norm n_next)) + a2 = acos (dot n_origin n_prev / (norm n_origin * norm n_prev)) + alpha = a1 + a2 + in recip (alpha * alpha) + nth i = + let V2 x y = origin + n_self@(V2 x_0 y_0) = js V.! i + n_origin = origin - n_self + n_prev = js V.! mod (i - 1) n - n_self + n_next = js V.! mod (i + 1) n - n_self + a1 = acos (dot n_origin n_next / (norm n_origin * norm n_next)) + a2 = acos (dot n_origin n_prev / (norm n_origin * norm n_prev)) + alpha = a1 + a2 + b = (a2 - a1) / 2 + x' = x_0 + (x - x_0) * cos b - (y - y_0) * sin b + y' = y_0 + (x - x_0) * sin b + (y - y_0) * cos b + in V2 x' y' ^/ (alpha * alpha) + +isValidLocation :: V2 Double -> V.Vector (V2 Double) -> V2 Double -> Bool +isValidLocation origin edges newLoc = + or + [ isInside origin a b newLoc + | i <- [0 .. length edges - 1] + , let a = edges V.! i + b = edges V.! mod (i + 1) (length edges) + ] + && V.toList edges + == sortOn (dir newLoc) (V.toList edges) + && minAngle origin edges + < minAngle newLoc edges + where + dir :: V2 Double -> V2 Double -> Double + dir a b = (atan2 (crossZ (V2 0 1) (b - a)) (dot (V2 0 1) (b - a))) + +minAngle :: V2 Double -> V.Vector (V2 Double) -> Double +minAngle origin edges = minimum $ concat + [ [a1, a2, a3] + | i <- [0 .. length edges - 1] + , let a = edges V.! i + b = edges V.! mod (i + 1) (length edges) + (a1, a2, a3) = triangleAngles origin a b + ] + +flipEdge :: Edge -> MeshM (V2 Double) (FaceId, FaceId) +flipEdge e = do + e' <- getEdge (e^.edgeTwin) + + v0 <- _vertexPosition <$> requireVertex (e^.edgeVertex) + v1 <- _vertexPosition <$> requireVertex (e'^.edgeVertex) + + a' <- getEdge (e^.edgeNext) + b' <- getEdge (e'^.edgeNext) + + v0' <- _vertexPosition <$> requireVertex (a'^.edgeVertex) + v1' <- _vertexPosition <$> requireVertex (b'^.edgeVertex) + + case lineIntersect (v0, v1) (v0', v1') of + Nothing -> pure (e^.edgeFace, e'^.edgeFace) + Just{} -> do + deleteEdge (e^.edgeId) + insertEdge (e^.edgeFace) (a'^.edgeVertex) (b'^.edgeVertex) + +internalEdges :: Mesh a -> [EdgeId] +internalEdges m = + [ edge^.edgeId + | edge <- M.elems (m^.meshEdges) + , edge^.edgeFace /= m^.meshOuterFace + , let twin = meshGetEdge (edge^.edgeTwin) m + , edge^.edgeVertex < twin^.edgeVertex + , twin^.edgeFace /= m^.meshOuterFace + ] + +outerEdges :: Mesh a -> [EdgeId] +outerEdges m = + [ edge^.edgeId + | edge <- M.elems (m^.meshEdges) + , edge^.edgeFace == m^.meshOuterFace + ] + +longestEdge :: Mesh (V2 Double) -> Mesh (V2 Double) -> EdgeId +longestEdge m1 m2 = + maximumBy cmp (internalEdges m1) + where + cmp e1 e2 = + compare + (max (edgeLength e1 m1) (edgeLength e1 m2)) + (max (edgeLength e2 m1) (edgeLength e2 m2)) + +edgeLength :: EdgeId -> Mesh (V2 Double) -> Double +edgeLength eid m = + let edge = meshGetEdge eid m + twin = meshGetEdge (edge^.edgeTwin) m + p1 = _vertexPosition $ meshGetVertex (edge^.edgeVertex) m + p2 = _vertexPosition $ meshGetVertex (twin^.edgeVertex) m + in distance p1 p2 + +applyCompatible :: (t -> Mesh a -> Maybe (Mesh a)) -> (Mesh a -> [t]) -> Mesh a -> Mesh a -> (Mesh a, Mesh a) +applyCompatible _fn _vs m1 m2 + | _meshIdCounter m1 /= _meshIdCounter m2 = error "invalid ID counter" +applyCompatible fn vs m1 m2 = worker m1 m2 (vs m1) + where + worker l r [] = (l,r) + worker l r (eid:rest) = + case (,) <$> fn eid l <*> fn eid r of + Nothing -> worker l r rest + Just (l', r') -> worker l' r' rest + +delaunayFlip :: Mesh (V2 Double) -> Mesh (V2 Double) -> (Mesh (V2 Double), Mesh (V2 Double)) +delaunayFlip = applyCompatible delaunayFlip' internalEdges + +delaunayFlip' :: EdgeId -> Mesh (V2 Double) -> Maybe (Mesh (V2 Double)) +delaunayFlip' eid m = + let edge = meshGetEdge eid m + twin = meshGetEdge (edge^.edgeTwin) m + f1 = edge^.edgeFace + f2 = twin^.edgeFace + beforeAng = min (faceMinAngle f1 m) (faceMinAngle f2 m) + ((f1',f2'), mAfter) = runState (flipEdge edge) m + afterAng = min (faceMinAngle f1' mAfter) (faceMinAngle f2' mAfter) + in + if (afterAng < beforeAng) || f1' == f1 + then Nothing + else Just mAfter + +splitInternalEdges :: Mesh (V2 Double) -> Mesh (V2 Double) -> (Mesh (V2 Double), Mesh (V2 Double)) +splitInternalEdges = applyCompatible splitInternalEdge internalEdges + +splitInternalEdge :: EdgeId -> Mesh (V2 Double) -> Maybe (Mesh (V2 Double)) +splitInternalEdge eid m = evalState worker m + where + edgeFaces edge = do + twin <- getEdge (edge^.edgeTwin) + return (edge^.edgeFace, twin^.edgeFace) + worker = do + edge <- getEdge eid + twin <- getEdge (edge^.edgeTwin) + v0 <- _vertexPosition <$> requireVertex (edge^.edgeVertex) + v1 <- _vertexPosition <$> requireVertex (twin^.edgeVertex) + let middle = lerp 0.5 v0 v1 + (f1,f2) <- edgeFaces edge + mBefore <- get + let beforeAng = min (faceMinAngle f1 mBefore) (faceMinAngle f2 mBefore) + (f3,f4,f5,f6) <- splitTriangle middle eid + mAfter <- get + let afterAng = minimum + [ faceMinAngle f3 mAfter + , faceMinAngle f4 mAfter + , faceMinAngle f5 mAfter + , faceMinAngle f6 mAfter ] + return () + if (afterAng < beforeAng) + then return Nothing + else return (Just mAfter) + +splitLongestEdge :: Mesh (V2 Double) -> Mesh (V2 Double) -> (Mesh (V2 Double), Mesh (V2 Double)) +splitLongestEdge m1 m2 = + (splitInternalEdgeForced longest m1, splitInternalEdgeForced longest m2) + where + longest = longestEdge m1 m2 + +splitInternalEdgeForced :: EdgeId -> Mesh (V2 Double) -> Mesh (V2 Double) +splitInternalEdgeForced eid m = execState worker m + where + worker = do + edge <- getEdge eid + twin <- getEdge (edge^.edgeTwin) + v0 <- _vertexPosition <$> requireVertex (edge^.edgeVertex) + v1 <- _vertexPosition <$> requireVertex (twin^.edgeVertex) + let middle = lerp 0.5 v0 v1 + splitTriangle middle eid + +splitOuterEdges :: Mesh (V2 Double) -> Mesh (V2 Double) -> (Mesh (V2 Double), Mesh (V2 Double)) +splitOuterEdges = applyCompatible splitOuterEdge outerEdges + +splitOuterEdge :: EdgeId -> Mesh (V2 Double) -> Maybe (Mesh (V2 Double)) +splitOuterEdge eid m = evalState worker m + where + worker = do + edge <- getEdge eid + twin <- getEdge (edge^.edgeTwin) + v0 <- _vertexPosition <$> requireVertex (edge^.edgeVertex) + v1 <- _vertexPosition <$> requireVertex (twin^.edgeVertex) + let middle = lerp 0.5 v0 v1 + let f1 = twin^.edgeFace + mBefore <- get + let beforeAng = faceMinAngle f1 mBefore + (f2,f3) <- splitOuterTriangle middle eid + mAfter <- get + let afterAng = minimum + [ faceMinAngle f2 mAfter + , faceMinAngle f3 mAfter ] + if (afterAng < beforeAng) + then return Nothing + else return (Just mAfter) + +renderMesh :: Double -> Mesh (V2 Double) -> SVG +renderMesh radius m = mkGroup + [ mkGroup + [ withStrokeColor "black" $ + mkLine (x1, y1) (x2, y2) + | edge <- M.elems (_meshEdges m) + , _edgeFace edge /= _meshOuterFace m + , let twin = meshGetEdge (edge ^. edgeTwin) m + , let V2 x1 y1 = _vertexPosition (meshGetVertex (_edgeVertex edge) m) + V2 x2 y2 = _vertexPosition (meshGetVertex (_edgeVertex twin) m) + ] + -- , mkGroup + -- [ mkLinePathClosed + -- [ + -- | + -- ] [(Double, Double)] -> Tree + -- | face <- M.elems _meshFaces + -- ] + , mkGroup + [ translate x y $ withFillColor "red" $ mkCircle radius + | vertex <- M.elems (_meshVertices m) + , let V2 x y = _vertexPosition vertex + ] + ] + +renderMeshEdges :: Mesh (V2 Double) -> SVG +renderMeshEdges mesh@Mesh {..} = mkGroup + [ mkGroup + [ mkGroup + [ withStrokeColorPixel (promotePixel $ viridis $ ang/pi) $ + mkLine (x1, y1) (x2, y2) + ] + | edge <- M.elems _meshEdges + , _edgeFace edge /= _meshOuterFace + , let twin = meshGetEdge (edge ^. edgeTwin) mesh + V2 x1 y1 = _vertexPosition (meshGetVertex (_edgeVertex edge) mesh) + V2 x2 y2 = _vertexPosition (meshGetVertex (_edgeVertex twin) mesh) + ang = meshEdgeAngle mesh (edge^.edgeId) + , ang/pi*180 < 2 + ] + ] + +renderMeshSimple :: Double -> Mesh (V2 Double) -> SVG +renderMeshSimple radius Mesh {..} = mkGroup + [ mkGroup + [ translate x y $ mkGroup + [ withFillColor "red" $ mkCircle 0.01 + , scaleToHeight (radius*2) $ center $ latex $ T.pack $ show (_vertexId vertex) ] + | vertex <- M.elems _meshVertices + , let V2 x y = _vertexPosition vertex + ] + ] + +renderMeshColored :: Mesh (V2 Double) -> SVG +renderMeshColored m@Mesh{..} = mkGroup + [ withFillColorPixel c $ mkLinePathClosed $ + [ (x,y) | V2 x y <- facePositions fid m ] + | fid <- M.keys _meshFaces + , let ang = faceMinAngle fid m + bestAng = pi/3 + score = ang/bestAng + c = promotePixel $ viridis score + ] +-- facePositions :: FaceId -> Mesh a -> [a] +-- faceMinAngle :: FaceId -> Mesh (V2 Double) -> Double + +renderMeshStats :: Mesh (V2 Double) -> SVG +renderMeshStats mesh = mkGroup + [ latex $ T.pack $ printf "Min: %.1f" (minAng/pi*180) + , translate 0 (sep*1) $ + latex $ T.pack $ printf "Mean: %.1f" (meanAngle/pi*180) + , translate 0 (sep*2) $ + latex $ T.pack $ printf "Avg: %.1f" (avgAngle/pi*180) + , translate 0 (sep*3) $ + latex $ T.pack $ printf "Max: %.1f" (maxAngle/pi*180) + ] + where + sep = -1 + angs = meshAngles mesh + minAng = minimum angs + meanAngle = L.sort angs !! (length angs `div` 2) + avgAngle = sum angs / (fromIntegral $ length angs) + maxAngle = maximum angs + +toRigidMesh :: Mesh (V2 Double) -> Mesh (V2 Double) -> Rigid.Mesh +toRigidMesh meshA meshB = Rigid.Mesh + { meshPointsA = pointsA + , meshPointsB = pointsB + , meshOutline = outline + , meshTriangles = trigs } + where + pointsA = V.fromList $ map _vertexPosition $ M.elems (meshA^.meshVertices) + pointsB = V.fromList $ map _vertexPosition $ M.elems (meshB^.meshVertices) + outline = V.fromList + [ fromJust (V.elemIndex v pointsA) + | eid <- faceEdges (meshA^.meshOuterFace) meshA + , let edge = meshGetEdge eid meshA + v = _vertexPosition (meshGetVertex (edge^.edgeVertex) meshA) + ] + trigs = V.fromList + [ (aIdx, bIdx, cIdx) + | fid <- M.keys (meshA^.meshFaces) + , fid /= (meshA^.meshOuterFace) + , let edges = map (`meshGetEdge` meshA) (faceEdges fid meshA) + vs = map (`meshGetVertex` meshA) $ map _edgeVertex edges + ps = map _vertexPosition vs + [aIdx, bIdx, cIdx] = map (fromJust . (`V.elemIndex` pointsA)) ps + p = mkPolygon (V.fromList $ map (fmap realToFrac) ps) + , pIsSimple p || error "invalid polygon" + ] + diff --git a/src/Reanimate/Math/EarClip.hs b/src/Reanimate/Math/EarClip.hs --- a/src/Reanimate/Math/EarClip.hs +++ b/src/Reanimate/Math/EarClip.hs @@ -1,16 +1,38 @@ module Reanimate.Math.EarClip - ( earClip + ( earCut + , earCut' + , earClip , earClip' , isEarCorner ) where import Data.List import qualified Data.Set as Set +import Data.Tuple import Reanimate.Math.Common import Reanimate.Math.Triangulate +import qualified Data.Vector as V +import qualified Geometry.Earcut as C +import Linear.V2 + -- import Debug.Trace + +earCut :: (Real a) => Ring a -> Triangulation +earCut = last . earCut' + +earCut' :: (Real a) => Ring a -> [Triangulation] +earCut' p = + map (edgesToTriangulation (ringSize p)) $ inits $ nub + [ if fst pair < snd pair then pair else swap pair + | (a,b,c) <- V.toList (C.earcut lst) + , pair <- [(a,b), (a,c), (b,c)] + , fst pair /= (snd pair+1) `mod` ringSize p + , fst pair /= (snd pair-1) `mod` ringSize p + ] + where + lst = [ (x,y) | V2 x y <- V.toList $ V.map (fmap realToFrac) $ ringUnpack p ] -- Triangulation by ear clipping. O(n^2) earClip :: (Fractional a, Ord a) => Ring a -> Triangulation diff --git a/src/Reanimate/Math/Polygon.hs b/src/Reanimate/Math/Polygon.hs --- a/src/Reanimate/Math/Polygon.hs +++ b/src/Reanimate/Math/Polygon.hs @@ -34,6 +34,8 @@ , pCircumference' -- :: (Real a, Fractional a) => APolygon a -> Double , pAddPoints -- :: Int -> Polygon -> Polygon , pRayIntersect -- :: Polygon -> (Int, Int) -> (Int,Int) -> Maybe (V2 Rational) + , pCuts -- :: Polygon -> [(Polygon,Polygon)] + , pCutEqual -- :: Polygon -> (Polygon, Polygon) -- * Triangulation , isValidTriangulation -- :: Polygon -> Triangulation -> Bool , triangulationsToPolygons -- :: Polygon -> Triangulation -> [Polygon] @@ -77,8 +79,10 @@ , pUnGenerate -- :: Polygon -> [(Double, Double)] ) where +-- import Control.Exception import Data.Hashable -import Data.List (intersect, tails, sort, maximumBy) +import Data.List (intersect, maximumBy, sort, sortOn, + tails) import Data.Maybe import Data.Ratio import Data.Serialize @@ -115,14 +119,14 @@ instance Hashable a => Hashable (APolygon a) where hashWithSalt s p = V.foldl' hashWithSalt s (polygonPoints p) -instance (Fractional a, Ord a, Serialize a) => Serialize (APolygon a) where +instance (Real a, Fractional a, Ord a, Serialize a) => Serialize (APolygon a) where put = put . V.toList . polygonPoints get = mkPolygon . V.fromList <$> get pRing :: APolygon a -> Ring a pRing = ringPack . polygonPoints -mkPolygon :: (Fractional a, Ord a) => V.Vector (V2 a) -> APolygon a +mkPolygon :: (Real a, Fractional a, Ord a) => V.Vector (V2 a) -> APolygon a mkPolygon points = Polygon { polygonPoints = points , polygonOffset = 0 @@ -132,9 +136,10 @@ where n = length points ring = ringPack points - trig = earClip ring + trig = earCut ring + -- earClip ring -mkPolygonFromRing :: (Fractional a, Ord a) => Ring a -> APolygon a +mkPolygonFromRing :: (Real a, Fractional a, Ord a) => Ring a -> APolygon a mkPolygonFromRing = mkPolygon . ringUnpack pUnsafeMap :: (Ring a -> Ring a) -> APolygon a -> APolygon a @@ -597,11 +602,32 @@ where fn (V2 x1 y1) (V2 x2 y2) = (x2-x1)*(y2+y1) +{-# INLINE pRayIntersect #-} pRayIntersect :: Polygon -> (Int, Int) -> (Int,Int) -> Maybe (V2 Rational) pRayIntersect p (a,b) (c,d) = rayIntersect (pAccess p a, pAccess p b) (pAccess p c, pAccess p d) +pCuts :: Polygon -> [(Polygon,Polygon)] +pCuts p = + [ pCutAt (pAdjustOffset p i) (j-i) + | i <- [0 .. pSize p-1 ] + , j <- [i+2 .. pSize p-1 ] + , (j+1) `mod` pSize p /= i + , pParent p i j == i ] +pCutEqual :: Polygon -> (Polygon, Polygon) +pCutEqual p = + fromMaybe (p,p) $ listToMaybe $ sortOn f $ pCuts p + where + f (a,b) = abs (pArea a - pArea b) + +-- FIXME: This should be more efficient +pCutAt :: Polygon -> Int -> (Polygon, Polygon) +pCutAt p i = (mkPolygon $ V.fromList left, mkPolygon $ V.fromList right) + where + n = pSize p + left = map (pAccess p) [0 .. i] + right = map (pAccess p) (0:[i..n-1]) diff --git a/src/Reanimate/Math/SSSP.hs b/src/Reanimate/Math/SSSP.hs --- a/src/Reanimate/Math/SSSP.hs +++ b/src/Reanimate/Math/SSSP.hs @@ -21,6 +21,7 @@ ) where import Control.Monad +-- import Control.Exception import Control.Monad.ST -- import Data.FingerTree (SearchResult (..), (|>)) -- import qualified Data.FingerTree as F diff --git a/src/Reanimate/Math/Smooth.hs b/src/Reanimate/Math/Smooth.hs --- a/src/Reanimate/Math/Smooth.hs +++ b/src/Reanimate/Math/Smooth.hs @@ -266,6 +266,8 @@ insertEdge t j p insertEdge t c p insertEdge t d p + -- Add 'newPoints' to mesh points + -- Convert edges to triangles return undefined where splitEdge i j = @@ -282,8 +284,8 @@ insertEdge v a b = do MV.modify v (b :) a MV.modify v (a :) b - -- sortEdges :: V.Vector (V2 Double) -> V2 Double -> V2 Double -> [Int] -> [Int] - -- sortEdges v prev pt = sortOn (\i -> dir prev pt (v V.! i)) + -- sortEdges :: V.Vector (V2 Double) -> V2 Double -> [Int] -> [Int] + -- sortEdges v pt = sortOn (\i -> dir pt (v V.! i)) - -- dir :: V2 Double -> V2 Double -> V2 Double -> Double - -- dir l a b = atan2 (crossZ (l - a) (b - a)) (dot (l - a) (b - a)) + -- dir :: V2 Double -> V2 Double -> Double + -- dir a b = (atan2 (crossZ (V2 0 1) (b - a)) (dot (V2 0 1) (b - a))) diff --git a/src/Reanimate/Misc.hs b/src/Reanimate/Misc.hs --- a/src/Reanimate/Misc.hs +++ b/src/Reanimate/Misc.hs @@ -8,19 +8,22 @@ , renameOrCopyFile ) where -import Control.Exception (evaluate, finally, throw, catch) -import qualified Data.Text as T -import qualified Data.Text.IO as T +import Control.Concurrent +import Control.Exception (catch, evaluate, finally, throw) +import qualified Data.Text as T +import qualified Data.Text.IO as T import Foreign.C.Error import GHC.IO.Exception -import System.Directory (copyFile, createDirectory, findExecutable, - getTemporaryDirectory, removeFile, - renameFile) -import System.FilePath ((<.>), ()) -import System.IO (hClose, hGetContents, hIsEOF, openTempFile) -import System.Process (readProcessWithExitCode, - runInteractiveProcess, showCommandForUser, - terminateProcess, waitForProcess) +import System.Directory (copyFile, findExecutable, removeFile, + renameFile) +import System.FilePath ((<.>)) +import System.IO (hClose, hGetContents, hIsEOF, hPutStr, + stderr) +import System.IO.Temp (withSystemTempDirectory, + withSystemTempFile) +import System.Process (readProcessWithExitCode, + runInteractiveProcess, showCommandForUser, + terminateProcess, waitForProcess) requireExecutable :: String -> IO FilePath @@ -39,34 +42,41 @@ runCmd_ :: FilePath -> [String] -> IO (Either String String) runCmd_ exec args = do - (ret, stdout, stderr) <- readProcessWithExitCode exec args "" - _ <- evaluate (length stdout + length stderr) + (ret, stdout, errMsg) <- readProcessWithExitCode exec args "" + _ <- evaluate (length stdout + length errMsg) case ret of ExitSuccess -> return (Right stdout) ExitFailure err | False -> - return $ Left $ - "Failed to run: " ++ showCommandForUser exec args ++ "\n" ++ - "Error code: " ++ show err ++ "\n" ++ - "stderr: " ++ stderr - ExitFailure{} | null stderr -> -- LaTeX prints errors to stdout. :( + return + $ Left + $ "Failed to run: " + ++ showCommandForUser exec args + ++ "\n" + ++ "Error code: " + ++ show err + ++ "\n" + ++ "stderr: " + ++ errMsg + ExitFailure{} | null errMsg -> -- LaTeX prints errors to stdout. :( return $ Left stdout - ExitFailure{} -> - return $ Left stderr + ExitFailure{} -> return $ Left errMsg -runCmdLazy :: FilePath -> [String] -> (IO (Either String T.Text) -> IO a) -> IO a +runCmdLazy + :: FilePath -> [String] -> (IO (Either String T.Text) -> IO a) -> IO a runCmdLazy exec args handler = do (inp, out, err, pid) <- runInteractiveProcess exec args Nothing Nothing hClose inp + errOutput <- hGetContents err + _ <- forkIO $ hPutStr stderr errOutput let fetch = do eof <- hIsEOF out if eof then do - stderr <- hGetContents err - _ <- evaluate (length stderr) - ret <- waitForProcess pid + _ <- evaluate (length errOutput) + ret <- waitForProcess pid case ret of ExitSuccess -> return (Left "") - ExitFailure{} -> return (Left stderr) + ExitFailure{} -> return (Left errOutput) {-ExitFailure errMsg -> do return $ Left $ "Failed to run: " ++ showCommandForUser exec args ++ "\n" ++ @@ -80,25 +90,19 @@ _ <- waitForProcess pid return () +-- renameFile fails if we're crossing filesystem boundaries. If this happens, +-- revert back to copyFile + removeFile. renameOrCopyFile :: FilePath -> FilePath -> IO () renameOrCopyFile src dst = renameFile src dst `catch` exdev - where - exdev e = if fmap Errno (ioe_errno e) == Just eXDEV - then copyFile src dst >> removeFile src - else throw e + where + exdev e = if fmap Errno (ioe_errno e) == Just eXDEV + then copyFile src dst >> removeFile src + else throw e withTempDir :: (FilePath -> IO a) -> IO a -withTempDir action = do - dir <- getTemporaryDirectory - (path, handle) <- openTempFile dir "reanimate" - hClose handle - removeFile path - createDirectory (dir path) - action (dir path) -- `finally` removeDirectoryRecursive (dir path) +withTempDir = withSystemTempDirectory "reanimate" withTempFile :: String -> (FilePath -> IO a) -> IO a -withTempFile ext action = do - dir <- getTemporaryDirectory - (path, handle) <- openTempFile dir ("reanimate" <.> ext) - hClose handle - action path -- `finally` removeFile path +withTempFile ext action = + withSystemTempFile ("reanimate" <.> ext) $ \path hd -> + hClose hd >> action path diff --git a/src/Reanimate/Morph/Cache.hs b/src/Reanimate/Morph/Cache.hs --- a/src/Reanimate/Morph/Cache.hs +++ b/src/Reanimate/Morph/Cache.hs @@ -7,6 +7,7 @@ import Data.Hashable import Data.Serialize import Reanimate.Cache (encodeInt) +import Reanimate.Misc (renameOrCopyFile) import Reanimate.Morph.Common import System.Directory import System.FilePath @@ -36,7 +37,7 @@ withSystemTempFile template $ \tmp h -> do hClose h B.writeFile tmp (encode correspondence) - renameFile tmp path + renameOrCopyFile tmp path return correspondence template = encodeInt key <.> "morph" key = hashWithSalt ident (src,dst) diff --git a/src/Reanimate/Morph/Common.hs b/src/Reanimate/Morph/Common.hs --- a/src/Reanimate/Morph/Common.hs +++ b/src/Reanimate/Morph/Common.hs @@ -17,23 +17,23 @@ ) where import Control.Lens -import qualified Data.Vector as V -import Graphics.SvgTree (DrawAttributes, Texture (..), - drawAttributes, fillColor, fillOpacity, - groupOpacity, strokeColor, - strokeOpacity) +import qualified Data.Vector as V +import Graphics.SvgTree (DrawAttributes, Texture (..), + drawAttributes, fillColor, + fillOpacity, groupOpacity, + strokeColor, strokeOpacity) import Linear.V2 import Reanimate.Animation import Reanimate.ColorComponents -import Reanimate.Math.EarClip -import Reanimate.Math.Polygon (Polygon, mkPolygon, pAddPoints, - pCentroid, pRing, pSize, pdualPolygons, - polygonPoints) -import Reanimate.Math.SSSP -import Reanimate.PolyShape import Reanimate.Ease +import Reanimate.Math.Polygon (Polygon, mkPolygon, pAddPoints, + pCentroid, pCutEqual, pSize, + polygonPoints) +import Reanimate.PolyShape import Reanimate.Svg +-- import Debug.Trace + -- Correspondence -- Trajectory -- Color interpolation @@ -129,6 +129,7 @@ (x, y) : dupObjectCorrespondence xs ys splitObjectCorrespondence :: ObjectCorrespondence +-- splitObjectCorrespondence = dupObjectCorrespondence splitObjectCorrespondence left right = case (left, right) of (_, []) -> [] @@ -145,14 +146,10 @@ (x,y) : splitObjectCorrespondence xs ys splitPolygon :: Int -> Polygon -> [Polygon] -splitPolygon n polygon = - let trig = earClip $ pRing polygon - d = dual 0 trig - pd = toPDual (pRing polygon) d - reduced = pdualReduce (pRing polygon) pd n - polygons = pdualPolygons polygon reduced - in polygons - +splitPolygon 1 p = [p] +splitPolygon n p = + let (a,b) = pCutEqual p + in splitPolygon (n`div`2) a ++ splitPolygon ((n+1)`div`2) b -- joinPairs :: Correspondence -> [(DrawAttributes, PolyShape)] -> [(DrawAttributes, PolyShape)] -- -> [(DrawAttributes, DrawAttributes, [(RPoint, RPoint)])] diff --git a/src/Reanimate/Morph/Linear.hs b/src/Reanimate/Morph/Linear.hs --- a/src/Reanimate/Morph/Linear.hs +++ b/src/Reanimate/Morph/Linear.hs @@ -43,7 +43,9 @@ then worker x newScore xs else worker bestP bestPScore xs options = pCycles dst - score = V.sum . V.zipWith approxDist (polygonPoints src) . polygonPoints + score p = sum + [ approxDist (pAccess src n) (pAccess p n) + | n <- [0 .. pSize src-1] ] linearTrajectory :: Trajectory linearTrajectory (src,dst) diff --git a/src/Reanimate/Morph/Rigid.hs b/src/Reanimate/Morph/Rigid.hs --- a/src/Reanimate/Morph/Rigid.hs +++ b/src/Reanimate/Morph/Rigid.hs @@ -76,7 +76,10 @@ import qualified Numeric.LinearAlgebra as Matrix import Numeric.LinearAlgebra.HMatrix (GMatrix, Matrix, toLists, (!), (><)) +import Reanimate.Animation +import Reanimate.Svg + type P = V2 Double type Trig = (P,P,P) type RelTrig = (Int,Int,Int) @@ -88,6 +91,18 @@ -- , meshSteiner :: Vector Int , meshTriangles :: Vector RelTrig } +renderMeshPair :: Mesh -> SVG +renderMeshPair Mesh{..} = withStrokeColor "black" $ mkGroup + [ mkLinePathClosed + [ (aPx, aPy) + , (bPx, bPy) + , (cPx, cPy)] + | (a,b,c) <- V.toList meshTriangles + , let V2 aPx aPy = meshPointsA V.! a + V2 bPx bPy = meshPointsA V.! b + V2 cPx cPy = meshPointsA V.! c + ] + -- applyA (computeA a b) a = b + some_constant_translation -- A = Q P_inv computeA :: Trig -> Trig -> Matrix Double @@ -189,8 +204,9 @@ where aOrigin = meshPointsA V.! pivotIdx bOrigin = meshPointsB V.! pivotIdx - pivotIdx = case V.head meshTriangles of - (a,_,_) -> a + pivotIdx = 0 + -- pivotIdx = case V.head meshTriangles of + -- (a,_,_) -> a mkAbs p (a,b,c) = (p V.! a,p V.! b,p V.! c) absATrigs = V.map (mkAbs meshPointsA) meshTriangles absBTrigs = V.map (mkAbs meshPointsB) meshTriangles diff --git a/src/Reanimate/Parameters.hs b/src/Reanimate/Parameters.hs --- a/src/Reanimate/Parameters.hs +++ b/src/Reanimate/Parameters.hs @@ -29,7 +29,7 @@ | RasterAuto | RasterInkscape | RasterRSvg - | RasterConvert + | RasterMagick deriving (Show, Eq) {-# NOINLINE pRasterRef #-} diff --git a/src/Reanimate/PolyShape.hs b/src/Reanimate/PolyShape.hs --- a/src/Reanimate/PolyShape.hs +++ b/src/Reanimate/PolyShape.hs @@ -38,16 +38,16 @@ import Data.List (minimumBy, nub, partition, sortOn) import Data.Ord import qualified Data.Vector as V -import Debug.Trace import Geom2D (rotate90L, rotate90R, ($*), (^*)) import Geom2D.CubicBezier (ClosedPath (..), CubicBezier (..), DPoint, FillRule (..), PathJoin (..), - Point (..), arcLength, arcLengthParam, - bezierIntersection, bezierSubsegment, - closedPathCurves, closest, colinear, - curvesToClosed, evalBezier, - interpolateVector, reorient, - splitBezier, union, vectorDistance) + Point (..), QuadBezier (..), arcLength, + arcLengthParam, bezierIntersection, + bezierSubsegment, closedPathCurves, + closest, colinear, curvesToClosed, + evalBezier, interpolateVector, + quadToCubic, reorient, splitBezier, + union, vectorDistance) import Graphics.SvgTree (PathCommand (..), RPoint, Tree (..), defaultSvg, pathDefinition) import Linear.V2 @@ -274,7 +274,7 @@ where bad = error $ "Reanimate.PolyShape: Invalid commands: " ++ show cmds finalize [] rest = rest - finalize acc rest = (ClosedPath $ reverse acc) : rest + finalize acc rest = ClosedPath (reverse acc) : rest worker _from acc [] = finalize acc [] worker _from acc (LineMove newStart : xs) = finalize acc $ @@ -291,12 +291,18 @@ finalize acc [] worker from acc (LineBezier [x]:xs) = worker x ((toGPoint from, JoinLine) : acc) xs + worker from acc (LineBezier [a,b]:xs) = + let quad = QuadBezier (toGPoint from) (toGPoint a) (toGPoint b) + CubicBezier _ a' b' c' = quadToCubic quad + in worker from acc (LineBezier (map fromGPoint [a',b',c']):xs) worker from acc (LineBezier [a,b,c]:xs) = worker c ((toGPoint from, JoinCurve (toGPoint a) (toGPoint b)) : acc) xs worker _ _ _ = bad toGPoint :: RPoint -> Point Double toGPoint (V2 x y) = Point x y + fromGPoint :: Point Double -> RPoint + fromGPoint (Point x y) = V2 x y unionPolyShapes :: [PolyShape] -> [PolyShape] unionPolyShapes shapes = @@ -349,7 +355,7 @@ { polyShapeParent = s , polyShapeHoles = holes } in prime : worker nonHoles - | otherwise = trace "Found hole, putting back" $ worker (rest ++ [s]) + | otherwise = worker (rest ++ [s]) worker [] = [] parents :: PolyShape -> [PolyShape] -> [PolyShape] @@ -407,7 +413,7 @@ [x2p] ) where - vect = (childOrigin ^-^ p) ^* 0.0001 + vect = (childOrigin ^-^ p) ^* 0 -- 0.0001 vectL = rotate90L $* vect vectR = rotate90R $* vect score = vectorDistance childOrigin p diff --git a/src/Reanimate/Raster.hs b/src/Reanimate/Raster.hs --- a/src/Reanimate/Raster.hs +++ b/src/Reanimate/Raster.hs @@ -1,30 +1,39 @@ module Reanimate.Raster - ( mkImage - , cacheImage - , embedImage - , embedDynamicImage - , embedPng - , raster - , rasterSized - , vectorize - , vectorize_ - , svgAsPngFile - , svgAsPngFile' - ) where + ( mkImage -- :: Double -> Double -> FilePath -> SVG + , cacheImage -- :: (PngSavable pixel, Hashable a) => a -> Image pixel -> FilePath + , prerenderSvg -- :: Hashable a => a -> SVG -> SVG + , prerenderSvgFile -- :: Hashable a => a -> Width -> Height -> SVG -> FilePath + , embedImage -- :: PngSavable a => Image a -> SVG + , embedDynamicImage -- :: DynamicImage -> SVG + , embedPng -- :: Double -> Double -> LBS.ByteString -> SVG + , raster -- :: SVG -> DynamicImage + , rasterSized -- :: Width -> Height -> SVG -> DynamicImage + , vectorize -- :: FilePath -> SVG + , vectorize_ -- :: [String] -> FilePath -> SVG + , svgAsPngFile -- :: SVG -> FilePath + , svgAsPngFile' -- :: Width -> Height -> SVG -> FilePath + ) +where import Codec.Picture -import Control.Lens ((&), (.~)) +import Control.Lens ( (&) + , (.~) + ) import Control.Monad -import qualified Data.ByteString as B -import qualified Data.ByteString.Base64.Lazy as Base64 -import qualified Data.ByteString.Lazy.Char8 as LBS +import qualified Data.ByteString as B +import qualified Data.ByteString.Base64.Lazy as Base64 +import qualified Data.ByteString.Lazy.Char8 as LBS import Data.Hashable -import qualified Data.Text as T -import Graphics.SvgTree (Number (..), Tree (..), - defaultSvg, parseSvgFile) -import qualified Graphics.SvgTree as Svg +import qualified Data.Text as T +import Graphics.SvgTree ( Number(..) + , Tree(..) + , defaultSvg + , parseSvgFile + ) +import qualified Graphics.SvgTree as Svg import Reanimate.Animation import Reanimate.Cache +import Reanimate.Driver.Magick import Reanimate.Misc import Reanimate.Render import Reanimate.Parameters @@ -54,51 +63,87 @@ -- > mkImage screenWidth screenHeight "../data/haskell.svg" -- -- <> -mkImage :: Double -- ^ Desired image width. - -> Double -- ^ Desired image height. - -> FilePath -- ^ Path to external image file. - -> SVG +mkImage + :: Double -- ^ Desired image width. + -> Double -- ^ Desired image height. + -> FilePath -- ^ Path to external image file. + -> SVG mkImage width height path | takeExtension path == ".svg" = unsafePerformIO $ do svg_data <- B.readFile path case parseSvgFile path svg_data of - Nothing -> error "Malformed svg" - Just svg -> return $ - scaleXY (width/screenWidth) (height/screenHeight) $ - embedDocument svg + Nothing -> error "Malformed svg" + Just svg -> + return + $ scaleXY (width / screenWidth) (height / screenHeight) + $ embedDocument svg mkImage width height path | pRaster == RasterNone = unsafePerformIO $ do inp <- LBS.readFile path let imgData = LBS.unpack $ Base64.encode inp - return $ flipYAxis $ ImageTree $ defaultSvg - & Svg.imageWidth .~ Svg.Num width - & Svg.imageHeight .~ Svg.Num height - & Svg.imageHref .~ ("data:"++mimeType++";base64,"++imgData) - & Svg.imageCornerUpperLeft .~ (Svg.Num (-width/2), Svg.Num (-height/2)) - & Svg.imageAspectRatio .~ Svg.PreserveAspectRatio False Svg.AlignNone Nothing - where + return + $ flipYAxis + $ ImageTree + $ defaultSvg + & Svg.imageWidth + .~ Svg.Num width + & Svg.imageHeight + .~ Svg.Num height + & Svg.imageHref + .~ ("data:" ++ mimeType ++ ";base64," ++ imgData) + & Svg.imageCornerUpperLeft + .~ (Svg.Num (-width / 2), Svg.Num (-height / 2)) + & Svg.imageAspectRatio + .~ Svg.PreserveAspectRatio False Svg.AlignNone Nothing + where -- FIXME: Is there a better way to do this? - mimeType = - case takeExtension path of - ".jpg" -> "image/jpeg" - ext -> "image/" ++ drop 1 ext + mimeType = case takeExtension path of + ".jpg" -> "image/jpeg" + ext -> "image/" ++ drop 1 ext mkImage width height path = unsafePerformIO $ do - exists <- doesFileExist target - unless exists $ copyFile path target - return $ flipYAxis $ ImageTree $ defaultSvg - & Svg.imageWidth .~ Svg.Num width - & Svg.imageHeight .~ Svg.Num height - & Svg.imageHref .~ ("file://"++target) - & Svg.imageCornerUpperLeft .~ (Svg.Num (-width/2), Svg.Num (-height/2)) - & Svg.imageAspectRatio .~ Svg.PreserveAspectRatio False Svg.AlignNone Nothing - where - target = pRootDirectory show hashPath <.> takeExtension path - hashPath = hash path + exists <- doesFileExist target + unless exists $ copyFile path target + return + $ flipYAxis + $ ImageTree + $ defaultSvg + & Svg.imageWidth + .~ Svg.Num width + & Svg.imageHeight + .~ Svg.Num height + & Svg.imageHref + .~ ("file://" ++ target) + & Svg.imageCornerUpperLeft + .~ (Svg.Num (-width / 2), Svg.Num (-height / 2)) + & Svg.imageAspectRatio + .~ Svg.PreserveAspectRatio False Svg.AlignNone Nothing + where + target = pRootDirectory encodeInt hashPath <.> takeExtension path + hashPath = hash path cacheImage :: (PngSavable pixel, Hashable a) => a -> Image pixel -> FilePath cacheImage key gen = unsafePerformIO $ cacheFile template $ \path -> - writePng path gen - where - template = show (hash key) <.> "png" + writePng path gen + where template = encodeInt (hash key) <.> "png" +-- Warning: Caching svg elements with links to external objects does +-- not work. 2020-06-01 +prerenderSvgFile :: Hashable a => a -> Width -> Height -> SVG -> FilePath +prerenderSvgFile key width height svg = + unsafePerformIO $ cacheFile template $ \path -> do + let svgPath = replaceExtension path "svg" + writeFile svgPath rendered + engine <- requireRaster pRaster + applyRaster engine svgPath + where + template = encodeInt (hash (key, width, height)) <.> "png" + rendered = renderSvg (Just $ Px $ fromIntegral width) + (Just $ Px $ fromIntegral height) + svg + +prerenderSvg :: Hashable a => a -> SVG -> SVG +prerenderSvg key = + mkImage screenWidth screenHeight . prerenderSvgFile key pWidth pHeight + + {-# INLINE embedImage #-} -- | Embed an in-memory PNG image. Note, the pixel size of the image -- is used as the dimensions. As such, embedding a 100x100 PNG will @@ -106,15 +151,16 @@ -- using with 'scaleToSize'. embedImage :: PngSavable a => Image a -> SVG embedImage img = embedPng width height (encodePng img) - where - width = fromIntegral $ imageWidth img - height = fromIntegral $ imageHeight img + where + width = fromIntegral $ imageWidth img + height = fromIntegral $ imageHeight img -- | Embed in-memory PNG bytestring without parsing it. -embedPng :: Double -- ^ Width - -> Double -- ^ Height - -> LBS.ByteString -- ^ Raw PNG data - -> SVG +embedPng + :: Double -- ^ Width + -> Double -- ^ Height + -> LBS.ByteString -- ^ Raw PNG data + -> SVG -- embedPng w h png = unsafePerformIO $ do -- LBS.writeFile path png -- return $ ImageTree $ defaultSvg @@ -124,14 +170,19 @@ -- & Svg.imageHref .~ ("file://"++path) -- where -- path = "/tmp" show (hash png) <.> "png" -embedPng w h png = flipYAxis $ - ImageTree $ defaultSvg - & Svg.imageCornerUpperLeft .~ (Svg.Num (-w/2), Svg.Num (-h/2)) - & Svg.imageWidth .~ Svg.Num w - & Svg.imageHeight .~ Svg.Num h - & Svg.imageHref .~ ("data:image/png;base64," ++ imgData) - where - imgData = LBS.unpack $ Base64.encode png +embedPng w h png = + flipYAxis + $ ImageTree + $ defaultSvg + & Svg.imageCornerUpperLeft + .~ (Svg.Num (-w / 2), Svg.Num (-h / 2)) + & Svg.imageWidth + .~ Svg.Num w + & Svg.imageHeight + .~ Svg.Num h + & Svg.imageHref + .~ ("data:image/png;base64," ++ imgData) + where imgData = LBS.unpack $ Base64.encode png {-# INLINE embedDynamicImage #-} @@ -141,13 +192,12 @@ -- using with 'scaleToSize'. embedDynamicImage :: DynamicImage -> SVG embedDynamicImage img = embedPng width height imgData - where - width = fromIntegral $ dynamicMap imageWidth img - height = fromIntegral $ dynamicMap imageHeight img - imgData = - case encodeDynamicPng img of - Left err -> error err - Right dat -> dat + where + width = fromIntegral $ dynamicMap imageWidth img + height = fromIntegral $ dynamicMap imageHeight img + imgData = case encodeDynamicPng img of + Left err -> error err + Right dat -> dat -- embedImageFile :: FilePath -> Tree -- embedImageFile path = unsafePerformIO $ do @@ -171,15 +221,16 @@ raster = rasterSized 2560 1440 -- | Convert an SVG object to a pixel-based image. -rasterSized :: Int -- ^ X resolution in pixels - -> Int -- ^ Y resolution in pixels - -> SVG -- ^ SVG object - -> DynamicImage +rasterSized + :: Width -- ^ X resolution in pixels + -> Height -- ^ Y resolution in pixels + -> SVG -- ^ SVG object + -> DynamicImage rasterSized w h svg = unsafePerformIO $ do - png <- B.readFile (svgAsPngFile' w h svg) - case decodePng png of - Left{} -> error "bad image" - Right img -> return img + png <- B.readFile (svgAsPngFile' w h svg) + case decodePng png of + Left{} -> error "bad image" + Right img -> return img -- | Use 'potrace' to trace edges in a raster image and convert them to SVG polygons. vectorize :: FilePath -> SVG @@ -188,29 +239,27 @@ -- | Same as 'vectorize' but takes a list of arguments for 'potrace'. vectorize_ :: [String] -> FilePath -> SVG vectorize_ _ path | pNoExternals = mkText $ T.pack path -vectorize_ args path = unsafePerformIO $ do - root <- getXdgDirectory XdgCache "reanimate" - createDirectoryIfMissing True root - let svgPath = root show key <.> "svg" - hit <- doesFileExist svgPath - unless hit $ - withSystemTempFile "file.svg" $ \tmpSvgPath svgH -> - withSystemTempFile "file.bmp" $ \tmpBmpPath bmpH -> do - hClose svgH - hClose bmpH - potrace <- requireExecutable "potrace" - convert <- requireExecutable "convert" - runCmd convert [ path, "-flatten", tmpBmpPath ] - runCmd potrace (args ++ ["--svg", "--output", tmpSvgPath, tmpBmpPath]) - renameOrCopyFile tmpSvgPath svgPath - svg_data <- B.readFile svgPath - case parseSvgFile svgPath svg_data of - Nothing -> do - removeFile svgPath - error "Malformed svg" - Just svg -> return $ unbox $ replaceUses svg - where - key = hash (path, args) +vectorize_ args path = unsafePerformIO $ do + root <- getXdgDirectory XdgCache "reanimate" + createDirectoryIfMissing True root + let svgPath = root show key <.> "svg" + hit <- doesFileExist svgPath + unless hit $ withSystemTempFile "file.svg" $ \tmpSvgPath svgH -> + withSystemTempFile "file.bmp" $ \tmpBmpPath bmpH -> do + hClose svgH + hClose bmpH + potrace <- requireExecutable "potrace" + magick <- requireExecutable magickCmd + runCmd magick [path, "-flatten", tmpBmpPath] + runCmd potrace (args ++ ["--svg", "--output", tmpSvgPath, tmpBmpPath]) + renameOrCopyFile tmpSvgPath svgPath + svg_data <- B.readFile svgPath + case parseSvgFile svgPath svg_data of + Nothing -> do + removeFile svgPath + error "Malformed svg" + Just svg -> return $ unbox $ replaceUses svg + where key = hash (path, args) -- imageAsFile :: DynamicImage -> FilePath -- imageAsFile img @@ -221,22 +270,26 @@ -- flag in the driver. svgAsPngFile :: SVG -> FilePath svgAsPngFile = svgAsPngFile' width height - where - width = 2560 - height = width * 9 `div` 16 + where + width = 2560 + height = width * 9 `div` 16 -- | Convert an SVG object to a pixel-based image and save it to disk, returning -- the filepath. -svgAsPngFile' :: Int -- ^ Width - -> Int -- ^ Height - -> SVG -- ^ SVG object - -> FilePath +svgAsPngFile' + :: Width -- ^ Width + -> Height -- ^ Height + -> SVG -- ^ SVG object + -> FilePath svgAsPngFile' _ _ _ | pNoExternals = "/svgAsPngFile/has/been/disabled" -svgAsPngFile' width height svg = unsafePerformIO $ cacheFile template $ \pngPath -> do +svgAsPngFile' width height svg = + unsafePerformIO $ cacheFile template $ \pngPath -> do let svgPath = replaceExtension pngPath "svg" writeFile svgPath rendered engine <- requireRaster pRaster applyRaster engine svgPath - where - template = show (hash rendered) <.> "png" - rendered = renderSvg (Just $ Px $ fromIntegral width) (Just $ Px $ fromIntegral height) svg + where + template = show (hash rendered) <.> "png" + rendered = renderSvg (Just $ Px $ fromIntegral width) + (Just $ Px $ fromIntegral height) + svg diff --git a/src/Reanimate/Render.hs b/src/Reanimate/Render.hs --- a/src/Reanimate/Render.hs +++ b/src/Reanimate/Render.hs @@ -13,179 +13,274 @@ import Control.Concurrent import Control.Exception -import Control.Monad (forM_, void, unless, forever) -import qualified Data.Text as T -import qualified Data.Text.IO as T +import Control.Monad (forM_, forever, unless, void, when) +import Data.Either +import Data.Function +import qualified Data.Text as T +import qualified Data.Text.IO as T import Data.Time -import Data.Either -import Graphics.SvgTree (Number (..)) +import Graphics.SvgTree (Number (..)) import Numeric import Reanimate.Animation +import Reanimate.Driver.Check +import Reanimate.Driver.Magick import Reanimate.Misc import Reanimate.Parameters -import Reanimate.Driver.Check +import System.Console.ANSI.Codes import System.Exit -import System.FilePath (()) -import System.FilePath (replaceExtension) +import System.FilePath ((), replaceExtension) import System.IO -import Text.Printf (printf) +import Text.Printf (printf) renderSvgs :: Animation -> IO () renderSvgs ani = do - print frameCount - lock <- newMVar () - - handle errHandler $ concurrentForM_ (frameOrder rate frameCount) $ \nth -> do - let -- frame = frameAt (recip (fromIntegral rate-1) * fromIntegral nth) ani - now = (duration ani / (fromIntegral frameCount-1)) * fromIntegral nth - frame = frameAt (if frameCount<=1 then 0 else now) ani - svg = renderSvg Nothing Nothing frame - _ <- evaluate (length svg) - withMVar lock $ \_ -> do - putStr (show nth) - T.putStrLn $ T.concat . T.lines . T.pack $ svg - hFlush stdout - where - rate = 60 - frameCount = round (duration ani * fromIntegral rate) :: Int - errHandler (ErrorCall msg) = do - hPutStrLn stderr msg - exitWith (ExitFailure 1) + print frameCount + lock <- newMVar () --- XXX: Merge with 'renderSvgs' -renderSnippets :: Animation -> IO () -renderSnippets ani = - forM_ [0..frameCount-1] $ \nth -> do - let now = (duration ani / (fromIntegral frameCount-1)) * fromIntegral nth - frame = frameAt now ani - svg = renderSvg Nothing Nothing frame + handle errHandler $ concurrentForM_ (frameOrder rate frameCount) $ \nth -> do + let -- frame = frameAt (recip (fromIntegral rate-1) * fromIntegral nth) ani + now = (duration ani / (fromIntegral frameCount - 1)) * fromIntegral nth + frame = frameAt (if frameCount <= 1 then 0 else now) ani + svg = renderSvg Nothing Nothing frame + _ <- evaluate (length svg) + withMVar lock $ \_ -> do putStr (show nth) T.putStrLn $ T.concat . T.lines . T.pack $ svg - where - frameCount = 50 :: Integer + hFlush stdout + where + rate = 60 + frameCount = round (duration ani * fromIntegral rate) :: Int + errHandler (ErrorCall msg) = do + hPutStrLn stderr msg + exitWith (ExitFailure 1) +-- XXX: Merge with 'renderSvgs' +renderSnippets :: Animation -> IO () +renderSnippets ani = forM_ [0 .. frameCount - 1] $ \nth -> do + let now = (duration ani / (fromIntegral frameCount - 1)) * fromIntegral nth + frame = frameAt now ani + svg = renderSvg Nothing Nothing frame + putStr (show nth) + T.putStrLn $ T.concat . T.lines . T.pack $ svg + where frameCount = 10 :: Integer + frameOrder :: Int -> Int -> [Int] frameOrder fps nFrames = worker [] fps - where - worker _seen 0 = [] - worker seen nthFrame = - filterFrameList seen nthFrame nFrames ++ - worker (nthFrame : seen) (nthFrame `div` 2) + where + worker _seen 0 = [] + worker seen nthFrame = filterFrameList seen nthFrame nFrames + ++ worker (nthFrame : seen) (nthFrame `div` 2) filterFrameList :: [Int] -> Int -> Int -> [Int] -filterFrameList seen nthFrame nFrames = - filter (not.isSeen) [0, nthFrame .. nFrames-1] - where - isSeen x = any (\y -> x `mod` y == 0) seen +filterFrameList seen nthFrame nFrames = filter (not . isSeen) + [0, nthFrame .. nFrames - 1] + where isSeen x = any (\y -> x `mod` y == 0) seen data Format = RenderMp4 | RenderGif | RenderWebm deriving (Show) -render :: Animation - -> FilePath - -> Raster - -> Format - -> Width - -> Height - -> FPS - -> IO () -render ani target raster format width height fps = do +mp4Arguments :: FPS -> FilePath -> FilePath -> FilePath -> [String] +mp4Arguments fps progress template target = + [ "-r" + , show fps + , "-i" + , template + , "-y" + , "-c:v" + , "libx264" + , "-vf" + , "fps=" ++ show fps + , "-preset" + , "slow" + , "-crf" + , "18" + , "-movflags" + , "+faststart" + , "-progress" + , progress + , "-pix_fmt" + , "yuv420p" + , target + ] + +-- gifArguments :: FPS -> FilePath -> FilePath -> FilePath -> [String] +-- gifArguments fps progress template target = + +render + :: Animation + -> FilePath + -> Raster + -> Format + -> Width + -> Height + -> FPS + -> Bool + -> IO () +render ani target raster format width height fps partial = do printf "Starting render of animation: %.1f\n" (duration ani) ffmpeg <- requireExecutable "ffmpeg" - generateFrames raster ani width height fps $ \template -> - withTempFile "txt" $ \progress -> writeFile progress "" >> - case format of - RenderMp4 -> - runCmd ffmpeg ["-r", show fps, "-i", template, "-y" - , "-c:v", "libx264", "-vf", "fps="++show fps - , "-preset", "slow" - , "-crf", "18" - , "-movflags", "+faststart" - , "-progress", progress - , "-pix_fmt", "yuv420p", target] - RenderGif -> withTempFile "png" $ \palette -> do - runCmd ffmpeg ["-i", template, "-y" - ,"-vf", "fps="++show fps++ - ",scale="++show width++":"++show height ++ - ":flags=lanczos,palettegen" - ,"-t", showFFloat Nothing (duration ani) "" - , palette ] - runCmd ffmpeg ["-framerate", show fps,"-i", template, "-y" - ,"-i", palette - ,"-progress", progress - ,"-filter_complex" - ,"fps="++show fps++ - ",scale="++show width++":"++show height ++ - ":flags=lanczos[x];[x][1:v]paletteuse" - ,"-t", showFFloat Nothing (duration ani) "" - , target] - RenderWebm -> - runCmd ffmpeg ["-r", show fps, "-i", template, "-y" - ,"-progress", progress - , "-c:v", "libvpx-vp9", "-vf", "fps="++show fps - , target] + generateFrames raster ani width height fps partial $ \template -> + withTempFile "txt" $ \progress -> do + writeFile progress "" + progressH <- openFile progress ReadMode + hSetBuffering progressH NoBuffering + allFinished <- newEmptyMVar + void $ forkIO $ do + progressPrinter "rendered" (animationFrameCount ani fps) + $ \done -> fix $ \loop -> do + eof <- hIsEOF progressH + if eof + then threadDelay 1000000 >> loop + else do + l <- try (hGetLine progressH) + case l of + Left SomeException{} -> return () + Right str -> + case take 6 str of + "frame=" -> do + void $ swapMVar done (read (drop 6 str)) + loop + _ | str == "progress=end" -> return () + _ -> loop + putMVar allFinished () + case format of + RenderMp4 -> runCmd ffmpeg (mp4Arguments fps progress template target) + RenderGif -> withTempFile "png" $ \palette -> do + runCmd + ffmpeg + [ "-i" + , template + , "-y" + , "-vf" + , "fps=" + ++ show fps + ++ ",scale=" + ++ show width + ++ ":" + ++ show height + ++ ":flags=lanczos,palettegen" + , "-t" + , showFFloat Nothing (duration ani) "" + , palette + ] + runCmd + ffmpeg + [ "-framerate" + , show fps + , "-i" + , template + , "-y" + , "-i" + , palette + , "-progress" + , progress + , "-filter_complex" + , "fps=" + ++ show fps + ++ ",scale=" + ++ show width + ++ ":" + ++ show height + ++ ":flags=lanczos[x];[x][1:v]paletteuse" + , "-t" + , showFFloat Nothing (duration ani) "" + , target + ] + RenderWebm -> runCmd + ffmpeg + [ "-r" + , show fps + , "-i" + , template + , "-y" + , "-progress" + , progress + , "-c:v" + , "libvpx-vp9" + , "-vf" + , "fps=" ++ show fps + , target + ] + takeMVar allFinished --------------------------------------------------------------------------------- -- Helpers -generateFrames :: Raster -> Animation -> Width -> Height -> FPS -> (FilePath -> IO a) -> IO a -generateFrames raster ani width_ height_ rate action = withTempDir $ \tmp -> do - setRootDirectory tmp - done <- newMVar (0::Int) - let frameName nth = tmp printf nameTemplate nth - putStr $ "\rFrames rendered: 0/" ++ show frameCount ++ "\27[K\r" - hFlush stdout - start <- getCurrentTime - let statusPrinter = forever $ do - nDone <- readMVar done - now <- getCurrentTime - let spent = diffUTCTime now start - remaining = (spent / (fromIntegral nDone / fromIntegral frameCount)) - spent - putStr $ "\rFrames rendered: " ++ show nDone ++ "/" ++ show frameCount - putStr $ ", time spent: " ++ ppDiff spent - unless (nDone==0) $ do - putStr $ ", time remaining: " ++ ppDiff remaining - putStr $ ", total time: " ++ ppDiff (remaining+spent) - putStr $ "\27[K\r" - hFlush stdout - threadDelay 1000000 - withBackgroundThread statusPrinter $ do - handle h $ concurrentForM_ frames $ \n -> do +progressPrinter :: String -> Int -> (MVar Int -> IO ()) -> IO () +progressPrinter typeName maxCount action = do + printf "\rFrames %s: 0/%d" typeName maxCount + putStr $ clearFromCursorToLineEndCode ++ "\r" + done <- newMVar (0 :: Int) + start <- getCurrentTime + let bgThread = forever $ do + nDone <- readMVar done + now <- getCurrentTime + let spent = diffUTCTime now start + remaining = + (spent / (fromIntegral nDone / fromIntegral maxCount)) - spent + printf "\rFrames %s: %d/%d" typeName nDone maxCount + putStr $ ", time spent: " ++ ppDiff spent + unless (nDone == 0) $ do + putStr $ ", time remaining: " ++ ppDiff remaining + putStr $ ", total time: " ++ ppDiff (remaining + spent) + putStr $ clearFromCursorToLineEndCode ++ "\r" + hFlush stdout + threadDelay 1000000 + withBackgroundThread bgThread $ action done + now <- getCurrentTime + let spent = diffUTCTime now start + printf "\rFrames %s: %d/%d" typeName maxCount maxCount + putStr $ ", time spent: " ++ ppDiff spent + putStr $ clearFromCursorToLineEndCode ++ "\n" + +animationFrameCount :: Animation -> FPS -> Int +animationFrameCount ani rate = round (duration ani * fromIntegral rate) :: Int + +generateFrames + :: Raster -> Animation -> Width -> Height -> FPS -> Bool -> (FilePath -> IO a) -> IO a +generateFrames raster ani width_ height_ rate partial action = withTempDir $ \tmp -> do + let frameName nth = tmp printf nameTemplate nth + setRootDirectory tmp + progressPrinter "generated" frameCount + $ \done -> handle h $ concurrentForM_ frames $ \n -> do writeFile (frameName n) $ renderSvg width height $ nthFrame n + modifyMVar_ done $ \nDone -> return (nDone + 1) + + when (raster /= RasterNone) + $ progressPrinter "rastered" frameCount + $ \done -> handle h $ concurrentForM_ frames $ \n -> do applyRaster raster (frameName n) - modifyMVar_ done $ \nDone -> return (nDone+1) - now <- getCurrentTime - let spent = diffUTCTime now start - putStr $ "\rFrames rendered: " ++ show frameCount ++ "/" ++ show frameCount - putStr $ ", time spent: " ++ ppDiff spent - putStr $ "\27[K\n" - action (tmp rasterTemplate raster) - where - width = Just $ Px $ fromIntegral width_ - height = Just $ Px $ fromIntegral height_ - h UserInterrupt = do - hPutStrLn stderr "\nCtrl-C detected. Trying to generate video with available frames. \ + modifyMVar_ done $ \nDone -> return (nDone + 1) + + action (tmp rasterTemplate raster) + where + + width = Just $ Px $ fromIntegral width_ + height = Just $ Px $ fromIntegral height_ + h UserInterrupt | partial = do + hPutStrLn + stderr + "\nCtrl-C detected. Trying to generate video with available frames. \ \Hit ctrl-c again to abort." - return () - h other = throwIO other - -- frames = [0..frameCount-1] - frames = frameOrder rate frameCount - nthFrame nth = frameAt (recip (fromIntegral rate) * fromIntegral nth) ani - frameCount = round (duration ani * fromIntegral rate) :: Int - nameTemplate :: String - nameTemplate = "render-%05d.svg" + return () + h other = throwIO other + -- frames = [0..frameCount-1] + frames = frameOrder rate frameCount + nthFrame nth = frameAt (recip (fromIntegral rate) * fromIntegral nth) ani + frameCount = animationFrameCount ani rate + nameTemplate :: String + nameTemplate = "render-%05d.svg" withBackgroundThread :: IO () -> IO a -> IO a withBackgroundThread t = bracket (forkIO t) killThread . const ppDiff :: NominalDiffTime -> String -ppDiff diff - | hours == 0 && mins == 0 = show secs ++ "s" - | hours == 0 = printf "%.2d:%.2d" mins secs - | otherwise = printf "%.2d:%.2d:%.2d" hours mins secs - where - (osecs, secs) = round diff `divMod` (60::Int) - (hours, mins) = osecs `divMod` 60 +ppDiff diff | hours == 0 && mins == 0 = show secs ++ "s" + | hours == 0 = printf "%.2d:%.2d" mins secs + | otherwise = printf "%.2d:%.2d:%.2d" hours mins secs + where + (osecs, secs) = round diff `divMod` (60 :: Int) + (hours, mins) = osecs `divMod` 60 rasterTemplate :: Raster -> String rasterTemplate RasterNone = "render-%05d.svg" @@ -193,10 +288,11 @@ requireRaster :: Raster -> IO Raster requireRaster raster = do - raster' <- selectRaster (if raster==RasterNone then RasterAuto else raster) + raster' <- selectRaster (if raster == RasterNone then RasterAuto else raster) case raster' of RasterNone -> do - hPutStrLn stderr + hPutStrLn + stderr "Raster required but none could be found. \ \Please install either inkscape, imagemagick, or rsvg-convert." exitWith (ExitFailure 1) @@ -204,43 +300,46 @@ selectRaster :: Raster -> IO Raster selectRaster RasterAuto = do - rsvg <- hasRSvg - ink <- hasInkscape - conv <- hasConvert - if | isRight rsvg -> pure RasterRSvg - | isRight ink -> pure RasterInkscape - | isRight conv -> pure RasterConvert - | otherwise -> pure RasterNone + rsvg <- hasRSvg + ink <- hasInkscape + magick <- hasMagick + if + | isRight rsvg -> pure RasterRSvg + | isRight ink -> pure RasterInkscape + | isRight magick -> pure RasterMagick + | otherwise -> pure RasterNone selectRaster r = pure r applyRaster :: Raster -> FilePath -> IO () -applyRaster RasterNone _ = return () -applyRaster RasterAuto _ = return () -applyRaster RasterInkscape path = - runCmd "inkscape" - [ "--without-gui" - , "--file=" ++ path - , "--export-png=" ++ replaceExtension path "png" ] -applyRaster RasterRSvg path = - runCmd "rsvg-convert" - [ path - , "--unlimited" - , "--output", replaceExtension path "png" ] -applyRaster RasterConvert path = - runCmd "convert" - [ path - , replaceExtension path "png" ] +applyRaster RasterNone _ = return () +applyRaster RasterAuto _ = return () +applyRaster RasterInkscape path = runCmd + "inkscape" + [ "--without-gui" + , "--file=" ++ path + , "--export-png=" ++ replaceExtension path "png" + ] +applyRaster RasterRSvg path = runCmd + "rsvg-convert" + [path, "--unlimited", "--output", replaceExtension path "png"] +applyRaster RasterMagick path = + runCmd magickCmd [path, replaceExtension path "png"] concurrentForM_ :: [a] -> (a -> IO ()) -> IO () concurrentForM_ lst action = do - n <- getNumCapabilities - sem <- newQSemN n + n <- getNumCapabilities + sem <- newQSemN n eVar <- newEmptyMVar forM_ lst $ \elt -> do waitQSemN sem 1 emp <- isEmptyMVar eVar if emp - then void $ forkIO (catch (action elt) (void . tryPutMVar eVar) `finally` signalQSemN sem 1) + then + void + $ forkIO + ( catch (action elt) (void . tryPutMVar eVar) + `finally` signalQSemN sem 1 + ) else signalQSemN sem 1 waitQSemN sem n mbE <- tryTakeMVar eVar diff --git a/src/Reanimate/Scene.hs b/src/Reanimate/Scene.hs --- a/src/Reanimate/Scene.hs +++ b/src/Reanimate/Scene.hs @@ -1,5 +1,8 @@ -{-# LANGUAGE ApplicativeDo #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE RecordWildCards #-} {-| Module : Reanimate.Scene Description : Imperative animation API @@ -55,21 +58,97 @@ , spriteVar -- :: Sprite s -> a -> (a -> SVG -> SVG) -> Scene s (Var s a) , spriteE -- :: Sprite s -> Effect -> Scene s () , spriteZ -- :: Sprite s -> ZIndex -> Scene s () + , spriteScope -- :: Scene s a -> Scene s a + -- * Object API + , Renderable(..) + , Object + , ObjectData + , oTranslate + , oSVG + , oContext + , oMargin + , oMarginTop + , oMarginRight + , oMarginBottom + , oMarginLeft + , oBB + , oBBMinX + , oBBMinY + , oBBWidth + , oBBHeight + , oOpacity + , oShown + , oZIndex + , oEasing + , oScale + , oScaleOrigin + , oTopY + , oBottomY + , oLeftX + , oRightX + , oCenterXY + , newObject + , oValue + , oModify + , oModifyS + , oRead + , oTween + , oTweenS + , oTweenV + , oTweenVS + + -- ** Graphics object methods + , oShow + , oHide + , oFadeIn + , oFadeOut + , oGrow + , oShrink + , oTransform + + -- ** Pre-defined objects + , Circle(..) + , circleRadius + , Rectangle(..) + , rectWidth + , rectHeight + , Morph(..) + , morphDelta + , morphSrc + , morphDst + , Camera(..) + , cameraAttach + , cameraFocus + , cameraSetZoom + , cameraZoom + , cameraSetPan + , cameraPan + -- * ST internals , liftST + , asAnimation -- :: (forall s. Scene s a) -> Scene s Animation + , transitionO + , evalScene ) where -import Control.Monad ( void ) +import Control.Lens +import Control.Monad (void) import Control.Monad.Fix import Control.Monad.ST +import Control.Monad.State (execState, State) import Data.List import Data.STRef -import Graphics.SvgTree ( Tree(None) ) +import Graphics.SvgTree (Tree (None)) import Reanimate.Animation +import Reanimate.Ease (Signal, curveS, fromToS) import Reanimate.Effect import Reanimate.Svg.Constructors +import Reanimate.Svg.BoundingBox +import Reanimate.Transition +import Reanimate.Morph.Common (morph) +import Reanimate.Morph.Linear (linear) -- | The ZIndex property specifies the stack order of sprites and animations. Elements -- with a higher ZIndex will be drawn on top of elements with a lower index. @@ -107,6 +186,11 @@ liftST :: ST s a -> Scene s a liftST action = M $ \_ -> action >>= \a -> return (a, 0, 0, []) +evalScene :: (forall s . Scene s a) -> a +evalScene action = runST $ do + (val, _, _ , _) <- unM action 0 + return val + sceneAnimation :: (forall s . Scene s a) -> Animation sceneAnimation action = runST (do @@ -254,7 +338,10 @@ tweenVar :: Var s a -> Duration -> (a -> Time -> a) -> Scene s () tweenVar (Var ref) dur fn = do now <- queryNow - liftST $ modifySTRef ref $ \prev t -> fn (prev t) (max 0 (min dur $ t - now) / dur) + liftST $ modifySTRef ref $ \prev t -> + if t < now + then prev t + else fn (prev t) (max 0 (min dur $ t - now) / dur) wait dur -- | Modify a variable between @now@ and @now+duration@. @@ -351,9 +438,16 @@ return $ \d absT -> let relD = (if spriteDur < 0 then d else spriteDur) - now relT = absT - now - in if relT < 0 || (relD + now /= d && relD <= relT) - then (None, 0) - else spriteEffect relD relT (fn absT relD relT) + -- Sprite is live [now;duration[ + -- If we're at the end of a scene, sprites + -- are live: [now;duration] + -- This behavior is difficult to get right. See the 'bug_*' examples for + -- automated tests. + inTimeSlice = relT >= 0 && relT < relD + isLastFrame = d==absT && relT == relD + in if inTimeSlice || isLastFrame + then spriteEffect relD relT (fn absT relD relT) + else (None, 0) return $ Sprite now ref -- | Create new sprite defined by a frame generator. The sprite will die at @@ -548,3 +642,376 @@ return $ \d t svg -> let (svg', z) = render d t svg in (svg', if t < now - born then z else zindex) ) + +-- Destroy all local sprites at the end of a scene. +spriteScope :: Scene s a -> Scene s a +spriteScope (M action) = M $ \t -> do + (a, s, p, gens) <- action t + return (a, s, p, map (genFn (t+max s p)) gens) + where + genFn maxT gen = do + frameGen <- gen + return $ \_ t -> + if t < maxT + then frameGen maxT t + else (None, 0) + +asAnimation :: (forall s'. Scene s' a) -> Scene s Animation +asAnimation scene = do + now <- queryNow + return $ dropA now (sceneAnimation (wait now >> scene)) + +transitionO :: Transition -> Double -> (forall s'. Scene s' a) -> (forall s'. Scene s' b) -> Scene s () +transitionO t o a b = do + aA <- asAnimation a + bA <- fork $ do + wait (duration aA - o) + asAnimation b + play $ overlapT o t aA bA + + + + +------------------------------------------------------- +-- Objects + +class Renderable a where + toSVG :: a -> SVG + +instance Renderable Tree where + toSVG = id + +data Object s a = Object + { objectSprite :: Sprite s + , objectData :: Var s (ObjectData a) + } +data ObjectData a = ObjectData + { _oTranslate :: (Double, Double) + , _oValueRef :: a + , _oSVG :: SVG + , _oContext :: SVG -> SVG + , _oMargin :: (Double, Double, Double, Double) + -- ^ Top, right, bottom, left + , _oBB :: (Double,Double,Double,Double) + , _oOpacity :: Double + , _oShown :: Bool + , _oZIndex :: Int + , _oEasing :: Signal + , _oScale :: Double + , _oScaleOrigin :: (Double, Double) + } + +-- Basic lenses + +oTranslate :: Lens' (ObjectData a) (Double, Double) +oTranslate = lens _oTranslate $ \obj val -> obj { _oTranslate = val } + +oSVG :: Getter (ObjectData a) SVG +oSVG = to _oSVG + +oContext :: Lens' (ObjectData a) (SVG -> SVG) +oContext = lens _oContext $ \obj val -> obj { _oContext = val } + +oMargin :: Lens' (ObjectData a) (Double, Double, Double, Double) +oMargin = lens _oMargin $ \obj val -> obj { _oMargin = val } + +oBB :: Getter (ObjectData a) (Double, Double, Double, Double) +oBB = to _oBB + +oOpacity :: Lens' (ObjectData a) Double +oOpacity = lens _oOpacity $ \obj val -> obj { _oOpacity = val } + +oShown :: Lens' (ObjectData a) Bool +oShown = lens _oShown $ \obj val -> obj { _oShown = val } + +oZIndex :: Lens' (ObjectData a) Int +oZIndex = lens _oZIndex $ \obj val -> obj { _oZIndex = val } + +oEasing :: Lens' (ObjectData a) Signal +oEasing = lens _oEasing $ \obj val -> obj { _oEasing = val } + +oScale :: Lens' (ObjectData a) Double +oScale = lens _oScale $ \obj val -> obj { _oScale = val } + +oScaleOrigin :: Lens' (ObjectData a) (Double, Double) +oScaleOrigin = lens _oScaleOrigin $ \obj val -> obj { _oScaleOrigin = val } + +-- Smart lenses + +oValue :: Renderable a => Lens' (ObjectData a) a +oValue = lens _oValueRef $ \obj newVal -> + let svg = toSVG newVal + in obj + { _oValueRef = newVal + , _oSVG = svg + , _oBB = boundingBox svg } + +oTopY :: Lens' (ObjectData a) Double +oTopY = lens getter setter + where + getter obj = + let top = obj ^. oMarginTop + miny = obj ^. oBBMinY + h = obj ^. oBBHeight + dy = obj ^. oTranslate . _2 + in dy+miny+h+top + setter obj val = + obj & (oTranslate . _2) +~ val-getter obj + +oBottomY :: Lens' (ObjectData a) Double +oBottomY = lens getter setter + where + getter obj = + let bot = obj ^. oMarginBottom + miny = obj ^. oBBMinY + dy = obj ^. oTranslate . _2 + in dy+miny-bot + setter obj val = + obj & (oTranslate . _2) +~ val-getter obj + +oLeftX :: Lens' (ObjectData a) Double +oLeftX = lens getter setter + where + getter obj = + let left = obj ^. oMarginLeft + minx = obj ^. oBBMinX + dx = obj ^. oTranslate . _1 + in dx+minx-left + setter obj val = + obj & (oTranslate . _1) +~ val-getter obj + +oRightX :: Lens' (ObjectData a) Double +oRightX = lens getter setter + where + getter obj = + let right = obj ^. oMarginRight + minx = obj ^. oBBMinX + w = obj ^. oBBWidth + dx = obj ^. oTranslate . _1 + in dx+minx+w+right + setter obj val = + obj & (oTranslate . _1) +~ val-getter obj + +oCenterXY :: Lens' (ObjectData a) (Double, Double) +oCenterXY = lens getter setter + where + getter obj = + let minx = obj ^. oBBMinX + miny = obj ^. oBBMinY + w = obj ^. oBBWidth + h = obj ^. oBBHeight + (dx,dy) = obj ^. oTranslate + in (dx+minx+w/2, dy+miny+h/2) + setter obj (dx, dy) = + let (x,y) = getter obj in + obj & (oTranslate . _1) +~ dx-x + & (oTranslate . _2) +~ dy-y + +oMarginTop :: Lens' (ObjectData a) Double +oMarginTop = oMargin . _1 + +oMarginRight :: Lens' (ObjectData a) Double +oMarginRight = oMargin . _2 + +oMarginBottom :: Lens' (ObjectData a) Double +oMarginBottom = oMargin . _3 + +oMarginLeft :: Lens' (ObjectData a) Double +oMarginLeft = oMargin . _4 + +oBBMinX :: Getter (ObjectData a) Double +oBBMinX = oBB . _1 + +oBBMinY :: Getter (ObjectData a) Double +oBBMinY = oBB . _2 + +oBBWidth :: Getter (ObjectData a) Double +oBBWidth = oBB . _3 + +oBBHeight :: Getter (ObjectData a) Double +oBBHeight = oBB . _4 + +oModify :: Object s a -> (ObjectData a -> ObjectData a) -> Scene s () +oModify o fn = modifyVar (objectData o) fn + +oModifyS :: Object s a -> (State (ObjectData a) b) -> Scene s () +oModifyS o fn = oModify o (execState fn) + +oRead :: Object s a -> Getting b (ObjectData a) b -> Scene s b +oRead o l = do + v <- readVar (objectData o) + return $ view l v + +oTween :: Object s a -> Duration -> (Double -> ObjectData a -> ObjectData a) -> Scene s () +oTween o d fn = do + -- Read 'easing' var here instead of taking it from 'v'. + -- This allows different easing functions even at the same timestamp. + ease <- oRead o oEasing + tweenVar (objectData o) d (\v t -> fn (ease t) v) + -- tweenVar ref d (\v t -> fn t v) + +-- oTweenS :: Object s a -> Duration -> (Double -> ObjectData a -> ObjectData a) -> Scene s () +oTweenS :: Object s a -> Duration -> (Double -> State (ObjectData a) b) -> Scene s () +oTweenS o d fn = oTween o d (\t -> execState (fn t)) + +oTweenV :: Renderable a => Object s a -> Duration -> (Double -> a -> a) -> Scene s () +oTweenV o d fn = oTween o d (\t -> oValue %~ fn t) + +oTweenVS :: Renderable a => Object s a -> Duration -> (Double -> State a b) -> Scene s () +oTweenVS o d fn = oTween o d (\t -> oValue %~ execState (fn t)) + +newObject :: Renderable a => a -> Scene s (Object s a) +newObject val = do + ref <- newVar ObjectData + { _oTranslate = (0,0) + , _oValueRef = val + , _oSVG = svg + , _oContext = id + , _oMargin = (0.5,0.5,0.5,0.5) + , _oBB = boundingBox svg + , _oOpacity = 1 + , _oShown = False + , _oZIndex = 1 + , _oEasing = curveS 2 + , _oScale = 1 + , _oScaleOrigin = (0,0) + } + sprite <- newSprite $ do + ~ObjectData{..} <- unVar ref + pure $ + if _oShown + then + uncurry translate _oTranslate $ + uncurry translate (_oScaleOrigin & both %~ negate) $ + scale _oScale $ + uncurry translate _oScaleOrigin $ + withGroupOpacity _oOpacity $ + _oContext _oSVG + else None + return Object + { objectSprite = sprite + , objectData = ref } + where + svg = toSVG val + +newtype Circle = Circle {_circleRadius :: Double} +instance Renderable Circle where + toSVG (Circle r) = mkCircle r + +data Rectangle = Rectangle { _rectWidth :: Double, _rectHeight :: Double } +instance Renderable Rectangle where + toSVG (Rectangle w h) = mkRect w h + +data Morph = Morph { _morphDelta :: Double, _morphSrc :: SVG, _morphDst :: SVG } +instance Renderable Morph where + toSVG (Morph t src dst) = morph linear src dst t + +data Camera = Camera +instance Renderable Camera where + toSVG Camera = None + +cameraAttach :: Object s Camera -> Object s a -> Scene s () +cameraAttach cam obj = + spriteModify (objectSprite obj) $ do + camData <- unVar (objectData cam) + return $ \(svg,zindex) -> + let (x,y) = camData^.oTranslate + ctx = + translate (-x) (-y) . + uncurry translate (camData^.oScaleOrigin) . + scale (camData^.oScale) . + uncurry translate (camData^.oScaleOrigin & both %~ negate) + in (ctx svg, zindex) + +cameraFocus :: Object s Camera -> (Double, Double) -> Scene s () +cameraFocus cam (x,y) = do + (ox, oy) <- oRead cam oScaleOrigin + (tx, ty) <- oRead cam oTranslate + s <- oRead cam oScale + let newLocation = (x-((x-ox)*s+ox-tx), y-((y-oy)*s+oy-ty)) + oModifyS cam $ do + oTranslate .= newLocation + oScaleOrigin .= (x,y) + +cameraSetZoom :: Object s Camera -> Double -> Scene s () +cameraSetZoom cam s = + oModifyS cam $ + oScale .= s + +cameraZoom :: Object s Camera -> Duration -> Double -> Scene s () +cameraZoom cam d s = + oTweenS cam d $ \t -> + oScale %= \v -> fromToS v s t + +cameraSetPan :: Object s Camera -> (Double, Double) -> Scene s () +cameraSetPan cam location = + oModifyS cam $ do + oTranslate .= location + +cameraPan :: Object s Camera -> Duration -> (Double, Double) -> Scene s () +cameraPan cam d (x,y) = + oTweenS cam d $ \t -> do + oTranslate._1 %= \v -> fromToS v x t + oTranslate._2 %= \v -> fromToS v y t + +makeLenses ''Circle +makeLenses ''Rectangle +makeLenses ''Morph + +oShow :: Object s a -> Scene s () +oShow o = oModify o $ oShown .~ True + +oHide :: Object s a -> Scene s () +oHide o = oModify o $ oShown .~ False + +oFadeIn :: Object s a -> Duration -> Scene s () +oFadeIn o d = do + oModify o $ + oShown .~ True + oTweenS o d $ \t -> + oOpacity *= t + +oFadeOut :: Object s a -> Duration -> Scene s () +oFadeOut o d = do + oModify o $ + oShown .~ True + oTweenS o d $ \t -> + oOpacity *= 1-t + +oGrow :: Object s a -> Duration -> Scene s () +oGrow o d = do + oModify o $ + oShown .~ True + oTweenS o d $ \t -> + oScale *= t + +oShrink :: Object s a -> Duration -> Scene s () +oShrink o d = + oTweenS o d $ \t -> + oScale *= 1-t + +-- FIXME: Also transform attributes: 'opacity', 'scale', 'scaleOrigin'. +oTransform :: Object s a -> Object s b -> Duration -> Scene s () +oTransform src dst d = do + srcSvg <- oRead src oSVG + srcCtx <- oRead src oContext + srcEase <- oRead src oEasing + srcLoc <- oRead src oTranslate + oModify src $ oShown .~ False + + dstSvg <- oRead dst oSVG + dstCtx <- oRead dst oContext + dstLoc <- oRead dst oTranslate + + m <- newObject $ Morph 0 (srcCtx srcSvg) (dstCtx dstSvg) + oModifyS m $ do + oShown .= True + oEasing .= srcEase + oTranslate .= srcLoc + fork $ oTween m d $ \t -> oTranslate %~ moveTo t dstLoc + oTweenV m d $ \t -> morphDelta .~ t + oModify m $ oShown .~ False + oModify dst $ oShown .~ True + where + moveTo t (dstX, dstY) (srcX, srcY) = + (fromToS srcX dstX t, fromToS srcY dstY t) diff --git a/src/Reanimate/Svg.hs b/src/Reanimate/Svg.hs --- a/src/Reanimate/Svg.hs +++ b/src/Reanimate/Svg.hs @@ -21,7 +21,7 @@ import qualified Reanimate.Transform as Transform lowerTransformations :: Tree -> Tree -lowerTransformations = worker Transform.identity +lowerTransformations = worker False Transform.identity where updLineCmd m cmd = case cmd of @@ -30,17 +30,30 @@ LineBezier ps -> LineBezier $ map (Transform.transformPoint m) ps LineEnd p -> LineEnd $ Transform.transformPoint m p updPath m = lineToPath . map (updLineCmd m) . toLineCommands - worker m t = + updPoint m (Num a,Num b) = + case Transform.transformPoint m (V2 a b) of + V2 x y -> (Num x, Num y) + updPoint _ other = other -- XXX: Can we do better here? + worker hasPathified m t = let m' = m * Transform.mkMatrix (t^.transform) in case t of PathTree path -> PathTree $ path & pathDefinition %~ updPath m' & transform .~ Nothing GroupTree g -> GroupTree $ - g & groupChildren %~ map (worker m') + g & groupChildren %~ map (worker hasPathified m') & transform .~ Nothing + LineTree line -> + LineTree $ + line & linePoint1 %~ updPoint m + & linePoint2 %~ updPoint m ClipPathTree{} -> t - _ -> mkGroup [t] & transform ?~ [ Transform.toTransformation m ] + -- If we encounter an unknown node and we've already tried to convert + -- to paths, give up and insert an explicit transformation. + _ | hasPathified -> + mkGroup [t] & transform ?~ [ Transform.toTransformation m ] + -- If we haven't tried to pathify, run pathify only once. + _ -> worker True m (pathify t) lowerIds :: Tree -> Tree lowerIds = mapTree worker @@ -81,7 +94,7 @@ where worker _attr None = [] worker _attr (DefinitionTree d) = - concatMap dropNulls $ + concatMap dropNulls [DefinitionTree $ d & groupChildren %~ concatMap (worker defaultSvg)] worker attr (GroupTree g) | g ^. drawAttributes == defaultSvg = diff --git a/src/Reanimate/Svg/BoundingBox.hs b/src/Reanimate/Svg/BoundingBox.hs --- a/src/Reanimate/Svg/BoundingBox.hs +++ b/src/Reanimate/Svg/BoundingBox.hs @@ -15,6 +15,10 @@ -- | Return bounding box of SVG tree. -- The four numbers returned are (minimal X-coordinate, minimal Y-coordinate, width, height) +-- +-- Note: Bounding boxes are computed on a best-effort basis and will not work +-- in all cases. The only supported SVG nodes are: path, circle, polyline, +-- ellipse, line, rectangle, image. All other nodes return (0,0,0,0). boundingBox :: Tree -> (Double, Double, Double, Double) boundingBox t = case svgBoundingPoints t of diff --git a/src/Reanimate/Svg/Unuse.hs b/src/Reanimate/Svg/Unuse.hs --- a/src/Reanimate/Svg/Unuse.hs +++ b/src/Reanimate/Svg/Unuse.hs @@ -6,6 +6,7 @@ import Control.Lens ((%~), (&), (.~), (?~), (^.)) import qualified Data.Map as Map +import Data.Maybe import Graphics.SvgTree hiding (line, path, use) import Reanimate.Constants import Reanimate.Svg.Constructors @@ -21,10 +22,12 @@ replace (UseTree use Nothing) = case Map.lookup (use^.useName) idMap of Nothing -> error $ "Unknown id: " ++ (use^.useName) - Just tree -> + Just tree -> mapTree replace $ GroupTree $ defaultSvg & groupChildren .~ [tree] - & transform ?~ [baseToTransformation (use^.useBase)] + & transform ?~ + fromMaybe [] (use^.transform) ++ + [baseToTransformation (use^.useBase)] replace x = x baseToTransformation (x,y) = case (toUserUnit defaultDPI x, toUserUnit defaultDPI y) of diff --git a/src/Reanimate/Transition.hs b/src/Reanimate/Transition.hs --- a/src/Reanimate/Transition.hs +++ b/src/Reanimate/Transition.hs @@ -21,7 +21,7 @@ -- | Map the result of a transition. mapT :: (Animation -> Animation) -> Transition -> Transition -mapT fn t = \a b -> fn (t a b) +mapT fn t a b = fn (t a b) -- | Apply transition only to @N@ seconds of the first -- animation and to the last @N@ seconds of the second animation. diff --git a/src/Reanimate/Voice.hs b/src/Reanimate/Voice.hs --- a/src/Reanimate/Voice.hs +++ b/src/Reanimate/Voice.hs @@ -10,11 +10,12 @@ module Reanimate.Voice ( Transcript(..) , TWord(..) - , findWord -- :: Transcript -> [Text] -> Text -> TWord - , findWords -- :: Transcript -> [Text] -> Text -> [TWord] - , loadTranscript -- :: FilePath -> Transcript - , fakeTranscript -- :: Text -> Transcript - , splitTranscript -- :: Transcript -> SVG -> [(SVG, TWord)] + , findWord -- :: Transcript -> [Text] -> Text -> TWord + , findWords -- :: Transcript -> [Text] -> Text -> [TWord] + , loadTranscript -- :: FilePath -> Transcript + , fakeTranscript -- :: Text -> Transcript + , splitTranscript -- :: Transcript -> SVG -> [(SVG, TWord)] + , annotateWithTranscript -- :: Transcript -> Scene s () ) where @@ -25,6 +26,7 @@ import System.FilePath import System.Process import System.Exit +import Control.Monad import Data.List import Data.Maybe import qualified Data.Map as Map @@ -32,9 +34,12 @@ import Data.Text ( Text ) import qualified Data.Text as T import qualified Data.Text.IO as T -import Reanimate.Animation ( SVG ) import Reanimate.Misc import Reanimate.LaTeX +import Reanimate.Scene +import Reanimate.Animation +import Reanimate.Svg +import Reanimate.Constants data Transcript = Transcript { transcriptText :: Text @@ -107,7 +112,7 @@ findWords t (key : keys) wd = [ tword | tword <- findWords t keys wd - , wordStartOffset tword > Map.findWithDefault badKey key (transcriptKeys t) + , wordStartOffset tword >= Map.findWithDefault badKey key (transcriptKeys t) ] where badKey = error $ "Missing transcript key: " ++ show key @@ -141,7 +146,7 @@ case mbT of Nothing -> error "bad json" Just t -> pure t - pure $ transcript { transcriptKeys = keys } + pure $ transcript { transcriptKeys = finalizeKeys keys } where jsonPath = replaceExtension path "json" audioExtensions = ["mp3", "m4a", "flac"] @@ -159,6 +164,13 @@ (T.drop newOffset txt) Just (_, cs) -> worker keys (offset + 1) cs +finalizeKeys :: Map Text Int -> Map Text Int +finalizeKeys = Map.fromList . worker 0 . sortOn snd . Map.toList + where + worker _offset [] = [] + worker offset ((key, at) : rest) = + (key, at - offset) : worker (offset + T.length key + 2) rest + cutoutKeys :: Map Text Int -> Text -> Text cutoutKeys keys = T.concat . worker 0 (sortOn snd (Map.toList keys)) where @@ -218,19 +230,20 @@ -> TokenPeriod : worker (offset + 1) cs | c == ',' -> TokenComma : worker (offset + 1) cs - | isAlphaNum c - -> let (w, rest) = T.span (\elt -> isAlphaNum elt || elt == '\'') txt + | isWord c + -> let (w, rest) = T.span isWord txt newOffset = offset + T.length w in TokenWord offset newOffset w : worker newOffset rest | otherwise -> worker (offset + 1) cs + isWord c = isAlphaNum c || c `elem` ['\'', '-'] -- | Fake transcript timings at roughly 120 words per minute. fakeTranscript :: Text -> Transcript fakeTranscript rawTranscript = let keys = parseTranscriptKeys rawTranscript t = fakeTranscript' (cutoutKeys keys rawTranscript) - in t { transcriptKeys = keys } + in t { transcriptKeys = finalizeKeys keys } fakeTranscript' :: Text -> Transcript fakeTranscript' input = Transcript { transcriptText = input @@ -241,17 +254,17 @@ worker _now [] = [] worker now (token : rest) = case token of TokenWord start end w -> - let duration = realToFrac (end - start) * 0.1 + let dur = realToFrac (end - start) * 0.1 in TWord { wordAligned = T.toLower w , wordCase = "success" , wordStart = now , wordStartOffset = start - , wordEnd = now + duration + , wordEnd = now + dur , wordEndOffset = end , wordPhones = [] , wordReference = w } - : worker (now + duration) rest + : worker (now + dur) rest TokenComma -> worker (now + commaPause) rest TokenPeriod -> worker (now + periodPause) rest TokenParagraph -> worker (now + paragraphPause) rest @@ -272,3 +285,16 @@ , T.drop wordEndOffset transcriptText ] ] + +annotateWithTranscript :: Transcript -> Scene s () +annotateWithTranscript t = forM_ (transcriptWords t) $ \tword -> do + let svg = scale 1 $ latex (wordReference tword) + waitUntil (wordStart tword) + let dur = wordEnd tword - wordStart tword + play $ staticFrame dur $ position $ outline svg + where + position = translate (-screenWidth / 2) (-screenHeight / 2) + outline txt = mkGroup + [ withStrokeWidth (defaultStrokeWidth * 10) $ withStrokeColor "white" txt + , withStrokeWidth 0 txt + ] diff --git a/test/Properties.hs b/test/Properties.hs --- a/test/Properties.hs +++ b/test/Properties.hs @@ -49,6 +49,8 @@ prop_validEarClip p = isValidTriangulation p (earClip $ pRing p) +prop_validEarCut p = isValidTriangulation p (earCut $ pRing p) + -- dualToTrangulation . dual = id prop_dualInv p = let t = polygonTriangulation p in @@ -57,6 +59,14 @@ prop_ssspEq p = pSize p < 20 ==> naive (pRing p) == polygonSSSP p V.! 0 + +prop_ssspSize :: Polygon -> Bool +prop_ssspSize p = + length (sssp (pRing p) (dual 0 $ polygonTriangulation p)) == pSize p + +prop_pCuts p = + pSize p < 20 ==> + all (\(l,r) -> pIsSimple l && pIsSimple r) (pCuts p) prop_ssspVisibilityLength (Parameters xs) = let p = pGenerate xs in diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,13 +1,14 @@ module Main (main) where import Test.Tasty +import Test.Tasty.Ingredients.Rerun (defaultMainWithRerun) -import UnitTests import Properties +import UnitTests main :: IO () main = do tests1 <- unitTestFolder "examples/" tests2 <- compileTestFolder "examples/" tests3 <- compileVideoFolder "videos/" - defaultMain $ testGroup "tests" [tests1, tests2, tests3, all_props] + defaultMainWithRerun $ testGroup "tests" [tests1, tests2, tests3, all_props]