reanimate 0.4.1.0 → 0.4.2.0

raw patch · 137 files changed

+2618/−5178 lines, 137 filesdep +filelockdep +ghciddep +hgeometrydep −chiphunkdep −earcutdep −hmatrixdep ~ansi-terminaldep ~arraydep ~attoparsecbinary-addedPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: filelock, ghcid, hgeometry, hgeometry-combinatorial

Dependencies removed: chiphunk, earcut, hmatrix

Dependency ranges changed: ansi-terminal, array, attoparsec, base64-bytestring, bytestring, cassava, cereal, colour, containers, cubicbezier, directory, filepath, fsnotify, geojson, hashable, lens, linear, matrix, mtl, open-browser, optparse-applicative, parallel, process, random, random-shuffle, split, temporary, text, time, vector-space, xml

API changes (from Hackage documentation)

Files

• ChangeLog.md +17/−1
• data/github-icon-white.svg +6/−0
• docs/gifs/doc_augustP.gif binary
• docs/gifs/doc_balloon.gif binary
• docs/gifs/doc_cameraAttach.gif binary
• docs/gifs/doc_cameraFocus.gif binary
• docs/gifs/doc_cassiniP.gif binary
• docs/gifs/doc_cylindricalEqualAreaP.gif binary
• docs/gifs/doc_foucautP.gif binary
• docs/gifs/doc_githubWhiteIcon.gif binary
• docs/gifs/doc_lagrangeP.gif binary
• docs/gifs/doc_linear.gif binary
• docs/gifs/doc_powerS.gif binary
• docs/gifs/doc_rawLinear.gif binary
• docs/gifs/doc_rotationalTrajectory.gif binary
• docs/gifs/doc_slideDownT.gif binary
• docs/gifs/doc_slideLeftT.gif binary
• docs/gifs/doc_slideUpT.gif binary
• docs/gifs/doc_spriteScope.gif binary
• docs/gifs/doc_ternaryPlot.gif binary
• examples/demo_tangent.hs +8/−13
• examples/doc_augustP.hs +12/−0
• examples/doc_balloon.hs +14/−0
• examples/doc_cameraAttach.hs +20/−0
• examples/doc_cameraFocus.hs +25/−0
• examples/doc_cassiniP.hs +12/−0
• examples/doc_cylindricalEqualAreaP.hs +12/−0
• examples/doc_foucautP.hs +12/−0
• examples/doc_githubWhiteIcon.hs +11/−0
• examples/doc_lagrangeP.hs +12/−0
• examples/doc_linear.hs +17/−0
• examples/doc_rawLinear.hs +17/−0
• examples/doc_rotationalTrajectory.hs +18/−0
• examples/doc_slideDownT.golden +10/−0
• examples/doc_slideDownT.hs +15/−0
• examples/doc_slideLeftT.golden +10/−10
• examples/doc_slideLeftT.hs +1/−1
• examples/doc_slideUpT.golden +10/−0
• examples/doc_slideUpT.hs +15/−0
• examples/doc_spriteScope.hs +19/−0
• examples/doc_ternaryPlot.hs +10/−8
• examples/fe_morph.hs +83/−0
• examples/intro_canvas.hs +16/−22
• examples/intro_canvas_square.hs +16/−22
• examples/latex_wheel.hs +16/−15
• examples/morphology_closest.hs +6/−5
• examples/morphology_intro.hs +2/−1
• examples/morphology_leastwork.hs +0/−69
• examples/morphology_linear.hs +4/−3
• examples/morphology_linebend.hs +0/−63
• examples/morphology_linebend_intro.hs +0/−100
• examples/morphology_object_correspondence.hs +10/−9
• examples/morphology_point_correspondence.hs +5/−4
• examples/morphology_point_trajectory.hs +0/−320
• examples/morphology_rigid.hs +0/−66
• examples/morphology_rotational.hs +6/−5
• examples/morphology_rotational_intro.hs +4/−3
• examples/polyshape_test1.hs +0/−92
• examples/polyshape_test2.hs +0/−34
• examples/polyshape_test3.hs +0/−48
• examples/polyshape_test4.hs +0/−33
• examples/shatter.hs +0/−135
• examples/signals.hs +0/−84
• examples/simulate_equation.hs +0/−201
• examples/simulate_gravity.golden +0/−10
• examples/simulate_gravity.hs +0/−79
• examples/sorting.hs +2/−1
• examples/tut_glue_blender.hs +5/−4
• examples/tut_glue_fourier.hs +9/−9
• examples/tut_glue_keyframe.hs +20/−20
• examples/tut_glue_latex.hs +6/−5
• examples/tut_glue_physics.hs +0/−59
• examples/tut_glue_potrace.hs +2/−1
• examples/tut_glue_povray.hs +9/−8
• examples/tut_glue_povray_ortho.hs +5/−4
• examples/voice_advanced.hs +0/−1
• examples/voice_triggers.hs +7/−6
• reanimate.cabal +53/−51
• src/Geom2D/CubicBezier/Linear.hs +344/−0
• src/Reanimate.hs +6/−6
• src/Reanimate/Animation.hs +22/−10
• src/Reanimate/Blender.hs +45/−12
• src/Reanimate/Builtin/CirclePlot.hs +11/−0
• src/Reanimate/Builtin/Documentation.hs +15/−5
• src/Reanimate/Builtin/Flip.hs +11/−1
• src/Reanimate/Builtin/Images.hs +12/−0
• src/Reanimate/Builtin/Slide.hs +9/−0
• src/Reanimate/Builtin/TernaryPlot.hs +56/−13
• src/Reanimate/Chiphunk.hs +0/−97
• src/Reanimate/ColorComponents.hs +32/−2
• src/Reanimate/ColorMap.hs +5/−0
• src/Reanimate/ColorSpace.hs +20/−42
• src/Reanimate/Constants.hs +25/−2
• src/Reanimate/Debug.hs +10/−0
• src/Reanimate/Driver.hs +4/−2
• src/Reanimate/Driver/CLI.hs +23/−3
• src/Reanimate/Driver/Magick.hs +5/−5
• src/Reanimate/Driver/Server.hs +179/−88
• src/Reanimate/Ease.hs +12/−11
• src/Reanimate/Effect.hs +2/−1
• src/Reanimate/GeoProjection.hs +55/−177
• src/Reanimate/LaTeX.hs +11/−0
• src/Reanimate/Math/Balloon.hs +22/−1
• src/Reanimate/Math/Common.hs +73/−26
• src/Reanimate/Math/Compatible.hs +0/−325
• src/Reanimate/Math/DCEL.hs +0/−891
• src/Reanimate/Math/EarClip.hs +0/−119
• src/Reanimate/Math/Polygon.hs +108/−23
• src/Reanimate/Math/Render.hs +0/−231
• src/Reanimate/Math/SSSP.hs +2/−1
• src/Reanimate/Math/Smooth.hs +0/−291
• src/Reanimate/Math/Triangulate.hs +35/−4
• src/Reanimate/Math/Visibility.hs +5/−5
• src/Reanimate/Memo.hs +22/−0
• src/Reanimate/Morph/Common.hs +37/−4
• src/Reanimate/Morph/LeastWork.hs +0/−449
• src/Reanimate/Morph/LineBend.hs +0/−108
• src/Reanimate/Morph/Linear.hs +44/−7
• src/Reanimate/Morph/Rigid.hs +0/−281
• src/Reanimate/Morph/Rotational.hs +24/−1
• src/Reanimate/Parameters.hs +28/−6
• src/Reanimate/PolyShape.hs +130/−119
• src/Reanimate/Povray.hs +34/−12
• src/Reanimate/Raster.hs +24/−4
• src/Reanimate/Render.hs +77/−15
• src/Reanimate/Scene.hs +245/−82
• src/Reanimate/Svg.hs +35/−0
• src/Reanimate/Svg/BoundingBox.hs +28/−11
• src/Reanimate/Svg/Constructors.hs +8/−0
• src/Reanimate/Svg/LineCommand.hs +36/−24
• src/Reanimate/Svg/Unuse.hs +11/−1
• src/Reanimate/Transform.hs +19/−11
• src/Reanimate/Transition.hs +7/−0
• src/Reanimate/Voice.hs +7/−0
• test/Helpers.hs +0/−1
• test/Properties.hs +5/−3
• test/UnitTests.hs +49/−20

@@ -1,6 +1,22 @@ # Revision history for reanimate -## 0.4.0.0+## 0.4.2.0++* Web-viewer: Use GHCi to reload code, reducing latency by ~100x.+* Improve caching for blender and povray.+* Hide many internal modules.+* Move hmatrix dependency to a separate package.+* Use hgeometry instead of broken C++ code.+* Introduce the basics for a new graphical object system.+* Introduce online playground.+* Introduce interactive embedded player.+* Hide internal modules and bring documentation coverage up to 100%.++## 0.4.1.0 -- 2020-07-30++* Slightly improved error messages.++## 0.4.0.0 -- 2020-07-28  * Show progress when running ffmpeg. * Small improvements to the scene API.

@@ -0,0 +1,6 @@+<?xml version="1.0" encoding="UTF-8" standalone="no"?>+<svg width="256px" height="250px" viewBox="0 0 256 250" version="1.1" xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink" preserveAspectRatio="xMidYMid">+    <g>+        <path d="M128.00106,0 C57.3172926,0 0,57.3066942 0,128.00106 C0,184.555281 36.6761997,232.535542 87.534937,249.460899 C93.9320223,250.645779 96.280588,246.684165 96.280588,243.303333 C96.280588,240.251045 96.1618878,230.167899 96.106777,219.472176 C60.4967585,227.215235 52.9826207,204.369712 52.9826207,204.369712 C47.1599584,189.574598 38.770408,185.640538 38.770408,185.640538 C27.1568785,177.696113 39.6458206,177.859325 39.6458206,177.859325 C52.4993419,178.762293 59.267365,191.04987 59.267365,191.04987 C70.6837675,210.618423 89.2115753,204.961093 96.5158685,201.690482 C97.6647155,193.417512 100.981959,187.77078 104.642583,184.574357 C76.211799,181.33766 46.324819,170.362144 46.324819,121.315702 C46.324819,107.340889 51.3250588,95.9223682 59.5132437,86.9583937 C58.1842268,83.7344152 53.8029229,70.715562 60.7532354,53.0843636 C60.7532354,53.0843636 71.5019501,49.6441813 95.9626412,66.2049595 C106.172967,63.368876 117.123047,61.9465949 128.00106,61.8978432 C138.879073,61.9465949 149.837632,63.368876 160.067033,66.2049595 C184.49805,49.6441813 195.231926,53.0843636 195.231926,53.0843636 C202.199197,70.715562 197.815773,83.7344152 196.486756,86.9583937 C204.694018,95.9223682 209.660343,107.340889 209.660343,121.315702 C209.660343,170.478725 179.716133,181.303747 151.213281,184.472614 C155.80443,188.444828 159.895342,196.234518 159.895342,208.176593 C159.895342,225.303317 159.746968,239.087361 159.746968,243.303333 C159.746968,246.709601 162.05102,250.70089 168.53925,249.443941 C219.370432,232.499507 256,184.536204 256,128.00106 C256,57.3066942 198.691187,0 128.00106,0 Z M47.9405593,182.340212 C47.6586465,182.976105 46.6581745,183.166873 45.7467277,182.730227 C44.8183235,182.312656 44.2968914,181.445722 44.5978808,180.80771 C44.8734344,180.152739 45.876026,179.97045 46.8023103,180.409216 C47.7328342,180.826786 48.2627451,181.702199 47.9405593,182.340212 Z M54.2367892,187.958254 C53.6263318,188.524199 52.4329723,188.261363 51.6232682,187.366874 C50.7860088,186.474504 50.6291553,185.281144 51.2480912,184.70672 C51.8776254,184.140775 53.0349512,184.405731 53.8743302,185.298101 C54.7115892,186.201069 54.8748019,187.38595 54.2367892,187.958254 Z M58.5562413,195.146347 C57.7719732,195.691096 56.4895886,195.180261 55.6968417,194.042013 C54.9125733,192.903764 54.9125733,191.538713 55.713799,190.991845 C56.5086651,190.444977 57.7719732,190.936735 58.5753181,192.066505 C59.3574669,193.22383 59.3574669,194.58888 58.5562413,195.146347 Z M65.8613592,203.471174 C65.1597571,204.244846 63.6654083,204.03712 62.5716717,202.981538 C61.4524999,201.94927 61.1409122,200.484596 61.8446341,199.710926 C62.5547146,198.935137 64.0575422,199.15346 65.1597571,200.200564 C66.2704506,201.230712 66.6095936,202.705984 65.8613592,203.471174 Z M75.3025151,206.281542 C74.9930474,207.284134 73.553809,207.739857 72.1039724,207.313809 C70.6562556,206.875043 69.7087748,205.700761 70.0012857,204.687571 C70.302275,203.678621 71.7478721,203.20382 73.2083069,203.659543 C74.6539041,204.09619 75.6035048,205.261994 75.3025151,206.281542 Z M86.046947,207.473627 C86.0829806,208.529209 84.8535871,209.404622 83.3316829,209.4237 C81.8013,209.457614 80.563428,208.603398 80.5464708,207.564772 C80.5464708,206.498591 81.7483088,205.631657 83.2786917,205.606221 C84.8005962,205.576546 86.046947,206.424403 86.046947,207.473627 Z M96.6021471,207.069023 C96.7844366,208.099171 95.7267341,209.156872 94.215428,209.438785 C92.7295577,209.710099 91.3539086,209.074206 91.1652603,208.052538 C90.9808515,206.996955 92.0576306,205.939253 93.5413813,205.66582 C95.054807,205.402984 96.4092596,206.021919 96.6021471,207.069023 Z" fill="#ffffff"></path>+    </g>+</svg>

binary file changed (absent → 442010 bytes)

binary file changed (absent → 29162 bytes)

binary file changed (absent → 197692 bytes)

binary file changed (absent → 476809 bytes)

binary file changed (absent → 31276 bytes)

binary file changed (absent → 31325 bytes)

binary file changed (absent → 406449 bytes)

binary file changed (absent → 5171 bytes)

binary file changed (absent → 625831 bytes)

binary file changed (absent → 401461 bytes)

binary file changed (absent → 12737 bytes)

binary file changed (absent → 401461 bytes)

binary file changed (absent → 461716 bytes)

binary file changed (absent → 71737 bytes)

binary file changed (83234 → 86029 bytes)

binary file changed (absent → 73143 bytes)

binary file changed (absent → 18932 bytes)

binary file changed (5132 → 6497 bytes)

@@ -6,8 +6,6 @@ import           Control.Lens                    ((^.)) import           Control.Monad.State import qualified Data.Vector.Unboxed             as V-import           Geom2D.CubicBezier              (AnyBezier (..), Point (..),-                                                  evalBezierDeriv) import           Graphics.SvgTree                (Coord, Tree (..), mapTree,                                                   pathDefinition) import           Linear.Metric@@ -15,10 +13,13 @@ import           Linear.Vector import           Reanimate import           Reanimate.Builtin.Documentation+import           Geom2D.CubicBezier.Linear +piSvg :: SVG+piSvg = pathify $ lowerTransformations $ center $ scale 10 $ latex "s"+ main :: IO () main = reanimate $ docEnv $ mkAnimation 30 $ \t ->-  let piSvg = pathify $ lowerTransformations $ center $ scale 10 $ latex "s" in   mkGroup   [ mkBackgroundPixel rtfdBackgroundColor   , piSvg@@ -81,7 +82,7 @@         else do           let bezier = lineCommandToBezier from cmd               (pos, tangent) = evalBezierDeriv bezier frac-          pure $ (fromPoint pos, fromPoint tangent)+          pure $ (pos, tangent)     totalLen = evalState (sum <$> mapM lineLength cmds) zero     targetLen = totalLen * alpha @@ -89,18 +90,12 @@ lineCommandToBezier from line =   case line of     LineBezier [a] ->-      AnyBezier $ V.fromList [toTuple from, toTuple a]+      AnyBezier $ V.fromList [from, a]     LineBezier [a,b] ->-      AnyBezier $ V.fromList [toTuple from, toTuple a, toTuple b]+      AnyBezier $ V.fromList [from, a, b]     LineBezier [a,b,c] ->-      AnyBezier $ V.fromList [toTuple from, toTuple a, toTuple b, toTuple c]+      AnyBezier $ V.fromList [from, a, b, c]     _ -> error (show line)--fromPoint :: Point a -> V2 a-fromPoint (Point x y) = V2 x y--toTuple :: V2 a -> (a,a)-toTuple (V2 x y) = (x, y)  unangle :: (Floating a, Ord a) => V2 a -> a unangle a@(V2 ax ay) =

@@ -0,0 +1,12 @@+#!/usr/bin/env stack+-- stack runghc --package reanimate+module Main (main) where++import           Reanimate+import           Reanimate.GeoProjection+import           Reanimate.Builtin.Images++main :: IO ()+main = reanimate $ animate $+  const $ scaleToSize screenWidth screenHeight $+  embedImage $ project smallEarth augustP

@@ -0,0 +1,14 @@+#!/usr/bin/env stack+-- stack runghc --package reanimate+{-# LANGUAGE OverloadedStrings #-}+module Main(main) where++import Reanimate+import Reanimate.Builtin.Documentation+import Reanimate.Math.Balloon+import Graphics.SvgTree++main :: IO ()+main = reanimate $ docEnv $ pauseAtEnd 1 $ mkAnimation 5 $ \t ->+  withStrokeLineJoin JoinRound $+  balloon (scale 8 $ center $ latex "X") t

@@ -0,0 +1,20 @@+#!/usr/bin/env stack+-- stack runghc --package reanimate+module Main(main) where++import Reanimate+import Reanimate.Builtin.Documentation+import Reanimate.Scene+import Control.Lens++main :: IO ()+main = reanimate $ docEnv $ sceneAnimation $ do+  cam <- newObject Camera+  circ <- newObject $ Circle 2+  oModifyS circ $+    oContext .= withFillOpacity 1 . withFillColor "blue"+  oShow circ++  cameraAttach cam circ+  cameraZoom cam 2 2+  cameraZoom cam 2 1

@@ -0,0 +1,25 @@+#!/usr/bin/env stack+-- stack runghc --package reanimate+module Main(main) where++import Reanimate+import Reanimate.Builtin.Documentation+import Reanimate.Scene+import Control.Lens++main :: IO ()+main = reanimate $ docEnv $ sceneAnimation $ do+  cam <- newObject Camera+  circ <- newObject $ Circle 2; oShow circ+  oModify circ $ oTranslate .~ (-3,0)+  box <- newObject $ Rectangle 4 4; oShow box+  oModify box $ oTranslate .~ (3,0)++  cameraAttach cam circ+  cameraAttach cam box+  cameraFocus cam (-3,0)+  cameraZoom cam 2 2+  cameraZoom cam 2 1+  cameraFocus cam (3,0)+  cameraZoom cam 2 2+  cameraZoom cam 2 1

@@ -0,0 +1,12 @@+#!/usr/bin/env stack+-- stack runghc --package reanimate+module Main (main) where++import           Reanimate+import           Reanimate.GeoProjection+import           Reanimate.Builtin.Images++main :: IO ()+main = reanimate $ animate $+  const $ scaleToSize screenWidth screenHeight $+  embedImage $ project smallEarth cassiniP

@@ -0,0 +1,12 @@+#!/usr/bin/env stack+-- stack runghc --package reanimate+module Main (main) where++import           Reanimate+import           Reanimate.GeoProjection+import           Reanimate.Builtin.Images++main :: IO ()+main = reanimate $ animate $+  const $ scaleToSize screenWidth screenHeight $+  embedImage $ project smallEarth (cylindricalEqualAreaP 0)

@@ -0,0 +1,12 @@+#!/usr/bin/env stack+-- stack runghc --package reanimate+module Main (main) where++import           Reanimate+import           Reanimate.GeoProjection+import           Reanimate.Builtin.Images++main :: IO ()+main = reanimate $ animate $+  const $ scaleToSize screenWidth screenHeight $+  embedImage $ project smallEarth foucautP

@@ -0,0 +1,11 @@+#!/usr/bin/env stack+-- stack runghc --package reanimate+module Main (main) where++import           Reanimate+import           Reanimate.Builtin.Images++main :: IO ()+main = reanimate $ staticFrame 1 $ mkGroup+  [ mkBackground "grey"+  , githubWhiteIcon ]

@@ -0,0 +1,12 @@+#!/usr/bin/env stack+-- stack runghc --package reanimate+module Main (main) where++import           Reanimate+import           Reanimate.GeoProjection+import           Reanimate.Builtin.Images++main :: IO ()+main = reanimate $ animate $+  const $ scaleToSize screenWidth screenHeight $+  embedImage $ project smallEarth lagrangeP

@@ -0,0 +1,17 @@+#!/usr/bin/env stack+-- stack runghc --package reanimate+{-# LANGUAGE OverloadedStrings #-}+module Main(main) where++import Reanimate+import Reanimate.Builtin.Documentation+import Reanimate.Morph.Common+import Reanimate.Morph.Linear+import Graphics.SvgTree++main :: IO ()+main = reanimate $ docEnv $ playThenReverseA $ pauseAround 0.5 0.5 $ mkAnimation 3 $ \t ->+  withStrokeLineJoin JoinRound $+  let src = scale 8 $ center $ latex "X"+      dst = scale 8 $ center $ latex "H"+  in morph linear src dst t

@@ -0,0 +1,17 @@+#!/usr/bin/env stack+-- stack runghc --package reanimate+{-# LANGUAGE OverloadedStrings #-}+module Main(main) where++import Reanimate+import Reanimate.Builtin.Documentation+import Reanimate.Morph.Common+import Reanimate.Morph.Linear+import Graphics.SvgTree++main :: IO ()+main = reanimate $ docEnv $ playThenReverseA $ pauseAround 0.5 0.5 $ mkAnimation 3 $ \t ->+  withStrokeLineJoin JoinRound $+  let src = scale 8 $ center $ latex "X"+      dst = scale 8 $ center $ latex "H"+  in morph rawLinear src dst t

@@ -0,0 +1,18 @@+#!/usr/bin/env stack+-- stack runghc --package reanimate+{-# LANGUAGE OverloadedStrings #-}+module Main(main) where++import Reanimate+import Reanimate.Builtin.Documentation+import Reanimate.Morph.Common+import Reanimate.Morph.Linear+import Reanimate.Morph.Rotational+import Graphics.SvgTree++main :: IO ()+main = reanimate $ docEnv $ playThenReverseA $ pauseAround 0.5 0.5 $ mkAnimation 3 $ \t ->+  withStrokeLineJoin JoinRound $+  let src = scale 8 $ center $ latex "X"+      dst = scale 8 $ center $ latex "H"+  in morph linear{morphTrajectory=rotationalTrajectory (0.5,0.5)} src dst t

@@ -0,0 +1,10 @@+0<svg viewBox="-8 -4.5 16 9" xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink" version="1.1" preserveAspectRatio="none"><g stroke-width="0.05" transform="scale(1, -1)"><g><g stroke-width="0" fill="#FFFFFF" transform="translate(-8, -4.5)" fill-opacity="1"><rect width="16" height="9" /></g><g stroke-width="0.1" stroke="#000000" fill-opacity="0"><g><g><g transform="translate(0, 0)"><path d="M-3,0 C-3,0 -3,0 -3,0" /></g><g transform="translate(0, 0)"><g transform="translate(0, 9)"><g><g stroke-width="0" fill="#000000" transform="translate(-8, -4.5)" fill-opacity="1"><rect width="16" height="9" /></g><g transform="scale(-1, 1)"><path stroke="#FFFFFF" d="M-3,0 C-3,0 -3,0 -3,0" /></g></g></g></g></g></g></g></g></g></svg>+1<svg viewBox="-8 -4.5 16 9" xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink" version="1.1" preserveAspectRatio="none"><g stroke-width="0.05" transform="scale(1, -1)"><g><g stroke-width="0" fill="#FFFFFF" transform="translate(-8, -4.5)" fill-opacity="1"><rect width="16" height="9" /></g><g stroke-width="0.1" stroke="#000000" fill-opacity="0"><g><g><g transform="translate(0, -0.5)"><path d="M-3,0 C-3,0.36819 -2.933672,0.720888 -2.812312,1.046797" /></g><g transform="translate(0, -0.5)"><g transform="translate(0, 9)"><g><g stroke-width="0" fill="#000000" transform="translate(-8, -4.5)" fill-opacity="1"><rect width="16" height="9" /></g><g transform="scale(-1, 1)"><path stroke="#FFFFFF" d="M-3,0 C-3,0.36819 -2.933672,0.720888 -2.812312,1.046797" /></g></g></g></g></g></g></g></g></g></svg>+2<svg viewBox="-8 -4.5 16 9" xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink" version="1.1" preserveAspectRatio="none"><g stroke-width="0.05" transform="scale(1, -1)"><g><g stroke-width="0" fill="#FFFFFF" transform="translate(-8, -4.5)" fill-opacity="1"><rect width="16" height="9" /></g><g stroke-width="0.1" stroke="#000000" fill-opacity="0"><g><g><g transform="translate(0, -2)"><path d="M-3,0 C-3,1.472759 -1.938749,2.69765 -0.539254,2.951666" /></g><g transform="translate(0, -2)"><g transform="translate(0, 9)"><g><g stroke-width="0" fill="#000000" transform="translate(-8, -4.5)" fill-opacity="1"><rect width="16" height="9" /></g><g transform="scale(-1, 1)"><path stroke="#FFFFFF" d="M-3,0 C-3,1.472759 -1.938749,2.69765 -0.539254,2.951666" /></g></g></g></g></g></g></g></g></g></svg>+3<svg viewBox="-8 -4.5 16 9" xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink" version="1.1" preserveAspectRatio="none"><g stroke-width="0.05" transform="scale(1, -1)"><g><g stroke-width="0" fill="#FFFFFF" transform="translate(-8, -4.5)" fill-opacity="1"><rect width="16" height="9" /></g><g stroke-width="0.1" stroke="#000000" fill-opacity="0"><g><g><g transform="translate(0, -4.5)"><path d="M-3,0 C-3,1.656854 -1.656854,3 0,3 C1.656854,3 3,1.656854 3,0 C3,0 3,0 3,0" /></g><g transform="translate(0, -4.5)"><g transform="translate(0, 9)"><g><g stroke-width="0" fill="#000000" transform="translate(-8, -4.5)" fill-opacity="1"><rect width="16" height="9" /></g><g transform="scale(-1, 1)"><path stroke="#FFFFFF" d="M-3,0 C-3,1.656854 -1.656854,3 0,3 C1.656854,3 3,1.656854 3,0 C3,0 3,0 3,0" /></g></g></g></g></g></g></g></g></g></svg>+4<svg viewBox="-8 -4.5 16 9" xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink" version="1.1" preserveAspectRatio="none"><g stroke-width="0.05" transform="scale(1, -1)"><g><g stroke-width="0" fill="#FFFFFF" transform="translate(-8, -4.5)" fill-opacity="1"><rect width="16" height="9" /></g><g stroke-width="0.1" stroke="#000000" fill-opacity="0"><g><g><g transform="translate(0, -7)"><path d="M-3,0 C-3,1.656854 -1.656854,3 0,3 C1.656854,3 3,1.656854 3,0 C3,-1.656854 1.656854,-3 0,-3 C-0.184095,-3 -0.364317,-2.983418 -0.539254,-2.951666" /></g><g transform="translate(0, -7)"><g transform="translate(0, 9)"><g><g stroke-width="0" fill="#000000" transform="translate(-8, -4.5)" fill-opacity="1"><rect width="16" height="9" /></g><g transform="scale(-1, 1)"><path stroke="#FFFFFF" d="M-3,0 C-3,1.656854 -1.656854,3 0,3 C1.656854,3 3,1.656854 3,0 C3,-1.656854 1.656854,-3 0,-3 C-0.184095,-3 -0.364317,-2.983418 -0.539254,-2.951666" /></g></g></g></g></g></g></g></g></g></svg>+5<svg viewBox="-8 -4.5 16 9" xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink" version="1.1" preserveAspectRatio="none"><g stroke-width="0.05" transform="scale(1, -1)"><g><g stroke-width="0" fill="#FFFFFF" transform="translate(-8, -4.5)" fill-opacity="1"><rect width="16" height="9" /></g><g stroke-width="0.1" stroke="#000000" fill-opacity="0"><g><g><g transform="translate(0, -8.5)"><path d="M-3,0 C-3,1.656854 -1.656854,3 0,3 C1.656854,3 3,1.656854 3,0 C3,-1.656854 1.656854,-3 0,-3 C-1.288664,-3 -2.387555,-2.18748 -2.812312,-1.046797" /></g><g transform="translate(0, -8.5)"><g transform="translate(0, 9)"><g><g stroke-width="0" fill="#000000" transform="translate(-8, -4.5)" fill-opacity="1"><rect width="16" height="9" /></g><g transform="scale(-1, 1)"><path stroke="#FFFFFF" d="M-3,0 C-3,1.656854 -1.656854,3 0,3 C1.656854,3 3,1.656854 3,0 C3,-1.656854 1.656854,-3 0,-3 C-1.288664,-3 -2.387555,-2.18748 -2.812312,-1.046797" /></g></g></g></g></g></g></g></g></g></svg>+6<svg viewBox="-8 -4.5 16 9" xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink" version="1.1" preserveAspectRatio="none"><g stroke-width="0.05" transform="scale(1, -1)"><g><g stroke-width="0" fill="#FFFFFF" transform="translate(-8, -4.5)" fill-opacity="1"><rect width="16" height="9" /></g><g stroke-width="0.1" stroke="#000000" fill-opacity="0"><g><g><g transform="translate(0, -9)"><path d="M-3,0 a3 3 0 1 0 6,0 3 3 0 1 0 -6,0" /></g><g transform="translate(0, -9)"><g transform="translate(0, 9)"><g><g stroke-width="0" fill="#000000" transform="translate(-8, -4.5)" fill-opacity="1"><rect width="16" height="9" /></g><g transform="scale(-1, 1)"><path stroke="#FFFFFF" d="M-3,0 a3 3 0 1 0 6,0 3 3 0 1 0 -6,0" /></g></g></g></g></g></g></g></g></g></svg>+7<svg viewBox="-8 -4.5 16 9" xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink" version="1.1" preserveAspectRatio="none"><g stroke-width="0.05" transform="scale(1, -1)"><g><g stroke-width="0" fill="#FFFFFF" transform="translate(-8, -4.5)" fill-opacity="1"><rect width="16" height="9" /></g><g stroke-width="0.1" stroke="#000000" fill-opacity="0"><g><g><g transform="translate(0, -9)"><path d="M-3,0 a3 3 0 1 0 6,0 3 3 0 1 0 -6,0" /></g><g transform="translate(0, -9)"><g transform="translate(0, 9)"><g><g stroke-width="0" fill="#000000" transform="translate(-8, -4.5)" fill-opacity="1"><rect width="16" height="9" /></g><g transform="scale(-1, 1)"><path stroke="#FFFFFF" d="M-3,0 a3 3 0 1 0 6,0 3 3 0 1 0 -6,0" /></g></g></g></g></g></g></g></g></g></svg>+8<svg viewBox="-8 -4.5 16 9" xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink" version="1.1" preserveAspectRatio="none"><g stroke-width="0.05" transform="scale(1, -1)"><g><g stroke-width="0" fill="#FFFFFF" transform="translate(-8, -4.5)" fill-opacity="1"><rect width="16" height="9" /></g><g stroke-width="0.1" stroke="#000000" fill-opacity="0"><g><g><g transform="translate(0, -9)"><path d="M-3,0 a3 3 0 1 0 6,0 3 3 0 1 0 -6,0" /></g><g transform="translate(0, -9)"><g transform="translate(0, 9)"><g><g stroke-width="0" fill="#000000" transform="translate(-8, -4.5)" fill-opacity="1"><rect width="16" height="9" /></g><g transform="scale(-1, 1)"><path stroke="#FFFFFF" d="M-3,0 a3 3 0 1 0 6,0 3 3 0 1 0 -6,0" /></g></g></g></g></g></g></g></g></g></svg>+9<svg viewBox="-8 -4.5 16 9" xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink" version="1.1" preserveAspectRatio="none"><g stroke-width="0.05" transform="scale(1, -1)"><g><g stroke-width="0" fill="#FFFFFF" transform="translate(-8, -4.5)" fill-opacity="1"><rect width="16" height="9" /></g><g stroke-width="0.1" stroke="#000000" fill-opacity="0"><g><g><g transform="translate(0, -9)"><path d="M-3,0 a3 3 0 1 0 6,0 3 3 0 1 0 -6,0" /></g><g transform="translate(0, -9)"><g transform="translate(0, 9)"><g><g stroke-width="0" fill="#000000" transform="translate(-8, -4.5)" fill-opacity="1"><rect width="16" height="9" /></g><g transform="scale(-1, 1)"><path stroke="#FFFFFF" d="M-3,0 a3 3 0 1 0 6,0 3 3 0 1 0 -6,0" /></g></g></g></g></g></g></g></g></g></svg>

@@ -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 $ pauseAtEnd 1 $ signalT (curveS 2) slideDownT left right+  where+    left = drawCircle+    right = staticFrame 1 (withFillOpacity 1 $ mkBackground "black") `parA`+            mapA (flipXAxis . withStrokeColor "white") drawCircle

@@ -1,10 +1,10 @@-0<svg viewBox="-8 -4.5 16 9" xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink" version="1.1" preserveAspectRatio="none"><g stroke-width="0.05" transform="scale(1, -1)"><g><g stroke-width="0" fill="#FFFFFF" transform="translate(-8, -4.5)" fill-opacity="1"><rect width="16" height="9" /></g><g stroke-width="0.1" stroke="#000000" fill-opacity="0"><g><g transform="translate(0, 0)"><path d="M-3,0 C-3,0 -3,0 -3,0" /></g><g transform="translate(0, 0)"><g transform="translate(16, 0)"><g><g stroke-width="0" fill="#000000" transform="translate(-8, -4.5)" fill-opacity="1"><rect width="16" height="9" /></g><g transform="scale(-1, 1)"><path stroke="#FFFFFF" d="M-3,0 C-3,0 -3,0 -3,0" /></g></g></g></g></g></g></g></g></svg>-1<svg viewBox="-8 -4.5 16 9" xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink" version="1.1" preserveAspectRatio="none"><g stroke-width="0.05" transform="scale(1, -1)"><g><g stroke-width="0" fill="#FFFFFF" transform="translate(-8, -4.5)" fill-opacity="1"><rect width="16" height="9" /></g><g stroke-width="0.1" stroke="#000000" fill-opacity="0"><g><g transform="translate(-0.395062, 0)"><path d="M-3,0 C-3,0.16364 -2.986898,0.32422 -2.961686,0.480748" /></g><g transform="translate(-0.395062, 0)"><g transform="translate(16, 0)"><g><g stroke-width="0" fill="#000000" transform="translate(-8, -4.5)" fill-opacity="1"><rect width="16" height="9" /></g><g transform="scale(-1, 1)"><path stroke="#FFFFFF" d="M-3,0 C-3,0.16364 -2.986898,0.32422 -2.961686,0.480748" /></g></g></g></g></g></g></g></g></svg>-2<svg viewBox="-8 -4.5 16 9" xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink" version="1.1" preserveAspectRatio="none"><g stroke-width="0.05" transform="scale(1, -1)"><g><g stroke-width="0" fill="#FFFFFF" transform="translate(-8, -4.5)" fill-opacity="1"><rect width="16" height="9" /></g><g stroke-width="0.1" stroke="#000000" fill-opacity="0"><g><g transform="translate(-1.580247, 0)"><path d="M-3,0 C-3,0.65456 -2.79037,1.260158 -2.434584,1.75332" /></g><g transform="translate(-1.580247, 0)"><g transform="translate(16, 0)"><g><g stroke-width="0" fill="#000000" transform="translate(-8, -4.5)" fill-opacity="1"><rect width="16" height="9" /></g><g transform="scale(-1, 1)"><path stroke="#FFFFFF" d="M-3,0 C-3,0.65456 -2.79037,1.260158 -2.434584,1.75332" /></g></g></g></g></g></g></g></g></svg>-3<svg viewBox="-8 -4.5 16 9" xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink" version="1.1" preserveAspectRatio="none"><g stroke-width="0.05" transform="scale(1, -1)"><g><g stroke-width="0" fill="#FFFFFF" transform="translate(-8, -4.5)" fill-opacity="1"><rect width="16" height="9" /></g><g stroke-width="0.1" stroke="#000000" fill-opacity="0"><g><g transform="translate(-3.555556, 0)"><path d="M-3,0 C-3,1.472759 -1.938749,2.69765 -0.539254,2.951666" /></g><g transform="translate(-3.555556, 0)"><g transform="translate(16, 0)"><g><g stroke-width="0" fill="#000000" transform="translate(-8, -4.5)" fill-opacity="1"><rect width="16" height="9" /></g><g transform="scale(-1, 1)"><path stroke="#FFFFFF" d="M-3,0 C-3,1.472759 -1.938749,2.69765 -0.539254,2.951666" /></g></g></g></g></g></g></g></g></svg>-4<svg viewBox="-8 -4.5 16 9" xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink" version="1.1" preserveAspectRatio="none"><g stroke-width="0.05" transform="scale(1, -1)"><g><g stroke-width="0" fill="#FFFFFF" transform="translate(-8, -4.5)" fill-opacity="1"><rect width="16" height="9" /></g><g stroke-width="0.1" stroke="#000000" fill-opacity="0"><g><g transform="translate(-6.320988, 0)"><path d="M-3,0 C-3,1.656854 -1.656854,3 0,3 C0.961385,3 1.817148,2.547781 2.366177,1.844455" /></g><g transform="translate(-6.320988, 0)"><g transform="translate(16, 0)"><g><g stroke-width="0" fill="#000000" transform="translate(-8, -4.5)" fill-opacity="1"><rect width="16" height="9" /></g><g transform="scale(-1, 1)"><path stroke="#FFFFFF" d="M-3,0 C-3,1.656854 -1.656854,3 0,3 C0.961385,3 1.817148,2.547781 2.366177,1.844455" /></g></g></g></g></g></g></g></g></svg>-5<svg viewBox="-8 -4.5 16 9" xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink" version="1.1" preserveAspectRatio="none"><g stroke-width="0.05" transform="scale(1, -1)"><g><g stroke-width="0" fill="#FFFFFF" transform="translate(-8, -4.5)" fill-opacity="1"><rect width="16" height="9" /></g><g stroke-width="0.1" stroke="#000000" fill-opacity="0"><g><g transform="translate(-9.679012, 0)"><path d="M-3,0 C-3,1.656854 -1.656854,3 0,3 C1.656854,3 3,1.656854 3,0 C3,-0.69547 2.763348,-1.335666 2.366177,-1.844455" /></g><g transform="translate(-9.679012, 0)"><g transform="translate(16, 0)"><g><g stroke-width="0" fill="#000000" transform="translate(-8, -4.5)" fill-opacity="1"><rect width="16" height="9" /></g><g transform="scale(-1, 1)"><path stroke="#FFFFFF" d="M-3,0 C-3,1.656854 -1.656854,3 0,3 C1.656854,3 3,1.656854 3,0 C3,-0.69547 2.763348,-1.335666 2.366177,-1.844455" /></g></g></g></g></g></g></g></g></svg>-6<svg viewBox="-8 -4.5 16 9" xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink" version="1.1" preserveAspectRatio="none"><g stroke-width="0.05" transform="scale(1, -1)"><g><g stroke-width="0" fill="#FFFFFF" transform="translate(-8, -4.5)" fill-opacity="1"><rect width="16" height="9" /></g><g stroke-width="0.1" stroke="#000000" fill-opacity="0"><g><g transform="translate(-12.444444, 0)"><path d="M-3,0 C-3,1.656854 -1.656854,3 0,3 C1.656854,3 3,1.656854 3,0 C3,-1.656854 1.656854,-3 0,-3 C-0.184095,-3 -0.364317,-2.983418 -0.539254,-2.951666" /></g><g transform="translate(-12.444444, 0)"><g transform="translate(16, 0)"><g><g stroke-width="0" fill="#000000" transform="translate(-8, -4.5)" fill-opacity="1"><rect width="16" height="9" /></g><g transform="scale(-1, 1)"><path stroke="#FFFFFF" d="M-3,0 C-3,1.656854 -1.656854,3 0,3 C1.656854,3 3,1.656854 3,0 C3,-1.656854 1.656854,-3 0,-3 C-0.184095,-3 -0.364317,-2.983418 -0.539254,-2.951666" /></g></g></g></g></g></g></g></g></svg>-7<svg viewBox="-8 -4.5 16 9" xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink" version="1.1" preserveAspectRatio="none"><g stroke-width="0.05" transform="scale(1, -1)"><g><g stroke-width="0" fill="#FFFFFF" transform="translate(-8, -4.5)" fill-opacity="1"><rect width="16" height="9" /></g><g stroke-width="0.1" stroke="#000000" fill-opacity="0"><g><g transform="translate(-14.419753, 0)"><path d="M-3,0 C-3,1.656854 -1.656854,3 0,3 C1.656854,3 3,1.656854 3,0 C3,-1.656854 1.656854,-3 0,-3 C-1.002295,-3 -1.889787,-2.508475 -2.434584,-1.75332" /></g><g transform="translate(-14.419753, 0)"><g transform="translate(16, 0)"><g><g stroke-width="0" fill="#000000" transform="translate(-8, -4.5)" fill-opacity="1"><rect width="16" height="9" /></g><g transform="scale(-1, 1)"><path stroke="#FFFFFF" d="M-3,0 C-3,1.656854 -1.656854,3 0,3 C1.656854,3 3,1.656854 3,0 C3,-1.656854 1.656854,-3 0,-3 C-1.002295,-3 -1.889787,-2.508475 -2.434584,-1.75332" /></g></g></g></g></g></g></g></g></svg>-8<svg viewBox="-8 -4.5 16 9" xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink" version="1.1" preserveAspectRatio="none"><g stroke-width="0.05" transform="scale(1, -1)"><g><g stroke-width="0" fill="#FFFFFF" transform="translate(-8, -4.5)" fill-opacity="1"><rect width="16" height="9" /></g><g stroke-width="0.1" stroke="#000000" fill-opacity="0"><g><g transform="translate(-15.604938, 0)"><path d="M-3,0 C-3,1.656854 -1.656854,3 0,3 C1.656854,3 3,1.656854 3,0 C3,-1.656854 1.656854,-3 0,-3 C-1.493214,-3 -2.731627,-1.909065 -2.961686,-0.480748" /></g><g transform="translate(-15.604938, 0)"><g transform="translate(16, 0)"><g><g stroke-width="0" fill="#000000" transform="translate(-8, -4.5)" fill-opacity="1"><rect width="16" height="9" /></g><g transform="scale(-1, 1)"><path stroke="#FFFFFF" d="M-3,0 C-3,1.656854 -1.656854,3 0,3 C1.656854,3 3,1.656854 3,0 C3,-1.656854 1.656854,-3 0,-3 C-1.493214,-3 -2.731627,-1.909065 -2.961686,-0.480748" /></g></g></g></g></g></g></g></g></svg>-9<svg viewBox="-8 -4.5 16 9" xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink" version="1.1" preserveAspectRatio="none"><g stroke-width="0.05" transform="scale(1, -1)"><g><g stroke-width="0" fill="#FFFFFF" transform="translate(-8, -4.5)" fill-opacity="1"><rect width="16" height="9" /></g><g stroke-width="0.1" stroke="#000000" fill-opacity="0"><g><g transform="translate(-16, 0)"><path d="M-3,0 a3 3 0 1 0 6,0 3 3 0 1 0 -6,0" /></g><g transform="translate(-16, 0)"><g transform="translate(16, 0)"><g><g stroke-width="0" fill="#000000" transform="translate(-8, -4.5)" fill-opacity="1"><rect width="16" height="9" /></g><g transform="scale(-1, 1)"><path stroke="#FFFFFF" d="M-3,0 a3 3 0 1 0 6,0 3 3 0 1 0 -6,0" /></g></g></g></g></g></g></g></g></svg>+0<svg viewBox="-8 -4.5 16 9" xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink" version="1.1" preserveAspectRatio="none"><g stroke-width="0.05" transform="scale(1, -1)"><g><g stroke-width="0" fill="#FFFFFF" transform="translate(-8, -4.5)" fill-opacity="1"><rect width="16" height="9" /></g><g stroke-width="0.1" stroke="#000000" fill-opacity="0"><g><g><g transform="translate(0, 0)"><path d="M-3,0 C-3,0 -3,0 -3,0" /></g><g transform="translate(0, 0)"><g transform="translate(16, 0)"><g><g stroke-width="0" fill="#000000" transform="translate(-8, -4.5)" fill-opacity="1"><rect width="16" height="9" /></g><g transform="scale(-1, 1)"><path stroke="#FFFFFF" d="M-3,0 C-3,0 -3,0 -3,0" /></g></g></g></g></g></g></g></g></g></svg>+1<svg viewBox="-8 -4.5 16 9" xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink" version="1.1" preserveAspectRatio="none"><g stroke-width="0.05" transform="scale(1, -1)"><g><g stroke-width="0" fill="#FFFFFF" transform="translate(-8, -4.5)" fill-opacity="1"><rect width="16" height="9" /></g><g stroke-width="0.1" stroke="#000000" fill-opacity="0"><g><g><g transform="translate(-0.888889, 0)"><path d="M-3,0 C-3,0.36819 -2.933672,0.720888 -2.812312,1.046797" /></g><g transform="translate(-0.888889, 0)"><g transform="translate(16, 0)"><g><g stroke-width="0" fill="#000000" transform="translate(-8, -4.5)" fill-opacity="1"><rect width="16" height="9" /></g><g transform="scale(-1, 1)"><path stroke="#FFFFFF" d="M-3,0 C-3,0.36819 -2.933672,0.720888 -2.812312,1.046797" /></g></g></g></g></g></g></g></g></g></svg>+2<svg viewBox="-8 -4.5 16 9" xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink" version="1.1" preserveAspectRatio="none"><g stroke-width="0.05" transform="scale(1, -1)"><g><g stroke-width="0" fill="#FFFFFF" transform="translate(-8, -4.5)" fill-opacity="1"><rect width="16" height="9" /></g><g stroke-width="0.1" stroke="#000000" fill-opacity="0"><g><g><g transform="translate(-3.555556, 0)"><path d="M-3,0 C-3,1.472759 -1.938749,2.69765 -0.539254,2.951666" /></g><g transform="translate(-3.555556, 0)"><g transform="translate(16, 0)"><g><g stroke-width="0" fill="#000000" transform="translate(-8, -4.5)" fill-opacity="1"><rect width="16" height="9" /></g><g transform="scale(-1, 1)"><path stroke="#FFFFFF" d="M-3,0 C-3,1.472759 -1.938749,2.69765 -0.539254,2.951666" /></g></g></g></g></g></g></g></g></g></svg>+3<svg viewBox="-8 -4.5 16 9" xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink" version="1.1" preserveAspectRatio="none"><g stroke-width="0.05" transform="scale(1, -1)"><g><g stroke-width="0" fill="#FFFFFF" transform="translate(-8, -4.5)" fill-opacity="1"><rect width="16" height="9" /></g><g stroke-width="0.1" stroke="#000000" fill-opacity="0"><g><g><g transform="translate(-8, 0)"><path d="M-3,0 C-3,1.656854 -1.656854,3 0,3 C1.656854,3 3,1.656854 3,0 C3,0 3,0 3,0" /></g><g transform="translate(-8, 0)"><g transform="translate(16, 0)"><g><g stroke-width="0" fill="#000000" transform="translate(-8, -4.5)" fill-opacity="1"><rect width="16" height="9" /></g><g transform="scale(-1, 1)"><path stroke="#FFFFFF" d="M-3,0 C-3,1.656854 -1.656854,3 0,3 C1.656854,3 3,1.656854 3,0 C3,0 3,0 3,0" /></g></g></g></g></g></g></g></g></g></svg>+4<svg viewBox="-8 -4.5 16 9" xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink" version="1.1" preserveAspectRatio="none"><g stroke-width="0.05" transform="scale(1, -1)"><g><g stroke-width="0" fill="#FFFFFF" transform="translate(-8, -4.5)" fill-opacity="1"><rect width="16" height="9" /></g><g stroke-width="0.1" stroke="#000000" fill-opacity="0"><g><g><g transform="translate(-12.444444, 0)"><path d="M-3,0 C-3,1.656854 -1.656854,3 0,3 C1.656854,3 3,1.656854 3,0 C3,-1.656854 1.656854,-3 0,-3 C-0.184095,-3 -0.364317,-2.983418 -0.539254,-2.951666" /></g><g transform="translate(-12.444444, 0)"><g transform="translate(16, 0)"><g><g stroke-width="0" fill="#000000" transform="translate(-8, -4.5)" fill-opacity="1"><rect width="16" height="9" /></g><g transform="scale(-1, 1)"><path stroke="#FFFFFF" d="M-3,0 C-3,1.656854 -1.656854,3 0,3 C1.656854,3 3,1.656854 3,0 C3,-1.656854 1.656854,-3 0,-3 C-0.184095,-3 -0.364317,-2.983418 -0.539254,-2.951666" /></g></g></g></g></g></g></g></g></g></svg>+5<svg viewBox="-8 -4.5 16 9" xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink" version="1.1" preserveAspectRatio="none"><g stroke-width="0.05" transform="scale(1, -1)"><g><g stroke-width="0" fill="#FFFFFF" transform="translate(-8, -4.5)" fill-opacity="1"><rect width="16" height="9" /></g><g stroke-width="0.1" stroke="#000000" fill-opacity="0"><g><g><g transform="translate(-15.111111, 0)"><path d="M-3,0 C-3,1.656854 -1.656854,3 0,3 C1.656854,3 3,1.656854 3,0 C3,-1.656854 1.656854,-3 0,-3 C-1.288664,-3 -2.387555,-2.18748 -2.812312,-1.046797" /></g><g transform="translate(-15.111111, 0)"><g transform="translate(16, 0)"><g><g stroke-width="0" fill="#000000" transform="translate(-8, -4.5)" fill-opacity="1"><rect width="16" height="9" /></g><g transform="scale(-1, 1)"><path stroke="#FFFFFF" d="M-3,0 C-3,1.656854 -1.656854,3 0,3 C1.656854,3 3,1.656854 3,0 C3,-1.656854 1.656854,-3 0,-3 C-1.288664,-3 -2.387555,-2.18748 -2.812312,-1.046797" /></g></g></g></g></g></g></g></g></g></svg>+6<svg viewBox="-8 -4.5 16 9" xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink" version="1.1" preserveAspectRatio="none"><g stroke-width="0.05" transform="scale(1, -1)"><g><g stroke-width="0" fill="#FFFFFF" transform="translate(-8, -4.5)" fill-opacity="1"><rect width="16" height="9" /></g><g stroke-width="0.1" stroke="#000000" fill-opacity="0"><g><g><g transform="translate(-16, 0)"><path d="M-3,0 a3 3 0 1 0 6,0 3 3 0 1 0 -6,0" /></g><g transform="translate(-16, 0)"><g transform="translate(16, 0)"><g><g stroke-width="0" fill="#000000" transform="translate(-8, -4.5)" fill-opacity="1"><rect width="16" height="9" /></g><g transform="scale(-1, 1)"><path stroke="#FFFFFF" d="M-3,0 a3 3 0 1 0 6,0 3 3 0 1 0 -6,0" /></g></g></g></g></g></g></g></g></g></svg>+7<svg viewBox="-8 -4.5 16 9" xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink" version="1.1" preserveAspectRatio="none"><g stroke-width="0.05" transform="scale(1, -1)"><g><g stroke-width="0" fill="#FFFFFF" transform="translate(-8, -4.5)" fill-opacity="1"><rect width="16" height="9" /></g><g stroke-width="0.1" stroke="#000000" fill-opacity="0"><g><g><g transform="translate(-16, 0)"><path d="M-3,0 a3 3 0 1 0 6,0 3 3 0 1 0 -6,0" /></g><g transform="translate(-16, 0)"><g transform="translate(16, 0)"><g><g stroke-width="0" fill="#000000" transform="translate(-8, -4.5)" fill-opacity="1"><rect width="16" height="9" /></g><g transform="scale(-1, 1)"><path stroke="#FFFFFF" d="M-3,0 a3 3 0 1 0 6,0 3 3 0 1 0 -6,0" /></g></g></g></g></g></g></g></g></g></svg>+8<svg viewBox="-8 -4.5 16 9" xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink" version="1.1" preserveAspectRatio="none"><g stroke-width="0.05" transform="scale(1, -1)"><g><g stroke-width="0" fill="#FFFFFF" transform="translate(-8, -4.5)" fill-opacity="1"><rect width="16" height="9" /></g><g stroke-width="0.1" stroke="#000000" fill-opacity="0"><g><g><g transform="translate(-16, 0)"><path d="M-3,0 a3 3 0 1 0 6,0 3 3 0 1 0 -6,0" /></g><g transform="translate(-16, 0)"><g transform="translate(16, 0)"><g><g stroke-width="0" fill="#000000" transform="translate(-8, -4.5)" fill-opacity="1"><rect width="16" height="9" /></g><g transform="scale(-1, 1)"><path stroke="#FFFFFF" d="M-3,0 a3 3 0 1 0 6,0 3 3 0 1 0 -6,0" /></g></g></g></g></g></g></g></g></g></svg>+9<svg viewBox="-8 -4.5 16 9" xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink" version="1.1" preserveAspectRatio="none"><g stroke-width="0.05" transform="scale(1, -1)"><g><g stroke-width="0" fill="#FFFFFF" transform="translate(-8, -4.5)" fill-opacity="1"><rect width="16" height="9" /></g><g stroke-width="0.1" stroke="#000000" fill-opacity="0"><g><g><g transform="translate(-16, 0)"><path d="M-3,0 a3 3 0 1 0 6,0 3 3 0 1 0 -6,0" /></g><g transform="translate(-16, 0)"><g transform="translate(16, 0)"><g><g stroke-width="0" fill="#000000" transform="translate(-8, -4.5)" fill-opacity="1"><rect width="16" height="9" /></g><g transform="scale(-1, 1)"><path stroke="#FFFFFF" d="M-3,0 a3 3 0 1 0 6,0 3 3 0 1 0 -6,0" /></g></g></g></g></g></g></g></g></g></svg>

@@ -8,7 +8,7 @@ import Reanimate.Transition  main :: IO ()-main = reanimate $ docEnv $ signalT (curveS 2) slideLeftT left right+main = reanimate $ docEnv $ pauseAtEnd 1 $ signalT (curveS 2) slideLeftT left right   where     left = drawCircle     right = staticFrame 1 (withFillOpacity 1 $ mkBackground "black") `parA`

@@ -0,0 +1,10 @@+0<svg viewBox="-8 -4.5 16 9" xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink" version="1.1" preserveAspectRatio="none"><g stroke-width="0.05" transform="scale(1, -1)"><g><g stroke-width="0" fill="#FFFFFF" transform="translate(-8, -4.5)" fill-opacity="1"><rect width="16" height="9" /></g><g stroke-width="0.1" stroke="#000000" fill-opacity="0"><g><g><g transform="translate(0, 0)"><path d="M-3,0 C-3,0 -3,0 -3,0" /></g><g transform="translate(0, 0)"><g transform="translate(0, -9)"><g><g stroke-width="0" fill="#000000" transform="translate(-8, -4.5)" fill-opacity="1"><rect width="16" height="9" /></g><g transform="scale(-1, 1)"><path stroke="#FFFFFF" d="M-3,0 C-3,0 -3,0 -3,0" /></g></g></g></g></g></g></g></g></g></svg>+1<svg viewBox="-8 -4.5 16 9" xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink" version="1.1" preserveAspectRatio="none"><g stroke-width="0.05" transform="scale(1, -1)"><g><g stroke-width="0" fill="#FFFFFF" transform="translate(-8, -4.5)" fill-opacity="1"><rect width="16" height="9" /></g><g stroke-width="0.1" stroke="#000000" fill-opacity="0"><g><g><g transform="translate(0, 0.5)"><path d="M-3,0 C-3,0.36819 -2.933672,0.720888 -2.812312,1.046797" /></g><g transform="translate(0, 0.5)"><g transform="translate(0, -9)"><g><g stroke-width="0" fill="#000000" transform="translate(-8, -4.5)" fill-opacity="1"><rect width="16" height="9" /></g><g transform="scale(-1, 1)"><path stroke="#FFFFFF" d="M-3,0 C-3,0.36819 -2.933672,0.720888 -2.812312,1.046797" /></g></g></g></g></g></g></g></g></g></svg>+2<svg viewBox="-8 -4.5 16 9" xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink" version="1.1" preserveAspectRatio="none"><g stroke-width="0.05" transform="scale(1, -1)"><g><g stroke-width="0" fill="#FFFFFF" transform="translate(-8, -4.5)" fill-opacity="1"><rect width="16" height="9" /></g><g stroke-width="0.1" stroke="#000000" fill-opacity="0"><g><g><g transform="translate(0, 2)"><path d="M-3,0 C-3,1.472759 -1.938749,2.69765 -0.539254,2.951666" /></g><g transform="translate(0, 2)"><g transform="translate(0, -9)"><g><g stroke-width="0" fill="#000000" transform="translate(-8, -4.5)" fill-opacity="1"><rect width="16" height="9" /></g><g transform="scale(-1, 1)"><path stroke="#FFFFFF" d="M-3,0 C-3,1.472759 -1.938749,2.69765 -0.539254,2.951666" /></g></g></g></g></g></g></g></g></g></svg>+3<svg viewBox="-8 -4.5 16 9" xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink" version="1.1" preserveAspectRatio="none"><g stroke-width="0.05" transform="scale(1, -1)"><g><g stroke-width="0" fill="#FFFFFF" transform="translate(-8, -4.5)" fill-opacity="1"><rect width="16" height="9" /></g><g stroke-width="0.1" stroke="#000000" fill-opacity="0"><g><g><g transform="translate(0, 4.5)"><path d="M-3,0 C-3,1.656854 -1.656854,3 0,3 C1.656854,3 3,1.656854 3,0 C3,0 3,0 3,0" /></g><g transform="translate(0, 4.5)"><g transform="translate(0, -9)"><g><g stroke-width="0" fill="#000000" transform="translate(-8, -4.5)" fill-opacity="1"><rect width="16" height="9" /></g><g transform="scale(-1, 1)"><path stroke="#FFFFFF" d="M-3,0 C-3,1.656854 -1.656854,3 0,3 C1.656854,3 3,1.656854 3,0 C3,0 3,0 3,0" /></g></g></g></g></g></g></g></g></g></svg>+4<svg viewBox="-8 -4.5 16 9" xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink" version="1.1" preserveAspectRatio="none"><g stroke-width="0.05" transform="scale(1, -1)"><g><g stroke-width="0" fill="#FFFFFF" transform="translate(-8, -4.5)" fill-opacity="1"><rect width="16" height="9" /></g><g stroke-width="0.1" stroke="#000000" fill-opacity="0"><g><g><g transform="translate(0, 7)"><path d="M-3,0 C-3,1.656854 -1.656854,3 0,3 C1.656854,3 3,1.656854 3,0 C3,-1.656854 1.656854,-3 0,-3 C-0.184095,-3 -0.364317,-2.983418 -0.539254,-2.951666" /></g><g transform="translate(0, 7)"><g transform="translate(0, -9)"><g><g stroke-width="0" fill="#000000" transform="translate(-8, -4.5)" fill-opacity="1"><rect width="16" height="9" /></g><g transform="scale(-1, 1)"><path stroke="#FFFFFF" d="M-3,0 C-3,1.656854 -1.656854,3 0,3 C1.656854,3 3,1.656854 3,0 C3,-1.656854 1.656854,-3 0,-3 C-0.184095,-3 -0.364317,-2.983418 -0.539254,-2.951666" /></g></g></g></g></g></g></g></g></g></svg>+5<svg viewBox="-8 -4.5 16 9" xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink" version="1.1" preserveAspectRatio="none"><g stroke-width="0.05" transform="scale(1, -1)"><g><g stroke-width="0" fill="#FFFFFF" transform="translate(-8, -4.5)" fill-opacity="1"><rect width="16" height="9" /></g><g stroke-width="0.1" stroke="#000000" fill-opacity="0"><g><g><g transform="translate(0, 8.5)"><path d="M-3,0 C-3,1.656854 -1.656854,3 0,3 C1.656854,3 3,1.656854 3,0 C3,-1.656854 1.656854,-3 0,-3 C-1.288664,-3 -2.387555,-2.18748 -2.812312,-1.046797" /></g><g transform="translate(0, 8.5)"><g transform="translate(0, -9)"><g><g stroke-width="0" fill="#000000" transform="translate(-8, -4.5)" fill-opacity="1"><rect width="16" height="9" /></g><g transform="scale(-1, 1)"><path stroke="#FFFFFF" d="M-3,0 C-3,1.656854 -1.656854,3 0,3 C1.656854,3 3,1.656854 3,0 C3,-1.656854 1.656854,-3 0,-3 C-1.288664,-3 -2.387555,-2.18748 -2.812312,-1.046797" /></g></g></g></g></g></g></g></g></g></svg>+6<svg viewBox="-8 -4.5 16 9" xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink" version="1.1" preserveAspectRatio="none"><g stroke-width="0.05" transform="scale(1, -1)"><g><g stroke-width="0" fill="#FFFFFF" transform="translate(-8, -4.5)" fill-opacity="1"><rect width="16" height="9" /></g><g stroke-width="0.1" stroke="#000000" fill-opacity="0"><g><g><g transform="translate(0, 9)"><path d="M-3,0 a3 3 0 1 0 6,0 3 3 0 1 0 -6,0" /></g><g transform="translate(0, 9)"><g transform="translate(0, -9)"><g><g stroke-width="0" fill="#000000" transform="translate(-8, -4.5)" fill-opacity="1"><rect width="16" height="9" /></g><g transform="scale(-1, 1)"><path stroke="#FFFFFF" d="M-3,0 a3 3 0 1 0 6,0 3 3 0 1 0 -6,0" /></g></g></g></g></g></g></g></g></g></svg>+7<svg viewBox="-8 -4.5 16 9" xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink" version="1.1" preserveAspectRatio="none"><g stroke-width="0.05" transform="scale(1, -1)"><g><g stroke-width="0" fill="#FFFFFF" transform="translate(-8, -4.5)" fill-opacity="1"><rect width="16" height="9" /></g><g stroke-width="0.1" stroke="#000000" fill-opacity="0"><g><g><g transform="translate(0, 9)"><path d="M-3,0 a3 3 0 1 0 6,0 3 3 0 1 0 -6,0" /></g><g transform="translate(0, 9)"><g transform="translate(0, -9)"><g><g stroke-width="0" fill="#000000" transform="translate(-8, -4.5)" fill-opacity="1"><rect width="16" height="9" /></g><g transform="scale(-1, 1)"><path stroke="#FFFFFF" d="M-3,0 a3 3 0 1 0 6,0 3 3 0 1 0 -6,0" /></g></g></g></g></g></g></g></g></g></svg>+8<svg viewBox="-8 -4.5 16 9" xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink" version="1.1" preserveAspectRatio="none"><g stroke-width="0.05" transform="scale(1, -1)"><g><g stroke-width="0" fill="#FFFFFF" transform="translate(-8, -4.5)" fill-opacity="1"><rect width="16" height="9" /></g><g stroke-width="0.1" stroke="#000000" fill-opacity="0"><g><g><g transform="translate(0, 9)"><path d="M-3,0 a3 3 0 1 0 6,0 3 3 0 1 0 -6,0" /></g><g transform="translate(0, 9)"><g transform="translate(0, -9)"><g><g stroke-width="0" fill="#000000" transform="translate(-8, -4.5)" fill-opacity="1"><rect width="16" height="9" /></g><g transform="scale(-1, 1)"><path stroke="#FFFFFF" d="M-3,0 a3 3 0 1 0 6,0 3 3 0 1 0 -6,0" /></g></g></g></g></g></g></g></g></g></svg>+9<svg viewBox="-8 -4.5 16 9" xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink" version="1.1" preserveAspectRatio="none"><g stroke-width="0.05" transform="scale(1, -1)"><g><g stroke-width="0" fill="#FFFFFF" transform="translate(-8, -4.5)" fill-opacity="1"><rect width="16" height="9" /></g><g stroke-width="0.1" stroke="#000000" fill-opacity="0"><g><g><g transform="translate(0, 9)"><path d="M-3,0 a3 3 0 1 0 6,0 3 3 0 1 0 -6,0" /></g><g transform="translate(0, 9)"><g transform="translate(0, -9)"><g><g stroke-width="0" fill="#000000" transform="translate(-8, -4.5)" fill-opacity="1"><rect width="16" height="9" /></g><g transform="scale(-1, 1)"><path stroke="#FFFFFF" d="M-3,0 a3 3 0 1 0 6,0 3 3 0 1 0 -6,0" /></g></g></g></g></g></g></g></g></g></svg>

@@ -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 $ pauseAtEnd 1 $ signalT (curveS 2) slideUpT left right+  where+    left = drawCircle+    right = staticFrame 1 (withFillOpacity 1 $ mkBackground "black") `parA`+            mapA (flipXAxis . withStrokeColor "white") drawCircle

@@ -0,0 +1,19 @@+#!/usr/bin/env stack+-- stack runghc --package reanimate+module Main(main) where++import Reanimate+import Reanimate.Builtin.Documentation++main :: IO ()+main = reanimate $ docEnv $ sceneAnimation $ do+  -- the rect lives through the entire 3s animation+  newSpriteSVG_ $ translate (-3) 0 $ mkRect 4 4+  wait 1+  spriteScope $ do+    -- the circle only lives for 1 second.+    local <- newSpriteSVG $ translate 3 0 $ mkCircle 2+    spriteE local $ overBeginning 0.3 fadeInE+    spriteE local $ overEnding 0.3 fadeOutE+    wait 1+  wait 1

@@ -2,13 +2,15 @@ -- stack runghc --package reanimate module Main(main) where -import Reanimate hiding (raster)-import Reanimate.Builtin.Documentation-import Reanimate.Builtin.TernaryPlot-import Reanimate.ColorComponents-import Data.Colour.CIE-import Codec.Picture.Types+import           Codec.Picture.Types+import           Reanimate+import           Reanimate.Builtin.Documentation+import           Reanimate.Builtin.TernaryPlot  main :: IO ()-main = reanimate $ docEnv $ animate $ const $-  ternaryPlot 1024 (\a b c -> promotePixel $ toRGB8 $ cieXYZ a b c)+main = reanimate $ docEnv $ staticFrame 1 $+  ternaryPlot 100 $ \aCoord bCoord cCoord -> promotePixel $+    let red   = round $ aCoord*255+        green = round $ bCoord*255+        blue  = round $ cCoord*255+    in PixelRGB8 red green blue

@@ -0,0 +1,83 @@+#!/usr/bin/env stack+-- stack runghc --package reanimate+{-# LANGUAGE ApplicativeDo     #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ParallelListComp  #-}+module Main(main) where++import           Text.Printf++{- 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           Graphics.SvgTree+import           Reanimate++main :: IO ()+main = reanimate $ sceneAnimation $ do+    newSpriteSVG_ $ mkBackground "white"+    let circles =+          [ (900, 0.3)+          , (760, 0.5)+          , (670, 0.4)+          , (600, 0.6)+          , (450, 0.7) ]+    play $ pauseAtEnd 2 $ mkAnimation 10 $ \t ->+      mkGroup+      [ mkGooeyFilter 0.2 -- fromToS 0.1 0.2 $ oscillateS t+      , mkGroup+        [ lowerTransformations $ center $ withFillColor "black" $ latex "Text"+        , mkGroup+          [rotate (t*rot) $ translate (fromToS 0 3.5 $ bellS 2 $ t) 0 $+            withFillColorPixel (promotePixel c) $ mkCircle (size*1.5)+          | (n,(rot, size)) <- zip [0..] circles+          , let c = turbo (n/fromIntegral (length circles-1))+          ]+        ] & filterRef .~ pure (Ref "gooey")++      ]+    -- wait 1++mkGooeyFilter :: Double -> SVG+mkGooeyFilter blur =+  FilterTree $ mkFilter ("gooey")+      [ FEGaussianBlur $ defaultSvg+        & gaussianBlurStdDeviationX .~ Num blur+        & gaussianBlurEdgeMode      .~ EdgeNone+        & filterResult              .~ Just "blur"+      , FEColorMatrix $ defaultSvg+        & colorMatrixType           .~ Matrix+        & colorMatrixValues         .~ printf+          "1 0 0 0 0 \+          \0 1 0 0 0 \+          \0 0 1 0 0 \+          \0 0 0 %f %f" mul sub+        & colorMatrixIn             .~ pure (SourceRef "blur")+        & filterResult              .~ Just "colormatrix"+      ]+  where+    -- Increase alpha contrast. Turns alphaMin to 0x00 and alphaMax to 0xFF.+    -- Increasing alphaDiff makes the shapes softer. Decreasing it gives more+    -- contrast.+    -- alphaMin*mul + sub*255 = 0+    -- alphaMax*mul + sub*255 = 255+    -- alphaDiff*mul = 255+    -- mul = 255/alphaDiff+    -- sub = -alphaMin*mul/255+    mul = 255/alphaDiff+    sub = -alphaMin*mul/255+    alphaCenter = 255/2 :: Double+    alphaDiff   = 20 :: Double+    alphaMin = alphaCenter - alphaDiff/2+    -- alphaMax = alphaCenter + alphaDiff/2++mkFilter :: String -> [FilterElement] -> Filter+mkFilter ident fe = defaultSvg & filterChildren .~ fe & attrId ?~ ident

@@ -6,28 +6,22 @@   ) where -import           Reanimate-import           Reanimate.Builtin.Documentation+import           Data.Text                       (Text)+import qualified Data.Text                       as T+import           Graphics.SvgTree                hiding (Point, Text, height)+import           Linear.Metric import           Linear.V2 import           Linear.Vector-import           Linear.Metric-import           Graphics.SvgTree                  hiding ( Text-                                                          , Point-                                                          , height-                                                          )-import           Data.Text                                ( Text )-import qualified Data.Text                     as T+import           Reanimate+import           Reanimate.Builtin.Documentation+import           Geom2D.CubicBezier.Linear import           Text.Printf-import           Geom2D.CubicBezier                       ( QuadBezier(..)-                                                          , evalBezier-                                                          , Point(..)-                                                          )  main :: IO () main = reanimate $ sceneAnimation $ do   newSpriteSVG_ $ mkBackgroundPixel rtfdBackgroundColor   newSpriteSVG_ static-  dotPath  <- newVar (QuadBezier (Point 0 0) (Point 0 0) (Point 0 0))+  dotPath  <- newVar (QuadBezier (V2 0 0) (V2 0 0) (V2 0 0))   dotParam <- newVar 0   newSprite_ $ redDot <$> (evalBezier <$> unVar dotPath <*> unVar dotParam)   let moveDot a b = do@@ -37,15 +31,15 @@         tweenVar dotParam 5 $ \v -> fromToS v 1 . curveS 2         wait 1   wait 1-  moveDot (Point 0 1)    (Point 4 2)-  moveDot (Point (-1) 0) (Point (-4) 3)-  moveDot (Point (0) 0)  (Point (-4) (-3))-  moveDot (Point (0) 0)  (Point (5) (-2))-  moveDot (Point (6) 2)  (Point 2 1)-  moveDot (Point (0) 0)  (Point 0 0)+  moveDot (V2 0 1)    (V2 4 2)+  moveDot (V2 (-1) 0) (V2 (-4) 3)+  moveDot (V2 (0) 0)  (V2 (-4) (-3))+  moveDot (V2 (0) 0)  (V2 (5) (-2))+  moveDot (V2 (6) 2)  (V2 2 1)+  moveDot (V2 (0) 0)  (V2 0 0) -redDot :: Point Double -> SVG-redDot (Point x y) = translate x y $ mkGroup+redDot :: V2 Double -> SVG+redDot (V2 x y) = translate x y $ mkGroup   [ translate 0 (-0.5) $ scale 0.5 $ outlinedText $ T.pack $ printf "%.1f,%.1f" x y   , withFillColor "red" $ mkCircle 0.1   ]

@@ -6,22 +6,16 @@   ) where -import           Reanimate-import           Reanimate.Builtin.Documentation+import           Data.Text                       (Text)+import qualified Data.Text                       as T+import           Graphics.SvgTree                hiding (Text, height)+import           Linear.Metric import           Linear.V2 import           Linear.Vector-import           Linear.Metric-import           Graphics.SvgTree                  hiding ( Text-                                                          , Point-                                                          , height-                                                          )-import           Data.Text                                ( Text )-import qualified Data.Text                     as T+import           Reanimate+import           Reanimate.Builtin.Documentation+import           Geom2D.CubicBezier.Linear import           Text.Printf-import           Geom2D.CubicBezier                       ( QuadBezier(..)-                                                          , evalBezier-                                                          , Point(..)-                                                          )  newWidth, newHeight :: Double newWidth = 8@@ -31,7 +25,7 @@ main = reanimate $ mapA squareViewBox $ sceneAnimation $ do   newSpriteSVG_ $ mkBackgroundPixel rtfdBackgroundColor   newSpriteSVG_ static-  dotPath  <- newVar (QuadBezier (Point 0 0) (Point 0 0) (Point 0 0))+  dotPath  <- newVar (QuadBezier (V2 0 0) (V2 0 0) (V2 0 0))   dotParam <- newVar 0   newSprite_ $ redDot <$> (evalBezier <$> unVar dotPath <*> unVar dotParam)   let moveDot a b = do@@ -40,18 +34,18 @@         writeVar dotParam 0         tweenVar dotParam 5 $ \v -> fromToS v 1 . curveS 2         wait 1-  moveDot (Point 0 1)     (Point 2 1)-  moveDot (Point (-1) 0)  (Point (-1) 1.5)-  moveDot (Point (0) 0)   (Point (-2) (-3))-  moveDot (Point (0) 0)   (Point (2.5) (-1))-  moveDot (Point (3) 1.5) (Point 1.5 1)-  moveDot (Point (0) 0)   (Point 0 0)+  moveDot (V2 0 1)     (V2 2 1)+  moveDot (V2 (-1) 0)  (V2 (-1) 1.5)+  moveDot (V2 (0) 0)   (V2 (-2) (-3))+  moveDot (V2 (0) 0)   (V2 (2.5) (-1))+  moveDot (V2 (3) 1.5) (V2 1.5 1)+  moveDot (V2 (0) 0)   (V2 0 0)  squareViewBox :: SVG -> SVG squareViewBox = withViewBox (-4, -4, 8, 8) -redDot :: Point Double -> SVG-redDot (Point x y) = translate x y $ mkGroup+redDot :: V2 Double -> SVG+redDot (V2 x y) = translate x y $ mkGroup   [ translate 0 (-0.5) $ scale 0.5 $ outlinedText $ T.pack $ printf "%.1f,%.1f" x y   , withFillColor "red" $ mkCircle 0.1   ]

@@ -4,6 +4,7 @@ {-# LANGUAGE RecursiveDo       #-} module Main (main) where +import           Control.Lens     ((&)) import           Control.Monad    (forM_) import           Graphics.SvgTree (Tree) import           Reanimate@@ -16,28 +17,28 @@ mainScene :: Animation mainScene = sceneAnimation $ mdo     play $ drawCircle-      # setDuration drawCircleT-      # applyE (constE $ scaleXY (-1) 1)+      & setDuration drawCircleT+      & applyE (constE $ scaleXY (-1) 1)     fork $ play $ drawCircle-      # freezeAtPercentage 1-      # setDuration rotDur+      & freezeAtPercentage 1+      & setDuration rotDur     rotDur <- withSceneDuration $ waitOn $       forM_ svgs $ \svg -> do         fork $ play $ drawTick-          # setDuration rotateT-          # repeatA rotateN-          # applyE (overBeginning 0.5 drawInE)-          # applyE (overEnding 0.5 drawOutE)+          & setDuration rotateT+          & repeatA rotateN+          & applyE (overBeginning 0.5 drawInE)+          & applyE (overEnding 0.5 drawOutE)         fork $ play $ drawSVG svg-          # setDuration rotateT-          # repeatA rotateN-          # applyE (overBeginning rotateT drawInE)-          # applyE (delayE rotateT $ overBeginning 1 fillInE)-          # applyE (overEnding 0.5 fadeOutE)+          & setDuration rotateT+          & repeatA rotateN+          & applyE (overBeginning rotateT drawInE)+          & applyE (delayE rotateT $ overBeginning 1 fillInE)+          & applyE (overEnding 0.5 fadeOutE)         wait (rotateT / fromIntegral (1+length svgs))     play $ drawCircle-      # setDuration drawCircleT-      # reverseA+      & setDuration drawCircleT+      & reverseA     return ()   where     drawCircleT = 1

@@ -6,8 +6,9 @@  import           Codec.Picture import           Codec.Picture.Types+import           Control.Lens           ((&)) import           Control.Monad-import           Graphics.SvgTree         (LineJoin (..))+import           Graphics.SvgTree       (LineJoin (..)) import           Reanimate import           Reanimate.Morph.Common import           Reanimate.Morph.Linear@@ -34,11 +35,11 @@     showPair from to =       waitOn $ do         fork $ play $ mkAnimation 4 (morph rawLinear from to)-          # mapA (translate (-4) (-0.5))-          # signalA (curveS 4)+          & mapA (translate (-4) (-0.5))+          & signalA (curveS 4)         fork $ play $ mkAnimation 4 (morph linear from to)-          # mapA (translate (4) (-0.5))-          # signalA (curveS 4)+          & mapA (translate (4) (-0.5))+          & signalA (curveS 4)      pairs = zip stages (tail stages ++ [head stages])     stages = map (lowerTransformations . scale 8 . pathify . center) $ colorize

@@ -5,6 +5,7 @@ module Main(main) where  import           Codec.Picture+import           Control.Lens           ((&)) import           Reanimate import           Reanimate.Morph.Common import           Reanimate.Morph.Linear@@ -23,7 +24,7 @@       play $ step stage2 stage3       play $ step stage3 stage4       play $ step stage4 stage1-        # setDuration 5+        & setDuration 5   where     radius = 2.5     step from to =

@@ -1,69 +0,0 @@-#!/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.LeastWork-import           Reanimate.Morph.Linear--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 "least-work"-      forM_ pairs $ uncurry showPair-  where-    showPair from to =-      waitOn $ do-        fork $ play $ mkAnimation 4 (morph linear from to)-          # mapA (translate (-3) (-0.5))-          # signalA (curveS 4)-        fork $ play $ mkAnimation 4 (morph myMorph from to)-          # mapA (translate (3) (-0.5))-          # signalA (curveS 4)--    stretchCosts = defaultStretchCosts-      { stretchStiffness = 2 }-    bendCosts = defaultBendCosts-    myMorph = linear{morphPointCorrespondence = leastWork stretchCosts bendCosts }-    pairs = zip stages (tail stages ++ [head stages])-    stages = map (lowerTransformations . scale 6 . pathify . center) $ colorize-      [ latex "X"-      , latex "$\\aleph$"-      , latex "Y"-      , latex "$\\infty$"-      , latex "I"-      , latex "$\\pi$"-      , latex "1"-      , latex "T"-      , latex "I"-      , latex "L"-      , 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..]-  ]

@@ -6,7 +6,8 @@  import           Codec.Picture import           Codec.Picture.Types-import           Graphics.SvgTree         (LineJoin (..))+import           Control.Lens           ((&))+import           Graphics.SvgTree       (LineJoin (..)) import           Reanimate import           Reanimate.Morph.Common import           Reanimate.Morph.Linear@@ -31,8 +32,8 @@         spriteE toS $ overBeginning 0.2 fadeInE         spriteE toS $ overEnding 0.2 fadeOutE         m <- fork $ newSpriteA $ animate (morph linear from to)-          # signalA (curveS 4)-          # mapA (translate (-4) 0)+          & signalA (curveS 4)+          & mapA (translate (-4) 0)         wait 4         destroySprite m         destroySprite toS

@@ -1,63 +0,0 @@-#!/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.LineBend--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 "line bend"-      forM_ pairs $ uncurry showPair-  where-    showPair from to =-      waitOn $ do-        fork $ play $ mkAnimation 4 (morph linear from to)-          # mapA (translate (-3) (-0.5))-          # signalA (curveS 4)-        fork $ play $ mkAnimation 4 (morph myMorph from to)-          # mapA (translate (3) (-0.5))-          # signalA (curveS 4)--    myMorph = linear{morphTrajectory = lineBend }-    pairs = zip stages (tail stages ++ [head stages])-    stages = map (lowerTransformations . scale 6 . pathify . center) $ colorize-      [ 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..]-  ]

@@ -1,100 +0,0 @@-#!/usr/bin/env stack--- stack runghc --package reanimate-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ParallelListComp  #-}-module Main(main) where--import           Codec.Picture-import           Control.Monad-import           Data.List                (transpose)-import qualified Data.Vector              as V-import           Graphics.SvgTree         (LineJoin (..))-import           Linear.V2-import           Reanimate-import           Reanimate.Math.Polygon-import           Reanimate.Morph.Common-import           Reanimate.Morph.Linear-import           Reanimate.Morph.LineBend--bgColor :: PixelRGBA8-bgColor = PixelRGBA8 252 252 252 0xFF--spike1 :: Polygon-spike1 = pScale 2.5 $ mkPolygon $ V.map (\x -> x - V2 1 1) $ V.fromList-  [ V2 0 0, V2 2 0-  , V2 2 1 ]--spike2 :: Polygon-spike2 = pScale 2.5 $ mkPolygon $ V.map (\x -> x - V2 1 1) $ V.fromList-  [ V2 0 0, V2 2 0-  , V2 0 1 ]--spike3 :: Polygon-spike3 = pScale 2.5 $ mkPolygon $ V.map (\x -> x - V2 1 1) $ V.fromList-  [ V2 0.5 0, V2 1.5 0-  , V2 1 2 ]--polygonShape :: Polygon -> SVG-polygonShape p = mkLinePathClosed-  [ (x,y) | V2 x y <- map (fmap realToFrac) $ V.toList (polygonPoints p) ]---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 (-4) 4 $-        center $ latex "linear"-      _ <- newSpriteSVG $-        withStrokeWidth 0 $ translate (4) 4 $-        center $ latex "line bend"-      showTrails-      forM_ pairs $ uncurry showPair-  where-    showTrails = do-      _ <- newSpriteSVG $-            translate (-4) (-0.5) $-            genTrails (map linearTrajectory pairs)-      _ <- newSpriteSVG $-            translate (4) (-0.5) $-            genTrails (map lineBend pairs)-      return ()-    showPair from to =-      waitOn $ do-        fork $ play $ mkAnimation 4 (morph linear (polygonShape from) (polygonShape to))-          # mapA (translate (-4) (-0.5))-          # mapA (withFillColor "lightgreen")-          # signalA (curveS 4)-        fork $ play $ mkAnimation 4 (morph myMorph (polygonShape from) (polygonShape to))-          # mapA (translate (4) (-0.5))-          # mapA (withFillColor "cyan")-          # signalA (curveS 4)-    myMorph = linear{morphTrajectory = lineBend }-    pairs = zip stages (tail stages ++ [head stages])-    stages =-      [ spike1-      , spike2-      , spike3-      ]--genTrails :: [(Double -> Polygon)] -> SVG-genTrails plotters =-    withFillOpacity 0 $-    withStrokeWidth (defaultStrokeWidth*0.5) $-    withStrokeColor "black" $-    withStrokeDashArray [0.1,0.05] $-    mkGroup $ map mkTrail $ transpose $ concat-      [-        [ V.toList $ V.map (fmap realToFrac) (polygonPoints poly)-        | n <- [0..steps]-        , let poly = plotter (fromIntegral n / fromIntegral steps)-        ]-      | plotter <- plotters ]-  where-    steps = 100 :: Int-    mkTrail lst = mkLinePath [ (x,y) | V2 x y <- lst ]

@@ -5,6 +5,7 @@ module Main(main) where  import           Codec.Picture+import           Control.Lens           ((&)) import           Reanimate import           Reanimate.Morph.Common import           Reanimate.Morph.Linear@@ -21,9 +22,9 @@     sceneAnimation $ do       let showLabel label = do             fork $ play $ staticFrame 4 (center $ latex label)-              # mapA (translate 0 4)-              # applyE (overBeginning 0.1 fadeInE)-              # applyE (overEnding 0.1 fadeOutE)+              & mapA (translate 0 4)+              & applyE (overBeginning 0.1 fadeInE)+              & applyE (overEnding 0.1 fadeOutE)       let sides = mkGroup             [ translate (-4) 0 $ withFillColor "blue" $               mkCircle 2@@ -35,21 +36,21 @@        showLabel "Cut"       play $ step sides middle-        # pauseAtEnd 1+        & pauseAtEnd 1       play $ step middle sides-        # pauseAtEnd 1+        & pauseAtEnd 1        showLabel "Overlap"       play $ stepDup sides middle-        # pauseAtEnd 1+        & pauseAtEnd 1       play $ stepDup middle sides-        # pauseAtEnd 1+        & pauseAtEnd 1        showLabel "Obliterate"       play $ stepGenesis sides middle-        # pauseAtEnd 1+        & pauseAtEnd 1       play $ stepGenesis middle sides-        # pauseAtEnd 1+        & pauseAtEnd 1   where     step from to =       signalA (curveS 2) $ animate $ morph linear from to

@@ -6,9 +6,10 @@  import           Codec.Picture import           Codec.Picture.Types-import           Control.Monad                   (replicateM_)-import qualified Data.Text                       as T-import qualified Data.Vector                     as V+import           Control.Lens           ((&))+import           Control.Monad          (replicateM_)+import qualified Data.Text              as T+import qualified Data.Vector            as V import           Linear.V2 import           Linear.Vector import           Reanimate@@ -52,7 +53,7 @@       replicateM_ 8 $ do         offsetVal <- readVar offset         play $ step pl1 (pl2 offsetVal 0)-          # setDuration 3+          & setDuration 3         slideLeft   where     step from to =

@@ -1,320 +0,0 @@-#!/usr/bin/env stack--- stack runghc --package reanimate-module Main where--import           Codec.Picture.Types-import           Control.Lens-import           Control.Monad-import           Data.List-import           Data.Maybe-import qualified Data.Text                     as T-import           Data.Tuple-import qualified Data.Vector                   as V-import           Linear.V2-import           Linear.Vector-import qualified Numeric.LinearAlgebra         as Matrix-import           Numeric.LinearAlgebra.HMatrix (Matrix, linearSolve, toLists,-                                                (><))-import           Reanimate-import           Reanimate.Math.Common-import           Reanimate.Math.Polygon--bgColor :: PixelRGBA8-bgColor = PixelRGBA8 252 252 252 0xFF--type Points = V.Vector (V2 Double)-type Edges = [(Int, Int, Int)]-data Mesh = Mesh { meshPoints :: Points, meshEdges :: Edges }-data MeshPair = MeshPair Points Points Edges--- The points in a RelMesh are:---   relMeshStatic ++ x where Ax = B-data RelMesh = RelMesh-  { relMeshStatic :: Points-  , relMeshEdges  :: Edges-  , relMeshA      :: Matrix Double-  , relMeshB      :: Matrix Double-  }-data RelMeshPair = RelMeshPair Points Edges (Matrix Double) (Matrix Double) (Matrix Double) (Matrix Double)--- Linear interpolation on RelMesh gives smooth morph.--- solveMesh :: RelMesh -> Mesh--- mkRelative :: Mesh -> RelMesh--- mkRelativePair :: MeshPair -> RelMeshPair--- triangulate :: Polygon -> Polygon -> MeshPair ?--- embed :: MeshPair -> MeshPair--- compatible :: Mesh -> Mesh -> Maybe MeshPair--- linearInterpolate :: MeshPair -> Double -> Mesh--- convexInterpolate :: RelMeshPair -> Double -> RelMesh--meshToPolygon :: Mesh -> Polygon-meshToPolygon mesh = pScale 2 $ mkPolygon $ V.fromList-    [ realToFrac <$> (meshPoints mesh V.! (n-1))-    | n <- polygonNodes ]-  where-    polygonNodes :: [Int]-    polygonNodes = [5,8,9,7,4,6]--main :: IO ()-main = reanimate morphAnimation--genTrails :: (Double -> Mesh) -> SVG-genTrails mkMesh =-    withFillOpacity 0 $-    withStrokeWidth (defaultStrokeWidth*0.5) $-    withStrokeColor "black" $-    withStrokeDashArray [0.1,0.1] $-    mkGroup $ map mkTrail $ transpose-      [ V.toList $ V.map (fmap realToFrac) $ polygonPoints $ meshToPolygon mesh-      | n <- [0..steps]-      , let mesh = mkMesh (fromIntegral n / fromIntegral steps)-      ]-  where-    steps = 100 :: Int-    mkTrail lst =mkLinePath [ (x,y) | V2 x y <- lst ]--morphAnimation :: Animation-morphAnimation = playThenReverseA $ pauseAround 1 1 $ addStatic (mkBackgroundPixel bgColor) $-  signalA (curveS 2) $ mkAnimation 5 $ \t -> lowerTransformations $ scale 3 $ pathify $-  mkGroup-  [ translate (-1.5) 0 $ withFillColor "lightgreen" $ mkGroup-    [ withStrokeWidth defaultStrokeWidth $-      withStrokeColor "black" $-      polygonShape $ meshToPolygon $ linearInterpolate meshPair t-    , linearTrails-    , polygonNumDots (meshToPolygon $ linearInterpolate meshPair t) 0-    ]-  , translate 1 0 $ withFillColor "cyan" $ mkGroup-    [ withStrokeWidth defaultStrokeWidth $-      withStrokeColor "black" $-      polygonShape $ meshToPolygon $ solveMesh $ convexInterpolate relPair t-    , curveTrails-    , polygonNumDots (meshToPolygon $ solveMesh $ convexInterpolate relPair t) 0-    ]-  ]-  where-    linearTrails = genTrails (linearInterpolate meshPair)-    curveTrails = genTrails (solveMesh . convexInterpolate relPair)-    relPair = mkRelativePair meshPair-    meshPair = fromJust $ compatible example1 example2--mkLineP :: P -> P -> SVG-mkLineP (V2 x1 y1) (V2 x2 y2) = mkLine (x1,y1) (x2,y2)---- FIXME: Check that the triangles are all anticlockwise.--- FIXME: Check that the edges connect all the points.--- FIXME: Check that the edgse leave no gaps.-compatible :: Mesh -> Mesh -> Maybe MeshPair-compatible a b =-  if meshEdges a == meshEdges b && V.length (meshPoints a) == V.length (meshPoints b)-    then Just $ MeshPair (meshPoints a) (meshPoints b) (meshEdges a)-    else Nothing--linearInterpolate :: MeshPair -> Double -> Mesh-linearInterpolate (MeshPair aP bP edges) t = Mesh-    { meshPoints = V.zipWith (lerp (1-t)) aP bP-    , meshEdges = edges }--example1 :: Mesh-example1 = Mesh points edges-  where-    points = V.fromList-      [ V2 1 0-      , V2 (-1/2) (sqrt 3 / 2)-      , V2 (-1/2) (-sqrt 3 / 2)-      , 3 * points V.! 0 ^/ 4-      , 3 * points V.! 1 ^/ 4-      , 3 * points V.! 2 ^/ 4-      , points V.! 0 ^/ 2-      , points V.! 1 ^/ 2-      , points V.! 2 ^/ 2-      ]-    edges =-      [ (1,5,4), (1,2,5), (2,6,5), (2,3,6), (3,4,6), (3,1,4)-      , (4,8,7), (4,5,8), (5,9,8), (5,6,9), (6,7,9), (6,4,7), (7,8,9)]--example2 :: Mesh-example2 = Mesh points edges-  where-    points = V.fromList-      [ V2 1 0-      , V2 (-1/2) (sqrt 3 / 2)-      , V2 (-1/2) (-sqrt 3 / 2)-      , 3 * points V.! 2 ^/ 4-      , 3 * points V.! 0 ^/ 4-      , 3 * points V.! 1 ^/ 4-      , points V.! 1  ^/ 2-      , points V.! 2 ^/ 2-      , points V.! 0 ^/ 2-      ]-    edges = meshEdges example1---- T = (U, G)--- G = [Polygon]--- U = nub $ concat G--findStarNeighbours :: Eq a => [(a,a,a)] -> a -> [(a, a)]-findStarNeighbours allTrig self =-  [ (b,c)-  | (a,b,c) <- allTrig-  , self == a-  ] ++-  [ (c,a)-  | (a,b,c) <- allTrig-  , self == b-  ] ++-  [ (a,b)-  | (a,b,c) <- allTrig-  , self == c-  ]--isInterior :: Eq a => [(a, a)] -> Bool-isInterior = isJust . getExteriorPoly--getExteriorPoly :: Eq a => [(a, a)] -> Maybe [a]-getExteriorPoly [] = Nothing-getExteriorPoly ((a,b):rest) = worker [a] a b rest-  where-    worker acc start this [] = do-      guard (start == this)-      return (reverse acc)-    worker acc start this xs =-      case lookup this xs of-        Just next -> worker (this:acc) start next (delete (this,next) xs)-        Nothing   ->-          case lookup this (map swap xs) of-            Just next -> worker (this:acc) start next (delete (next, this) xs)-            Nothing   -> Nothing--convexInterpolate :: RelMeshPair -> Double -> RelMesh-convexInterpolate (RelMeshPair static edges leftM leftB rightM rightB) t =-  RelMesh-  { relMeshStatic = static-  , relMeshEdges  = edges-  , relMeshA      = Matrix.scale (1-t) leftM +-                    Matrix.scale t rightM-  , relMeshB      = Matrix.scale (1-t) leftB +-                    Matrix.scale t rightB-  }--solveMesh :: RelMesh -> Mesh-solveMesh (RelMesh static edges m b) =-  case linearSolve m b of-    Nothing -> error "Failed to solve mesh"-    Just ret ->-      Mesh (static <> V.fromList (worker (toLists ret))) edges-  where-    worker []             = []-    worker ([x]:[y]:rest) = V2 x y : worker rest-    worker _              = error "invalid result"--mkRelative :: Mesh -> RelMesh-mkRelative (Mesh points edges) = RelMesh (V.fromList exteriorPoints) edges mM bM-  where-    mM = (s><s) (concat m)-    bM = (s><1) b-    (s,exterior, (m, b)) = toParameters points edges-    exteriorPoints =-      [ points V.! (i-1)-      | i <- exterior-      ]--mkRelativePair :: MeshPair -> RelMeshPair-mkRelativePair (MeshPair p1 p2 edges) =-  let RelMesh static _ leftM leftB = mkRelative (Mesh p1 edges)-      RelMesh _ _ rightM rightB = mkRelative (Mesh p2 edges)-  in RelMeshPair static edges leftM leftB rightM rightB--toParameters :: (Ord b, Fractional b) => V.Vector (V2 b) -> [(Int, Int, Int)] -> (Int, [Int], ([[b]], [b]))-toParameters points groups = (length interior*2,exterior,unzip $ concat-  [ let lst = [(if i == j then -1 else t)-              | j <- interior-              , let t = fromMaybe 0 $ lookup (i,j) lam_ij_cache-              ]-        pos = negate $ sum-           [ pj ^* t-           | j <- exterior-           , let t = fromMaybe 0 $ lookup (i,j) lam_ij_cache-                 pj = points V.! (j-1)-           ]-    in [ (dupX lst, pos ^. _x)-       , (dupY lst, pos ^. _y)]-  | i <- interior ])-  where-    lam_ij_cache = lam_ij points groups-    dupX []     = []-    dupX (x:xs) = x:0:dupX xs-    dupY []     = []-    dupY (x:xs) = 0:x:dupY xs-    (interior, exterior) =-      partition (isInterior . findStarNeighbours groups) [1 .. length points]--lam_ij :: (Ord b, Fractional b) => V.Vector (V2 b) -> [(Int, Int, Int)] -> [((Int, Int), b)]-lam_ij points groups =-  [ ((i, j), t)-  | i <- [1..V.length points]-  , (j, t) <- lam_j points groups i-  ]--lam_j :: (Ord b, Fractional b) => V.Vector (V2 b) -> [(Int, Int, Int)] -> Int -> [(Int, b)]-lam_j points groups p =-  [ (nP, sum [ t | (j,_k,t) <- mu, j == nP ] / fromIntegral (length nPoints))-  | let n = findStarNeighbours groups p-        nPoints = fromMaybe [] $ getExteriorPoly n-        mu = calcMu points groups p-  , nP <- nPoints ]--calcMu :: (Ord c, Fractional c) => V.Vector (V2 c) -> [(Int, Int, Int)] -> Int -> [(Int, Int, c)]-calcMu points groups p = concat-    [ [ (nP, nP, t1)-      , (a, nP, t2)-      , (b, nP, t3) ]-      -- (nP, a, b)-    | {-p <- [1..length points]-}-      let selfVert = points V.! (p-1)-          n = findStarNeighbours groups p-          nPoints :: [Int]-          nPoints = fromMaybe [] $ getExteriorPoly n-    , nP <- nPoints-    , let vert = points V.! (nP-1)-    , let line = (vert, selfVert)-    , let (a,b,aP,bP) = head $-            [ (_a,_b,_aP,_bP)-            | (_a,_b) <- n-            , let _aP = points V.! (_a-1)-                  _bP = points V.! (_b-1)-                  segment = (points V.! (_a-1), points V.! (_b-1))-            , case rayIntersect line segment of-                Nothing -> False-                Just u  -> isBetween u segment-            , _a /= nP-            , _b /= nP ]-    -- , b == (nPoints ++ nPoints) !! i-    , let (t1,t2,t3) = barycentricCoords vert aP bP selfVert-    ]--genColor :: Int -> Int -> PixelRGBA8-genColor n m =-    promotePixel $ parula (fromIntegral (n+offset) / fromIntegral (m+offset))-  where-    offset = 5--polygonNumDots :: Polygon -> Double -> SVG-polygonNumDots p t = mkGroup $ reverse-    [ mkGroup-      [ colored n $ withStrokeWidth (defaultStrokeWidth*0.5) $ withStrokeColor "black" $-        translate x y $ mkCircle circR-      , withFillColor "black" $-        translate x y $ ppNum n ]-    | n <- [0..pSize p-1]-    , let a = realToFrac <$> pAccess p n-          b = realToFrac <$> pAccess p (pNext p n)-          V2 x y = lerp t b a ]-  where-    circR = 0.1-    colored n =-      let c = genColor n (pSize p-1)-      in withFillColorPixel c-    ppNum n = scaleToHeight (circR*1.5) $ center $ latex $ T.pack $ "\\texttt{" ++ show n ++ "}"--polygonShape :: Polygon -> SVG-polygonShape p = mkLinePathClosed-  [ (x,y) | V2 x y <- map (fmap realToFrac) $ V.toList (polygonPoints p) ]

@@ -1,66 +0,0 @@-#!/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..]-  ]

@@ -6,8 +6,9 @@  import           Codec.Picture import           Codec.Picture.Types+import           Control.Lens               ((&)) import           Control.Monad-import           Graphics.SvgTree (LineJoin(..))+import           Graphics.SvgTree           (LineJoin (..)) import           Reanimate import           Reanimate.Morph.Common import           Reanimate.Morph.Linear@@ -35,11 +36,11 @@     showPair from to =       waitOn $ do         fork $ play $ mkAnimation 4 (morph linear from to)-          # mapA (translate (-3) (-0.5))-          # signalA (curveS 4)+          & mapA (translate (-3) (-0.5))+          & signalA (curveS 4)         fork $ play $ mkAnimation 4 (morph myMorph from to)-          # mapA (translate (3) (-0.5))-          # signalA (curveS 4)+          & mapA (translate (3) (-0.5))+          & signalA (curveS 4)     myMorph = linear{morphTrajectory = rotationalTrajectory origin }     origin = (0.5, 0.5)     pairs = zip stages (tail stages ++ [head stages])

@@ -6,6 +6,7 @@ module Main(main) where  import           Codec.Picture+import           Control.Lens               ((&)) import           Data.List                  (transpose) import qualified Data.Vector                as V import           Graphics.SvgTree           (LineJoin (..))@@ -84,9 +85,9 @@     showPair originVar from to =       waitOn $ do         fork $ play $ mkAnimation 2 (morph linear (polygonShape from) (polygonShape to))-          # mapA (translate (-4) (-0.5))-          # mapA (withFillColor "lightgreen")-          # signalA (curveS 4)+          & mapA (translate (-4) (-0.5))+          & mapA (withFillColor "lightgreen")+          & signalA (curveS 4)         s <- fork $ newSprite $ do           origin <- unVar originVar           t <- spriteT

@@ -1,92 +0,0 @@-#!/usr/bin/env stack--- stack runghc --package reanimate-{-# LANGUAGE OverloadedStrings #-}-module Main (main) where--import           Control.Lens        ()-import           Data.List-import qualified Geom2D.CubicBezier  as G-import           Reanimate-import           Reanimate.PolyShape---polygonTest :: Animation-polygonTest = animate $ \_ ->-    std $ gridLayout $ transpose-      [ test0, test1, test2, test3, test4, test5 ]-  where-    test0 = column ppA poly1-    test1 = column ppA poly2-    test2 = column ppA poly3-    test3 = column ppA poly4-    test4 = column ppB [boxPolyShape]-    test5 = column ppB [starPolyShape]--    column pp poly = map pp-      [ poly-      , map plFromPolygon $ plDecompose' 0.05 poly-      , map plFromPolygon $ plDecompose poly ]---    poly1 =-      svgToPolyShapes $ lowerTransformations $-      center $ scale 3 $-      latex "$\\Phi$"-    poly2 =-      svgToPolyShapes $ lowerTransformations $-      center $ scale 3 $-      latex "$\\vartheta$"-    poly3 =-      svgToPolyShapes $ lowerTransformations $-      center $ scale 3 $-      latex "$\\Xi$"-    poly4 =-      svgToPolyShapes $ lowerTransformations $-      center $ scale 3 $-      latex "$\\Theta$"--    ppA = renderPolyShapes-    ppB = lowerTransformations . scale 0.6 . center . renderPolyShapes-    std =-      withFillOpacity 1 .-      withFillColor "blue" .-      withStrokeWidth 0.01 .-      withStrokeColor "white"---boxPolyShape :: PolyShape-boxPolyShape = PolyShape $ G.ClosedPath-  [(G.Point 0 0, G.JoinLine)-  ,(G.Point 0 3, G.JoinLine)-  ,(G.Point 1 3, G.JoinLine)-  ,(G.Point 1 1, G.JoinLine)-  ,(G.Point 2 1, G.JoinLine)-  ,(G.Point 2 2, G.JoinLine)-  ,(G.Point 0 2, G.JoinLine)-  ,(G.Point 0 3, G.JoinLine)-  ,(G.Point 3 3, G.JoinLine)-  ,(G.Point 3 0, G.JoinLine)-  ]--{--squarePolyShape :: PolyShape-squarePolyShape = PolyShape $ G.ClosedPath-  [(G.Point 0 0, G.JoinLine)-  ,(G.Point 1 0, G.JoinLine)-  ,(G.Point 1 1, G.JoinLine)-  ,(G.Point 0 1, G.JoinLine)]--}--starPolyShape :: PolyShape-starPolyShape = PolyShape $ G.ClosedPath-  [(G.Point 0 0, G.JoinLine)-  ,(G.Point 1 2, G.JoinLine)-  ,(G.Point 2 0, G.JoinLine)-  ,(G.Point 0 1, G.JoinLine)-  ,(G.Point 2 1, G.JoinLine)-  ]--main :: IO ()-main = reanimate $ bg `parA` polygonTest-  where-    bg = animate $ const $ mkBackground "black"

@@ -1,34 +0,0 @@-#!/usr/bin/env stack--- stack runghc --package reanimate-{-# LANGUAGE OverloadedStrings #-}-module Main (main) where--import           Reanimate-import           Reanimate.PolyShape--polygonTest :: Animation-polygonTest = mkAnimation 10 $ \t ->-    let s = fromToS 0.5 (-0.5) t-        bigBox = head $ svgToPolyShapes $ pathify $-          mkRect 2 2-        smallBox = head $ svgToPolyShapes $ pathify $-          translate 0 (screenHeight*s) $-          rotate (-45) $-          mkRect 1 1--        overlap = mkGroup $ map renderPolyShape [bigBox, smallBox]-        merged = translate (screenWidth/2*0.1) 0 $-          mkGroup $ map renderPolyShape $-          unionPolyShapes [bigBox, smallBox]-    in std $ gridLayout [[ overlap, merged ]]-  where-    std =-      withFillOpacity 1 .-      withFillColor "blue" .-      withStrokeWidth 0.01 .-      withStrokeColor "white"--main :: IO ()-main = reanimate $ bg `parA` polygonTest-  where-    bg = animate $ const $ mkBackground "black"

@@ -1,48 +0,0 @@-#!/usr/bin/env stack--- stack runghc --package reanimate-{-# LANGUAGE OverloadedStrings #-}-module Main (main) where--import           Reanimate-import           Reanimate.PolyShape-import qualified Geom2D.CubicBezier  as G--polygonTest :: Animation-polygonTest = mkAnimation 10 $ \t ->-    let original =-          renderPolyShapes [iShape]-        originalP =-          renderPolyShapes $ map (plPartial t) [iShape]-        decomposed =-          renderPolyShapes $-          map plFromPolygon $ plDecompose [iShape]-        decomposedP =-          renderPolyShapes $ map (plPartial' t) $ concat $ plGroupTouching $-          map plFromPolygon $ plDecompose $ [iShape]-    in std $ gridLayout-      [[original, originalP]-      ,[decomposed, decomposedP]]-  where-    std =-      withFillOpacity 1 .-      withFillColor "blue" .-      withStrokeWidth 0.02 .-      withStrokeColor "white"--main :: IO ()-main = reanimate $ bg `parA` polygonTest-  where-    bg = animate $ const $ mkBackground "black"--iShape :: PolyShape-iShape = PolyShape $ G.ClosedPath-  [(G.Point 2 2, G.JoinLine)-  ,(G.Point 0 2, G.JoinLine)-  ,(G.Point 0 1, G.JoinLine)-  ,(G.Point 1 1, G.JoinLine)-  ,(G.Point 1 0, G.JoinLine)-  ,(G.Point 3 0, G.JoinLine)-  ,(G.Point 3 1, G.JoinLine)-  ,(G.Point 4 1, G.JoinLine)-  ,(G.Point 4 2, G.JoinLine)-  ]

@@ -1,33 +0,0 @@-#!/usr/bin/env stack--- stack runghc --package reanimate-{-# LANGUAGE OverloadedStrings #-}-module Main (main) where--import           Reanimate-import           Reanimate.PolyShape--polygonTest :: Animation-polygonTest = mapA std $-    let shapes = svgToPolyShapes $ center $ scale 6 $ latex "$\\infty$"-        groups =-          plGroupTouching $-          map plFromPolygon $ plDecompose $ shapes-        -- totalLen = sum $ map (maximum . map (plArea.snd)) groups-        totalLen = fromIntegral $ length groups-        anis = [ setDuration dur $ animate $ \t -> renderPolyShapes $ map (plPartial' t) group-               | group <- groups-               , let groupLen = 1 -- maximum (map (plArea.snd) group)-                     dur = groupLen/totalLen * totalT ]-    in foldr andThen (pause 0) anis-  where-    totalT = 5-    std =-      withFillOpacity 1 .-      withFillColor "blue" .-      withStrokeWidth 0.00 .-      withStrokeColor "white"--main :: IO ()-main = reanimate $ bg `parA` polygonTest-  where-    bg = animate $ const $ mkBackground "black"

@@ -1,135 +0,0 @@-#!/usr/bin/env stack--- stack runghc --package reanimate-{-# LANGUAGE OverloadedStrings #-}-module Main (main) where--import           Chiphunk.Low-import           Control.Monad-import           Graphics.SvgTree    (Tree)-import           Linear.V2-import           Reanimate-import           Reanimate.Chiphunk-import           Reanimate.PolyShape-import           System.IO.Unsafe--test :: Animation-test = unsafePerformIO $ do-  bodyStore <- newBodyStore-  let gravity = Vect 0 (-1)--  -- Create an empty space.-  space <- spaceNew-  spaceCollisionSlop space $= (screenWidth/2560)-  spaceGravity space $= gravity--  -- Add a static line segment shape for the ground.-  -- We'll make it slightly tilted so the ball will roll off.-  -- We attach it to a static body to tell Chipmunk it shouldn't be movable.-  static <- get $ spaceStaticBody space-  ground <- segmentShapeNew static-    (Vect (-screenWidth/2) 0)-    (Vect (screenWidth/2) (-screenHeight/2)) 0-  -- ground <- polyShapeNewRaw static-  --   [ Vect (-screenWidth/2) (screenHeight/2)-  --   , Vect (screenWidth/2) (-screenHeight/2)-  --   , Vect (-screenWidth/2) (-screenHeight/2)-  --   , Vect (-screenWidth/2) (screenHeight/2) ] 0-  shapeFriction ground $= 1-  spaceAddShape space ground----  -- Now let's make a ball that falls onto the line and rolls off.-  -- First we need to make a cpBody to hold the physical properties of the object.-  -- These include the mass, position, velocity, angle, etc. of the object.-  -- Then we attach collision shapes to the Body to give it a size and shape.--  let toVect (V2 x y) = Vect x y--  let svg = center $ scale 2 $ latex "\\LaTeX"-      poly = svgToPolyShapes svg-      vectGroup = plDecompose poly-            --mkCircle (Num radius)-      -- vects = svgToVects svg-      -- vects' = fst $ convexHull vects 0-      -- svg' =-      --   withFillOpacity 0 $ withStrokeColor "white" $-      --   withStrokeWidth 0.01 $-      --   renderPolyShapes (map plFromPolygon vectGroup)-  ---  -- ballBody <- polyShapesToBody space poly-  -- bodyPosition ballBody $= Vect (-screenWidth/4) (screenHeight/2)-  ---  -- addToBodyStore bodyStore ballBody $-  --   withFillColor "white" $-  --   mkGroup-  --     [ svg' ]--  -- let splitPolys = vectGroup-  forM_ vectGroup $ \polygon -> do-    bd <- polygonsToBody space [map toVect polygon]-    bodyPosition bd $= Vect 0 (screenHeight/3)-    addToBodyStore bodyStore bd $-      renderPolyShape $ plFromPolygon polygon-      -- withFillColor "white" $-      -- mkGroup-      --   [ --withStrokeWidth (Num 0.005) $-      --     -- withStrokeWidth (Num 0.00) $-      --     -- withStrokeColor "white" $-      --     -- withFillOpacity 1 $-      --     renderPolyShape $ plFromPolygon polygon-      --   ]--  ani <- simulate space bodyStore 60 60 10-  spaceFreeRecursive space-  return ani---- data LineCommand---   = LineMove RPoint---   -- | LineDraw RPoint---   | LineBezier [RPoint]---   | LineEnd---- vectsToSVG :: [Vect] -> Tree--- vectsToSVG (Vect x y:rest) =---   mkPath $---     MoveTo OriginAbsolute [V2 x y] :---     [ LineTo OriginAbsolute [V2 a b] | Vect a b <- rest ] ++---     [ EndPath ]---   where---     mkPath cmds = PathTree $ defaultSvg & pathDefinition .~ cmds---- polygonsToSVG :: [[Vect]] -> Tree--- polygonsToSVG = merge . mkGroup . map vectsToSVG---   where---     merge svg = PathTree $ defaultSvg & pathDefinition .~ extractPath svg---- svgToVects :: Tree -> [Vect]--- svgToVects svg = map worker (lineToPoints 200 cmds)---   where---     worker (V2 x y) = Vect x y---     cmds = toLineCommands $ wibble $ extractPath svg---     wibble xs = takeWhile (/=EndPath) xs ++ [EndPath]--chunkPolyshapes :: Tree -> Tree-chunkPolyshapes t =-  withStrokeColor "white" $-  withStrokeWidth 0.01 $-  withFillColor "white" $ t---- plArea :: PolyShape -> Double--- plArea pl = areaForPoly (map toVect $ plPolygonify polyShapeTolerance pl) 0---   where---     toVect (Point x y) = Vect x y--reorient :: Tree -> Tree-reorient = id -- scale 4 . translate 0 (-0.9)--main :: IO ()-main = reanimate $ bg `parA` mapA reorient (line `parA` mapA chunkPolyshapes test)-  where-    bg = animate $ const $ mkBackground "black"-    line = animate $ const $ withStrokeColor "white" $-      withStrokeWidth 0.01 $-      mkLine (-screenWidth/2, 0)-             (screenWidth/2, -screenHeight/2)

@@ -1,84 +0,0 @@-#!/usr/bin/env stack--- stack runghc --package reanimate-{-# LANGUAGE OverloadedStrings #-}-module Main (main) where--import           Data.Text           (Text, pack)-import           Graphics.SvgTree    hiding (Text)-import           Numeric-import           Reanimate.Animation-import           Reanimate.Constants-import           Reanimate--main :: IO ()-main = reanimate $ pauseAtEnd 5 $-    curvesExample (\_ -> ([], "[]"))-      `seqA`-    curvesExample (\s ->-      ( [(1, constantS s)]-      , "[(1, constantS " <> ppD s <> ")]"))-      `seqA`-    curvesExample (\s ->-      ( [(s, constantS 0), (1, id)]-      , "[(" <> ppD s <> ", constantS 0), (1, id)]"))-      `seqA`-    curvesExample (\s ->-      ( [(s, constantS 1), (1, reverseS)]-      , "[(" <> ppD s <> ", constantS 1), (1, reverseS)]"))-      `seqA`-    curvesExample (\s ->-      ( [(1, curveS (2+s*3))]-      , "[(1, curveS "<> ppD (2+s*3) <>")]"))-      `seqA`-    curvesExample (\s ->-      ( [(1, fromToS s 1 . curveS 5)]-      , "[(1, fromToS "<>  ppD s <>" 1 \\$ curveS 5)]"))-      `seqA`-    curvesExample (\s ->-      ( [(1, bellS (2+s*3))]-      , "[(1, bellS "<> ppD (2+s*3)<>")]"))-  where-    ppD s = pack (showFFloat (Just 2) s "")--convertX, convertY :: Double -> Double-convertX x = x*(screenWidth/320)-convertY y = y*(screenHeight/180)--curvesExample :: (Double -> ([(Double, Double -> Double)], Text)) -> Animation-curvesExample gen = mkAnimation 2 $ \t ->-    mkGroup-    [ mkBackground "black"-    , withFillColor "white" $-      translate 0 (screenHeight*0.35) $-      center $ latex "Signals"-    , let (curveFns, name) = gen t in-      center $-      mkGroup-        [ withStrokeColor "white" $ withStrokeWidth 0.01 $-          mkGroup-          [ mkLine (0, 0)-                   (convertX 200, 0)-          , mkLine (0, 0)-                   (0, convertY 50) ]-        , withStrokeColor "white" $ withStrokeWidth 0.01 $-          mkGroup-          [ mkLine (0, convertX $ y)-                   (convertX 200, convertX y)-          | y <- [10,20,30,40,50] ]-        , withFillColor "white" $-          mkGroup-            [ translate (convertX $ -5) (convertX $ -5)  $ scale 0.5 $ center $ latex "0"-            , translate (convertX $ -5) (convertX $ 50)  $ scale 0.5 $ center $ latex "1"-            , translate (convertX $ 205) (convertX $ -5) $ scale 0.5 $ center $ latex "1"-            , translate (convertX $ 100) (convertX $ -30)$ scale 0.6 $ center $ latex name ]-        , withFillOpacity 0 $ withStrokeColor "green" $ -- withStrokeWidth 0.5 $-          lowerTransformations $ scaleXY (convertX $ 200) (convertX $ 50) $ mkSignalLine (fromListS curveFns)-        ]-    ]--mkSignalLine :: Signal -> Tree-mkSignalLine fn = mkLinePath-    [ (x/steps, fn (x/steps))-    | x <- [0 .. steps] ]-  where-    steps = 1000

@@ -1,201 +0,0 @@-#!/usr/bin/env stack--- stack runghc --package reanimate-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards   #-}-module Main (main) where--import           Chiphunk.Low-import           Control.Monad-import           Graphics.SvgTree    (Tree)-import           Linear.V2-import           Reanimate.Chiphunk-import           Reanimate-import           Reanimate.PolyShape-import           System.IO.Unsafe--test :: Animation-test = unsafePerformIO $ do-  bodyStore <- newBodyStore-  let gravity = Vect 0 (-1)--  -- Create an empty space.-  space <- spaceNew-  -- spaceCollisionSlop space $= (screenWidth/2560)-  spaceGravity space $= gravity--  -- Add a static line segment shape for the ground.-  -- We'll make it slightly tilted so the ball will roll off.-  -- We attach it to a static body to tell Chipmunk it shouldn't be movable.-  static <- get $ spaceStaticBody space-  ground <- segmentShapeNew static-    (Vect (-screenWidth/2) (screenHeight/2))-    (Vect (screenWidth/2) (-screenHeight/2)) 0-  shapeFriction ground $= 1-  spaceAddShape space ground--  -- Now let's make a ball that falls onto the line and rolls off.-  -- First we need to make a cpBody to hold the physical properties of the object.-  -- These include the mass, position, velocity, angle, etc. of the object.-  -- Then we attach collision shapes to the Body to give it a size and shape.--  let toVect (V2 x y) = Vect x y--  let svg = center $ scale 2 $ latex "$\\Phi$"-      poly = svgToPolyShapes svg-      vectGroup = plDecompose' 1 poly-            --mkCircle (Num radius)-      -- vects = svgToVects svg-      -- vects' = fst $ convexHull vects 0-      -- svg' =-      --   withFillOpacity 0 $ withStrokeColor "white" $-      --   withStrokeWidth 0.01 $-      --   renderPolyShapes (map plFromPolygon vectGroup)-  ---  -- ballBody <- polyShapesToBody space poly-  -- bodyPosition ballBody $= Vect (-screenWidth/4) (screenHeight/2)-  ---  -- addToBodyStore bodyStore ballBody $-  --   withFillColor "white" $-  --   mkGroup-  --     [ svg' ]--  -- let splitPolys = vectGroup-  forM_ vectGroup $ \polygon -> do-    bd <- polygonsToBody space [map toVect polygon]-    bodyPosition bd $= Vect 0 (screenHeight/3)-    addToBodyStore bodyStore bd $-      renderPolyShape $ plFromPolygon polygon-      -- withFillColor "white" $-      -- mkGroup-      --   [ --withStrokeWidth (Num 0.005) $-      --     -- withStrokeWidth (Num 0.00) $-      --     -- withStrokeColor "white" $-      --     -- withFillOpacity 1 $-      --     renderPolyShape $ plFromPolygon polygon-      --   ]--  ani <- simulate space bodyStore 60 10 10-  spaceFreeRecursive space-  return ani---- data LineCommand---   = LineMove RPoint---   -- | LineDraw RPoint---   | LineBezier [RPoint]---   | LineEnd---- vectsToSVG :: [Vect] -> Tree--- vectsToSVG (Vect x y:rest) =---   mkPath $---     MoveTo OriginAbsolute [V2 x y] :---     [ LineTo OriginAbsolute [V2 a b] | Vect a b <- rest ] ++---     [ EndPath ]---   where---     mkPath cmds = PathTree $ defaultSvg & pathDefinition .~ cmds---- polygonsToSVG :: [[Vect]] -> Tree--- polygonsToSVG = merge . mkGroup . map vectsToSVG---   where---     merge svg = PathTree $ defaultSvg & pathDefinition .~ extractPath svg---- svgToVects :: Tree -> [Vect]--- svgToVects svg = map worker (lineToPoints 200 cmds)---   where---     worker (V2 x y) = Vect x y---     cmds = toLineCommands $ wibble $ extractPath svg---     wibble xs = takeWhile (/=EndPath) xs ++ [EndPath]--chunkPolyshapes :: Tree -> Tree-chunkPolyshapes t =-  mkGroup-  [-  -- withFillColor "white" $-  -- withFillOpacity 1 $-  -- withStrokeWidth (Num 0.01) $-  -- withStrokeColor "blue" $-  -- mkGroup $ map renderPolyShape $-  -- map mergePolyShapeHoles $-  -- plGroupShapes $-  -- -- unionPolyShapes $-  -- traceUnion $-  -- svgToPolyShapes t-    withStrokeWidth 0.001 $-    withStrokeColor "red" $-    withFillOpacity 0 $-    mkGroup $ map renderPolyShape $-    svgToPolyShapes t-    -- withStrokeWidth 0.001 $-    -- withStrokeColor "red" $-    -- mkGroup $ map renderPolyShape [pl12,pl13]-  ]---- plArea :: PolyShape -> Double--- plArea pl = areaForPoly (map toVect $ plPolygonify polyShapeTolerance pl) 0---   where---     toVect (Point x y) = Vect x y--reorient :: Tree -> Tree-reorient = scale 6 . translate 0 (-0.9)---- traceUnion t =---   let out = unionPolyShapes t---   in trace (unlines $---             ("Trace: " ++ show (sum $ map plArea t)) :---             ("Check: " ++ show (sum $ map plArea out)) :---             map show t ++ ["Out:"] ++ map show out) out---- pl1 = PolyShape {unPolyShape = ClosedPath [(Point 9.076152025049407e-2 0.8793158714390639,JoinLine),(Point 0.48865783997158957 0.5875446050720555,JoinLine),(Point 0.6291445682322502 0.560956966929786,JoinLine),(Point 0.684414274089106 0.6254399758525935,JoinLine),(Point 8.549729225029659e-2 0.9226054512958702,JoinLine)]}--- pl2 = PolyShape {unPolyShape = ClosedPath [(Point 0.3174796674934045 (-0.17830385091116296),JoinLine),(Point 0.3930521201476444 (-0.22384314349780887),JoinLine),(Point 0.42400439387727545 (-0.17026635397131717),JoinLine),(Point 0.367180526197663 (-0.13743818486413273),JoinLine)]}--- pl3 = PolyShape {unPolyShape = ClosedPath [(Point 3.818529643334073e-2 4.994390978944008e-2,JoinLine),(Point 3.5509598929490127e-3 3.0061273354143103e-2,JoinLine),(Point 2.6643683455205014e-2 (-1.3314171733262437e-2),JoinLine)]}--- pl4 = PolyShape {unPolyShape = ClosedPath [(Point 8.041123459068245e-2 (-4.592522065745819e-2),JoinLine),(Point 0.29675416515553454 (-0.17235110729572378),JoinLine),(Point 0.34590008699238584 (-0.13081971694800998),JoinLine),(Point 0.22737727571852562 4.513304505856075e-2,JoinLine),(Point 0.10498823211784264 (-3.373201779345303e-3),JoinLine)]}--- pl5 = PolyShape {unPolyShape = ClosedPath [(Point 4.1547772506933034e-2 0.10908491253751296,JoinLine),(Point 5.7556283592893165e-2 (-2.2936657573235042e-2),JoinLine),(Point 0.18645395693905423 2.887370173550552e-2,JoinLine),(Point 0.24063435970720265 0.12675372820097613,JoinLine),(Point 0.19807899284556882 0.17285980812856805,JoinLine),(Point 8.45668830191807e-2 0.18680141998908184,JoinLine)]}--- pl6 = PolyShape {unPolyShape = ClosedPath [(Point (-0.2574090456009813) 0.22352645168090446,JoinLine),(Point (-0.27139525022076605) 0.16073053060077958,JoinLine),(Point (-9.444562231853837e-2) 4.994785063168361e-2,JoinLine),(Point (-4.012849544398306e-2) 6.733655689772311e-2,JoinLine),(Point (-4.6550067413171026e-2) 0.20017002713448606,JoinLine)]}--- pl7 = PolyShape {unPolyShape = ClosedPath [(Point (-0.3714373753139388) 0.20874389306710772,JoinLine),(Point (-0.29452803703157854) 0.1655072120141602,JoinLine),(Point (-0.2835217605861194) 0.22889335799870397,JoinLine),(Point (-0.34012040364470725) 0.2621083279509192,JoinLine)]}--- pl8 = PolyShape {unPolyShape = ClosedPath [(Point 0.1712163207191154 0.2149766965620984,JoinLine),(Point 0.19616659305280632 0.1905738263277067,JoinLine),(Point 0.6315796735654418 0.5328570813993471,JoinLine),(Point 0.49895896036053317 0.5862908698518825,JoinLine)]}--- pl9 = PolyShape {unPolyShape = ClosedPath [(Point 0.10739670009207455 0.19390054402859663,JoinLine),(Point 0.16776933204268935 0.17681618959615353,JoinLine),(Point 0.19166035517967667 0.1970425575035583,JoinLine),(Point 0.16584071117957827 0.2205236594561943,JoinLine)]}--- pl10 = PolyShape {unPolyShape = ClosedPath [(Point (-0.3669271639958152) 1.1382616686769857,JoinLine),(Point (-0.30169633405804164) 1.1454435521784956,JoinLine),(Point (-0.2858326377769962) 1.2078015601462844,JoinLine),(Point (-0.3736986541543818) 1.199765022618315,JoinLine)]}--- pl11 = PolyShape {unPolyShape = ClosedPath [(Point (-3.0061173114158422e-2) 1.1779482589541495,JoinLine),(Point 5.4907529076574785e-3 1.2315286122957358,JoinLine),(Point (-3.4177530164954735e-2) 1.2269151735259667,JoinLine)]}--- pl12 = PolyShape {unPolyShape = ClosedPath---   [(Point (-0.301730083226429*10) 1.1457103198223786,JoinLine)---   ,(Point (-0.10299641326632633*10) 1.0714677466302471,JoinLine)---   ,(Point (-3.162369257155477e-2*10) 1.182092647608354,JoinLine)---   ,(Point (-3.636877035247056e-2*10) 1.2310026399913667,JoinLine)---   ,(Point (-0.28589249688644447*10) 1.208074964264014,JoinLine)]}--- pl13 = PolyShape {unPolyShape = ClosedPath---   [(Point (-9.39646610882567e-2*10) 0.96018603098516,JoinLine)---   ,(Point (-6.465077411411442e-2*10) 0.9514465910530718,JoinLine)---   ,(Point (0.14134955357291654*10) 1.2461928296570437,JoinLine)---   ,(Point (8.29425965486209e-3*10) 1.2330682613363688,JoinLine)---   ,(Point (-0.10287959610529117*10) 1.0717052650151784,JoinLine)]}--- pl14 = PolyShape {unPolyShape = ClosedPath [(Point (-0.6410657779553459) 0.5634659418454123,JoinLine),(Point (-0.641345175626591) 0.555247219163176,JoinLine),(Point (-0.4420444191709594) 0.5513358399243028,JoinLine),(Point (-0.10594072095664082) 0.9023816092645105,JoinLine),(Point (-7.577913627887163e-2) 0.9355404742795719,JoinLine),(Point (-0.10373629906690308) 0.9479533236181756,JoinLine)]}--- pl15 = PolyShape {unPolyShape = ClosedPath [(Point (-3.523485505752828e-2) 0.1998408875682416,JoinLine),(Point 1.2546982880291841e-2 0.15208851089779252,JoinLine),(Point 0.13018455413761065 0.208301106923033,JoinLine),(Point 8.433578523127425e-2 0.9418697065712005,JoinLine),(Point (-7.884702019521485e-2) 0.932428903501462,JoinLine),(Point (-8.084970167352624e-2) 0.9296667902794287,JoinLine)]}--- pl16 = PolyShape {unPolyShape = ClosedPath [(Point (-7.878197627394322e-2) 0.9319709148544943,JoinLine),(Point 8.438182768423004e-2 0.941734614325483,JoinLine),(Point 8.518191684165782e-2 0.9853357574063363,JoinLine),(Point 8.15663333974107e-2 0.9853939259545145,JoinLine),(Point (-4.936159754845773e-2) 0.9727171460725276,JoinLine)]}--- pl17 = PolyShape {unPolyShape = ClosedPath [(Point (-4.99911351869741e-2) 0.9726181699897635,JoinLine),(Point 8.094809532371453e-2 0.9851776987711782,JoinLine),(Point 7.384845354621125e-2 1.0968271981504014,JoinLine),(Point 4.400324523877765e-2 1.1025518925313644,JoinLine)]}--- pl18 = PolyShape {unPolyShape = ClosedPath [(Point 4.8482888984171635e-2 1.1105768787999895,JoinLine),(Point 7.512899062784217e-2 1.0959654499901599,JoinLine),(Point 0.2822087302816073 1.1420633097553252,JoinLine),(Point 0.27513287205836434 1.2060076125068004,JoinLine),(Point 0.20204313118994668 1.2231219927110881,JoinLine)]}--- pl19 = PolyShape {unPolyShape = ClosedPath [(Point 0.2748784478150325 1.2078902086770202,JoinLine),(Point 0.2820822061918643 1.1439601884266248,JoinLine),(Point 0.3457225261391361 1.127943000720636,JoinLine),(Point 0.36082444597621127 1.187946730956635,JoinLine)]}--- pl20 = PolyShape {unPolyShape = ClosedPath [(Point (-0.6864531908080556) 0.5032767356555317,JoinLine),(Point (-9.929294916146593e-2) 0.20829491627795255,JoinLine),(Point (-8.483230342755331e-2) 0.23523598173633797,JoinLine),(Point (-0.49217693932265094) 0.547917843618004,JoinLine)]}--- pl21 = PolyShape {unPolyShape = ClosedPath [(Point (-9.274301086931341e-2) 0.2153671046631685,JoinLine),(Point (-4.68781647762479e-2) 0.2005165600411279,JoinLine),(Point (-4.790067311086227e-2) 0.23865704773924823,JoinLine),(Point (-7.795810209993242e-2) 0.2330461435659677,JoinLine)]}---- unionTest = parsed---   where---     svg = center $ scale 2 $ latex "I"---     poly = svgToPolyShapes svg---     vectGroup = plDecompose' 1 poly---     rendered = mkGroup $ take 100 $ map (renderPolyShape . plFromPolygon) vectGroup---     parsed = svgToPolyShapes rendered------     myDecompose tol =---       concatMap decomposePolygon .---       map (plPolygonify tol) .---       map mergePolyShapeHoles .---       plGroupShapes .---       unionPolyShapes--main :: IO ()-main = reanimate $ bg `parA` mapA reorient (line `parA` mapA chunkPolyshapes test)-  where-    bg = animate $ const $ mkBackground "black"-    line = animate $ const $ withStrokeColor "white" $-      withStrokeWidth 0.01 $-      mkLine (-screenWidth/2, screenHeight/2)-             (screenWidth/2, -screenHeight/2)

@@ -1,10 +0,0 @@-0<svg viewBox="-8 -4.5 16 9" xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink" version="1.1" preserveAspectRatio="none"><g stroke-width="0.05" transform="scale(1, -1)"><g><g><g stroke-width="0" fill="#000000" transform="translate(-8, -4.5)" fill-opacity="1"><rect width="16" height="9" /></g><line stroke-width="0.01" stroke="#FFFFFF" x1="-8" x2="8" y2="-4.5" /></g><g><g transform="translate(0, 4.5)"><g transform="rotate(0)"><g fill="#FFFFFF"><circle r="1" /><line stroke="#000000" y2="1" /></g></g></g></g></g></g></svg>-1<svg viewBox="-8 -4.5 16 9" xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink" version="1.1" preserveAspectRatio="none"><g stroke-width="0.05" transform="scale(1, -1)"><g><g><g stroke-width="0" fill="#000000" transform="translate(-8, -4.5)" fill-opacity="1"><rect width="16" height="9" /></g><line stroke-width="0.01" stroke="#FFFFFF" x1="-8" x2="8" y2="-4.5" /></g><g><g transform="translate(0, 3.5)"><g transform="rotate(0)"><g fill="#FFFFFF"><circle r="1" /><line stroke="#000000" y2="1" /></g></g></g></g></g></g></svg>-2<svg viewBox="-8 -4.5 16 9" xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink" version="1.1" preserveAspectRatio="none"><g stroke-width="0.05" transform="scale(1, -1)"><g><g><g stroke-width="0" fill="#000000" transform="translate(-8, -4.5)" fill-opacity="1"><rect width="16" height="9" /></g><line stroke-width="0.01" stroke="#FFFFFF" x1="-8" x2="8" y2="-4.5" /></g><g><g transform="translate(0, 0.623148)"><g transform="rotate(0)"><g fill="#FFFFFF"><circle r="1" /><line stroke="#000000" y2="1" /></g></g></g></g></g></g></svg>-3<svg viewBox="-8 -4.5 16 9" xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink" version="1.1" preserveAspectRatio="none"><g stroke-width="0.05" transform="scale(1, -1)"><g><g><g stroke-width="0" fill="#000000" transform="translate(-8, -4.5)" fill-opacity="1"><rect width="16" height="9" /></g><line stroke-width="0.01" stroke="#FFFFFF" x1="-8" x2="8" y2="-4.5" /></g><g><g transform="translate(0.544434, -1.371641)"><g transform="rotate(-32.404054)"><g fill="#FFFFFF"><circle r="1" /><line stroke="#000000" y2="1" /></g></g></g></g></g></g></svg>-4<svg viewBox="-8 -4.5 16 9" xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink" version="1.1" preserveAspectRatio="none"><g stroke-width="0.05" transform="scale(1, -1)"><g><g><g stroke-width="0" fill="#000000" transform="translate(-8, -4.5)" fill-opacity="1"><rect width="16" height="9" /></g><line stroke-width="0.01" stroke="#FFFFFF" x1="-8" x2="8" y2="-4.5" /></g><g><g transform="translate(1.709402, -1.699288)"><g transform="rotate(-101.741451)"><g fill="#FFFFFF"><circle r="1" /><line stroke="#000000" y2="1" /></g></g></g></g></g></g></svg>-5<svg viewBox="-8 -4.5 16 9" xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink" version="1.1" preserveAspectRatio="none"><g stroke-width="0.05" transform="scale(1, -1)"><g><g><g stroke-width="0" fill="#000000" transform="translate(-8, -4.5)" fill-opacity="1"><rect width="16" height="9" /></g><line stroke-width="0.01" stroke="#FFFFFF" x1="-8" x2="8" y2="-4.5" /></g><g><g transform="translate(3.264515, -2.136663)"><g transform="rotate(-194.299838)"><g fill="#FFFFFF"><circle r="1" /><line stroke="#000000" y2="1" /></g></g></g></g></g></g></svg>-6<svg viewBox="-8 -4.5 16 9" xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink" version="1.1" preserveAspectRatio="none"><g stroke-width="0.05" transform="scale(1, -1)"><g><g><g stroke-width="0" fill="#000000" transform="translate(-8, -4.5)" fill-opacity="1"><rect width="16" height="9" /></g><line stroke-width="0.01" stroke="#FFFFFF" x1="-8" x2="8" y2="-4.5" /></g><g><g transform="translate(5.09458, -2.651369)"><g transform="rotate(-303.223039)"><g fill="#FFFFFF"><circle r="1" /><line stroke="#000000" y2="1" /></g></g></g></g></g></g></svg>-7<svg viewBox="-8 -4.5 16 9" xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink" version="1.1" preserveAspectRatio="none"><g stroke-width="0.05" transform="scale(1, -1)"><g><g><g stroke-width="0" fill="#000000" transform="translate(-8, -4.5)" fill-opacity="1"><rect width="16" height="9" /></g><line stroke-width="0.01" stroke="#FFFFFF" x1="-8" x2="8" y2="-4.5" /></g><g><g transform="translate(7.340372, -3.282998)"><g transform="rotate(-436.88976)"><g fill="#FFFFFF"><circle r="1" /><line stroke="#000000" y2="1" /></g></g></g></g></g></g></svg>-8<svg viewBox="-8 -4.5 16 9" xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink" version="1.1" preserveAspectRatio="none"><g stroke-width="0.05" transform="scale(1, -1)"><g><g><g stroke-width="0" fill="#000000" transform="translate(-8, -4.5)" fill-opacity="1"><rect width="16" height="9" /></g><line stroke-width="0.01" stroke="#FFFFFF" x1="-8" x2="8" y2="-4.5" /></g><g><g transform="translate(9.775043, -4.315897)"><g transform="rotate(-581.798313)"><g fill="#FFFFFF"><circle r="1" /><line stroke="#000000" y2="1" /></g></g></g></g></g></g></svg>-9<svg viewBox="-8 -4.5 16 9" xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink" version="1.1" preserveAspectRatio="none"><g stroke-width="0.05" transform="scale(1, -1)"><g><g><g stroke-width="0" fill="#000000" transform="translate(-8, -4.5)" fill-opacity="1"><rect width="16" height="9" /></g><line stroke-width="0.01" stroke="#FFFFFF" x1="-8" x2="8" y2="-4.5" /></g><g><g transform="translate(12.329251, -7.234268)"><g transform="rotate(-733.821586)"><g fill="#FFFFFF"><circle r="1" /><line stroke="#000000" y2="1" /></g></g></g></g></g></g></svg>

@@ -1,79 +0,0 @@-#!/usr/bin/env stack--- stack runghc --package reanimate-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards   #-}-module Main (main) where--import           Chiphunk.Low-import           Reanimate.Chiphunk-import           Reanimate-import           System.IO.Unsafe---test :: Animation-test = unsafePerformIO $ do-  bodyStore <- newBodyStore-  let gravity = Vect 0 (-10)--  -- Create an empty space.-  space <- spaceNew-  spaceGravity space $= gravity--  -- Add a static line segment shape for the ground.-  -- We'll make it slightly tilted so the ball will roll off.-  -- We attach it to a static body to tell Chipmunk it shouldn't be movable.-  static <- get $ spaceStaticBody space-  ground <- segmentShapeNew static-    (Vect (-screenWidth/2) 0)-    (Vect (screenWidth/2) (-screenHeight/2)) 0-  shapeFriction ground $= 1-  spaceAddShape space ground--  -- Now let's make a ball that falls onto the line and rolls off.-  -- First we need to make a cpBody to hold the physical properties of the object.-  -- These include the mass, position, velocity, angle, etc. of the object.-  -- Then we attach collision shapes to the Body to give it a size and shape.--  let radius = 1-  let mass = 1--  -- The moment of inertia is like mass for rotation-  -- Use the momentFor* functions to help you approximate it.-  let moment = momentForCircle mass 0 radius (Vect 0 0)--  -- The spaceAdd* functions return the thing that you are adding.-  ballBody <- bodyNew mass moment-  spaceAddBody space ballBody-  bodyPosition ballBody $= Vect 0 (screenHeight/2)--  -- Now we create the collision shape for the ball.-  -- You can create multiple collision shapes that point to the same body.-  -- They will all be attached to the body and move around to follow it.-  ballShape <- circleShapeNew ballBody radius (Vect 0 0)-  spaceAddShape space ballShape-  shapeFriction ballShape $= 0.7--  addToBodyStore bodyStore ballBody $-    withFillColor "white" $-    mkGroup-      [ mkCircle radius-      , withStrokeColor "black" $-        mkLine (0, 0) (0, radius) ]--  ani <- simulate space bodyStore 60 3 4--  shapeFree ballShape-  bodyFree ballBody-  shapeFree ground-  spaceFree space-  return ani---main :: IO ()-main = reanimate $ bg `parA` line `parA` test-  where-    bg = animate $ const $ mkBackground "black"-    line = animate $ const $ withStrokeColor "white" $-      withStrokeWidth 0.01 $-      mkLine (-screenWidth/2, 0)-             (screenWidth/2, -screenHeight/2)

@@ -2,6 +2,7 @@ -- stack runghc --package reanimate {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes        #-}+{-# LANGUAGE PackageImports    #-} module Main (main) where  import           Codec.Picture@@ -13,7 +14,7 @@ import qualified Data.Vector.Unboxed         as V import           Reanimate import           System.Random-import           System.Random.Shuffle+import "random-shuffle" System.Random.Shuffle  main :: IO () main = reanimate $

@@ -3,20 +3,21 @@ {-# LANGUAGE ApplicativeDo     #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes       #-}+{-# LANGUAGE PackageImports    #-} module Main (main) where  import           Reanimate import           Reanimate.Builtin.Documentation  import           Codec.Picture.Types-import           Control.Lens                    ((^.))+import           Control.Lens                    ((&), (^.)) import           Control.Monad import           Data.Monoid import qualified Data.Text                       as T import           Graphics.SvgTree                hiding (text) import           NeatInterpolation import           System.Random-import           System.Random.Shuffle+import "random-shuffle" System.Random.Shuffle  -- spritePercent = (/) <$> spriteT <*> spriteDur @@ -216,7 +217,7 @@     mapM_ destroySprite sprites     -- Undraw equations     play $ drawAnimation' (Just 0xdeadbeef) 1 0.1 strokedSvg-      # reverseA+      & reverseA   where     glyphs = svgGlyphs svg     strokedSvg =@@ -258,7 +259,7 @@     fork $ do       wait (n*step)       play $ mapA fn $ (animate (\t -> withFillOpacity 0 $ partialSvg t tree)-        # applyE (overEnding fillDur $ fadeLineOutE sWidth))+        & applyE (overEnding fillDur $ fadeLineOutE sWidth))     fork $ do       wait (n*step+(1-fillDur))       newSprite $ do

@@ -3,26 +3,26 @@ {-# LANGUAGE OverloadedStrings #-} module Main (main) where +import           Codec.Picture+import           Control.Lens import           Data.Complex import           Graphics.SvgTree import           Linear.V2 import           Reanimate-import           Reanimate.Ease-import           Codec.Picture  -- layer 3 main :: IO () main = reanimate $ setDuration 30 $ sceneAnimation $ do     _ <- newSpriteSVG $ mkBackgroundPixel (PixelRGBA8 252 252 252 0xFF)     play $ fourierA (fromToS 0 5)      -- Rotate 15 times-      # setDuration 50-      # signalA (reverseS . powerS 2 . reverseS) -- Start fast, end slow-      # pauseAtEnd 2+      & setDuration 50+      & signalA (reverseS . powerS 2 . reverseS) -- Start fast, end slow+      & pauseAtEnd 2     play $ fourierA (constantS 0)       -- Don't rotate at all-      # setDuration 10-      # reverseA-      # signalA (powerS 2)                       -- Start slow, end fast-      # pauseAtEnd 2+      & setDuration 10+      & reverseA+      & signalA (powerS 2)                       -- Start slow, end fast+      & pauseAtEnd 2  -- layer 2 fourierA :: (Double -> Double) -> Animation

@@ -4,11 +4,11 @@ {-# LANGUAGE RecursiveDo       #-} module Main (main) where -import           Reanimate-+import           Codec.Picture+import           Control.Lens import           Control.Monad    (forM_) import           Graphics.SvgTree (Tree)-import           Codec.Picture+import           Reanimate  main :: IO () main = reanimate $ bg `parA` mainScene@@ -18,30 +18,30 @@ mainScene :: Animation mainScene = sceneAnimation $ mdo     play $ drawCircle-      # setDuration drawCircleT-      # applyE (constE flipXAxis)-      # signalA (curveS 2)+      & setDuration drawCircleT+      & applyE (constE flipXAxis)+      & signalA (curveS 2)     fork $ play $ drawCircle-      # freezeAtPercentage 1-      # setDuration rotDur+      & freezeAtPercentage 1+      & setDuration rotDur     rotDur <- withSceneDuration $ waitOn $       forM_ svgs $ \svg -> do         fork $ play $ drawTick-          # setDuration rotateT-          # repeatA rotateN-          # applyE (overBeginning 0.5 drawInE)-          # applyE (overEnding 0.5 drawOutE)+          & setDuration rotateT+          & repeatA rotateN+          & applyE (overBeginning 0.5 drawInE)+          & applyE (overEnding 0.5 drawOutE)         fork $ play $ drawSVG svg-          # setDuration rotateT-          # repeatA rotateN-          # applyE (overBeginning rotateT drawInE)-          # applyE (delayE rotateT $ overBeginning 1 fillInE)-          # applyE (overEnding 0.5 fadeOutE)+          & setDuration rotateT+          & repeatA rotateN+          & applyE (overBeginning rotateT drawInE)+          & applyE (delayE rotateT $ overBeginning 1 fillInE)+          & applyE (overEnding 0.5 fadeOutE)         wait (rotateT / fromIntegral (1+length svgs))     play $ drawCircle-      # setDuration drawCircleT-      # reverseA-      # signalA (curveS 2)+      & setDuration drawCircleT+      & reverseA+      & signalA (curveS 2)     return ()   where     drawCircleT = 2.5

@@ -1,19 +1,20 @@ #!/usr/bin/env stack -- stack runghc --package reanimate+{-# LANGUAGE ApplicativeDo     #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE PackageImports    #-} module Main (main) where  import           Reanimate  import           Codec.Picture import           Codec.Picture.Types-import           Control.Lens          ((^.))+import           Control.Lens          ((&), (^.)) import           Control.Monad import           Data.Monoid import           Graphics.SvgTree import           System.Random-import           System.Random.Shuffle+import "random-shuffle" System.Random.Shuffle  main :: IO () main = reanimate $ parA bg latexExample@@ -38,7 +39,7 @@     mapM_ destroySprite sprites     -- Undraw equations     play $ drawAnimation' (Just 0xdeadbeef) 1 0.1 strokedSvg-      # reverseA+      & reverseA   where     glyphs = svgGlyphs svg     strokedSvg =@@ -80,7 +81,7 @@     fork $ do       wait (n*step)       play $ mapA fn $ (animate (\t -> withFillOpacity 0 $ partialSvg t tree)-        # applyE (overEnding fillDur $ fadeLineOutE sWidth))+        & applyE (overEnding fillDur $ fadeLineOutE sWidth))     fork $ do       wait (n*step+(1-fillDur))       newSprite $ do

@@ -1,59 +0,0 @@-#!/usr/bin/env stack--- stack runghc --package reanimate-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards   #-}-module Main (main) where--import           Chiphunk.Low-import           Codec.Picture       (PixelRGBA8 (..))-import           Control.Monad       (forM_)-import           Linear.V2           (V2 (..))-import           Reanimate-import           Reanimate.Chiphunk-import           Reanimate.PolyShape-import           Reanimate.Ease-import           System.IO.Unsafe    (unsafePerformIO)--shatter :: Animation-shatter = unsafePerformIO $ do-    bodyStore <- newBodyStore-    let gravity = Vect 0 (-1) -- Gravity points down (negative 1 y/s^2)--    space <- spaceNew-    spaceGravity space $= gravity--    static <- get $ spaceStaticBody space-    ground <- segmentShapeNew static-      (Vect (-screenWidth/2) (-screenHeight/2))-      (Vect (screenWidth/2) (-screenHeight/2)) 0-    shapeFriction ground $= 1-    spaceAddShape space ground--    let toVect (V2 x y) = Vect x y-        vectGroup = plDecompose $ svgToPolyShapes $ center $ scale 4 $-          latex "$F=ma$"--    forM_ vectGroup $ \polygon -> do-      bd <- polygonsToBody space [map toVect polygon]-      bodyPosition bd $= Vect 0 (screenHeight/3)-      addToBodyStore bodyStore bd $-        renderPolyShape $ plFromPolygon polygon--    ani <- simulate space bodyStore fps stepsPerFrame shatterT-    spaceFreeRecursive space-    return $ mapA pp ani-  where-    shatterT = 10-    fps = 60-    stepsPerFrame = 10-    pp = withStrokeWidth 0.01 . withStrokeColor "black" . withFillColor "black"--main :: IO ()-main = reanimate $ parA bg $ sceneAnimation $ do-    play $ shatter-    play $ shatter-      # reverseA-      # setDuration 5-      # signalA (powerS 2)-  where-    bg = animate $ const $ mkBackgroundPixel (PixelRGBA8 252 252 252 0xFF)

@@ -8,6 +8,7 @@ import           Reanimate.Povray  (povraySlow')  import           Codec.Picture+import           Control.Lens import           Control.Monad import           Data.Text         (Text) import qualified Data.Text         as T@@ -25,7 +26,7 @@       tweenVar xRot (wobbleDur/2) $ \v -> fromToS v (v-90) . curveS 2     destroySprite wf     play $ mkAnimation drawDuration (\t -> partialSvg t (wireframe (-45) 220))-      # reverseA+      & reverseA   where     drawDuration = 10     wobbles = 3

@@ -1,8 +1,9 @@ #!/usr/bin/env stack -- stack runghc --package reanimate+{-# LANGUAGE ApplicativeDo     #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes       #-}-{-# LANGUAGE ApplicativeDo     #-}+{-# LANGUAGE PackageImports    #-} module Main (main) where  import           Reanimate@@ -10,15 +11,15 @@  import           Codec.Picture import           Codec.Picture.Types-import           Control.Lens          ((^.))+import           Control.Lens          ((&), (^.)) import           Control.Monad-import qualified Data.Text             as T import           Data.Monoid-import           NeatInterpolation import           Data.Text             (Text)-import           Graphics.SvgTree      hiding (Text,text)+import qualified Data.Text             as T+import           Graphics.SvgTree      hiding (Text, text)+import           NeatInterpolation import           System.Random-import           System.Random.Shuffle+import "random-shuffle" System.Random.Shuffle   main :: IO ()@@ -109,7 +110,7 @@     mapM_ destroySprite sprites     -- Undraw equations     play $ drawAnimation' (Just 0xdeadbeef) 1 0.1 strokedSvg-      # reverseA+      & reverseA   where     glyphs = svgGlyphs svg     strokedSvg =@@ -151,7 +152,7 @@     fork $ do       wait (n*step)       play $ mapA fn $ (animate (\t -> withFillOpacity 0 $ partialSvg t tree)-        # applyE (overEnding fillDur $ fadeLineOutE sWidth))+        & applyE (overEnding fillDur $ fadeLineOutE sWidth))     fork $ do       wait (n*step+(1-fillDur))       newSprite $ do

@@ -3,6 +3,7 @@ {-# LANGUAGE ApplicativeDo     #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes       #-}+{-# LANGUAGE PackageImports    #-} module Main (main) where  import           Reanimate@@ -10,7 +11,7 @@  import           Codec.Picture import           Codec.Picture.Types-import           Control.Lens          ((^.))+import           Control.Lens          ((^.),(&)) import           Control.Monad import           Data.Monoid import           Data.Text             (Text)@@ -18,7 +19,7 @@ import           Graphics.SvgTree      hiding (Text,text) import           NeatInterpolation import           System.Random-import           System.Random.Shuffle+import "random-shuffle" System.Random.Shuffle   main :: IO ()@@ -147,7 +148,7 @@     mapM_ destroySprite sprites     -- Undraw equations     play $ drawAnimation' (Just 0xdeadbeef) 1 0.1 strokedSvg-      # reverseA+      & reverseA   where     glyphs = svgGlyphs svg     strokedSvg =@@ -189,7 +190,7 @@     fork $ do       wait (n*step)       play $ mapA fn $ (animate (\t -> withFillOpacity 0 $ partialSvg t tree)-        # applyE (overEnding fillDur $ fadeLineOutE sWidth))+        & applyE (overEnding fillDur $ fadeLineOutE sWidth))     fork $ do       wait (n*step+(1-fillDur))       newSprite $ do

@@ -7,7 +7,6 @@ import           Control.Monad import qualified Data.Text                     as T import           Reanimate-import           Reanimate.Ease import           Reanimate.Voice import           Reanimate.Builtin.Documentation import           Geom2D.CubicBezier                       ( QuadBezier(..)

@@ -1,15 +1,16 @@ #!/usr/bin/env stack -- stack runghc --package reanimate+{-# LANGUAGE ApplicativeDo     #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ApplicativeDo #-} module Main where +import           Control.Lens import           Control.Monad-import qualified Data.Text                     as T+import qualified Data.Text                       as T+import           Graphics.SvgTree                (ElementRef (..)) import           Reanimate-import           Reanimate.Voice import           Reanimate.Builtin.Documentation-import           Graphics.SvgTree                         ( ElementRef(..) )+import           Reanimate.Voice  transcript :: Transcript transcript = loadTranscript "voice_triggers.txt"@@ -53,8 +54,8 @@             translate (screenWidth / 4) 0 $ scale t $ scaleToHeight 4 $ center               img           )-      # signalA (bellS 2)-      # setDuration dur+      & signalA (bellS 2)+      & setDuration dur  {-# INLINE masked #-} masked :: String -> Double -> SVG -> SVG -> SVG -> SVG

@@ -3,7 +3,7 @@ --  see http://haskell.org/cabal/users-guide/  name:                reanimate-version:             0.4.1.0+version:             0.4.2.0 -- synopsis: -- description: license:             PublicDomain@@ -11,7 +11,7 @@ maintainer:          lemmih@gmail.com category:            Graphics synopsis:            Animation library based on SVGs.-homepage:            https://github.com/reanimate/reanimate#readme+homepage:            https://reanimate.github.io bug-reports:         https://github.com/reanimate/reanimate/issues build-type:          Simple extra-source-files:  ChangeLog.md, examples/*.hs, examples/*.golden@@ -37,23 +37,6 @@     Type:      git     Location:  git://github.com/lemmih/reanimate.git --- 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-  Manual:      True- library   hs-source-dirs:     src   default-language:   Haskell2010@@ -68,24 +51,15 @@                       Reanimate.Svg.Constructors                       Reanimate.Svg.BoundingBox                       Reanimate.Svg.LineCommand-                      -- Reanimate.Diagrams                       Reanimate.Transform-                      Reanimate.Misc+                      Reanimate.Math.Triangulate                       Reanimate.Math.Common                       Reanimate.Math.Polygon-                      Reanimate.Math.Triangulate-                      Reanimate.Math.EarClip-                      Reanimate.Math.Visibility                       Reanimate.Math.SSSP                       Reanimate.Math.Balloon-                      Reanimate.Math.Compatible-                      Reanimate.Math.Render                       Reanimate.Morph.Common                       Reanimate.Morph.Linear                       Reanimate.Morph.Rotational-                      Reanimate.Morph.LeastWork-                      Reanimate.Morph.LineBend-                      Reanimate.Morph.Cache                       Reanimate.Raster                       Reanimate.ColorComponents                       Reanimate.ColorMap@@ -102,38 +76,67 @@                       Reanimate.Builtin.Slide                       Reanimate.Constants                       Reanimate.Parameters-                      Reanimate.Chiphunk                       Reanimate.PolyShape                       Reanimate.GeoProjection                       Reanimate.Builtin.Documentation                       Reanimate.Builtin.Images                       Reanimate.Debug                       Reanimate.Voice+                      Geom2D.CubicBezier.Linear   other-modules:      Reanimate.Cache+                      Reanimate.Morph.Cache                       Reanimate.Driver                       Reanimate.Driver.Check                       Reanimate.Driver.CLI                       Reanimate.Driver.Magick                       Reanimate.Driver.Server                       Reanimate.Driver.Compile+                      Reanimate.Misc                       Paths_reanimate-  build-depends:       base >=4.10 && <5,-                       time, text, filepath, process, directory,-                       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-terminal, temporary,-                       optparse-applicative, chiphunk >= 0.1.2.1,-                       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-  }+                      Reanimate.Math.Visibility+  build-depends:+    base                 >=4.10 && <5,+    JuicyPixels          >=3.3.3,+    aeson                >=1.3.0.0,+    ansi-terminal        >=0.8.0.4,+    array                >=0.5.2.0,+    attoparsec           >=0.13.2.0,+    base64-bytestring    >=1.0.0.1,+    bytestring           >=0.10.8.0,+    cassava              >=0.5.1.0,+    cereal               >=0.5.5.0,+    colour               >=2.3.4,+    containers           >=0.5.11.0,+    cubicbezier          >=0.6.0.5,+    directory            >=1.3.1.0,+    filelock             >=0.1.1.2,+    filepath             >=1.4.2,+    fsnotify             >=0.3.0.1,+    geojson              >=3.0.4,+    ghcid                >=0.7,+    hashable             >=1.2.7.0,+    hgeometry            >=0.11.0.0,+    hgeometry-combinatorial >=0.11.0.0,+    lens                 >=4.16.1,+    linear               >=1.20.8,+    matrix               >=0.3.6.1,+    mtl                  >=2.2.2,+    neat-interpolation   >=0.3,+    open-browser         >=0.2.1.0,+    optparse-applicative >=0.14.2.0,+    parallel             >=3.2.1.0,+    process              >=1.6.3.0,+    random               >=1.1,+    random-shuffle       >=0.0.4,+    reanimate-svg        >=0.10.0.0,+    split                >=0.2.3.3,+    temporary            >=1.3,+    text                 >=1.2.3.0,+    time                 >=1.8.0.0,+    vector               >=0.12.0.0,+    vector-space         >=0.13,+    websockets           >=0.12.7.0,+    xml                  >=1.3.14   ghc-options: -Wall -fno-ignore-asserts  test-suite spec@@ -145,16 +148,15 @@     Properties     Helpers   hs-source-dirs: test-  if !flag(test) {-    Buildable: False-  }   ghc-options: -w   build-depends:     base,     directory,     filepath,     bytestring, process,-    reanimate, vector, linear,+    reanimate,+    vector, linear,     QuickCheck >= 2.1.0, text,+    temporary,     tasty, tasty-golden, tasty-hunit,     tasty-quickcheck, tasty-rerun >= 1.1.17

@@ -0,0 +1,344 @@+{-# LANGUAGE DeriveFoldable         #-}+{-# LANGUAGE DeriveFunctor          #-}+{-# LANGUAGE DeriveTraversable      #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses  #-}+{-# LANGUAGE UndecidableInstances   #-}+{-|+Module      : Geom2D.CubicBezier.Linear+Copyright   : Written by David Himmelstrup+License     : Unlicense+Maintainer  : lemmih@gmail.com+Stability   : experimental+Portability : POSIX++Convenience wrapper around 'Geom2D.CubicBezier'++-}+module Geom2D.CubicBezier.Linear+  ( AnyBezier(..)+  , CubicBezier(..)+  , QuadBezier(..)+  , OpenPath(..)+  , ClosedPath(..)+  , PathJoin(..)+  , ClosedMetaPath(..)+  , OpenMetaPath(..)+  , MetaJoin(..)+  , MetaNodeType(..)+  , FillRule(..)+  , Tension(..)+  , quadToCubic+  , arcLength+  , arcLengthParam+  , C.splitBezier+  , colinear+  , evalBezier+  , evalBezierDeriv+  , bezierHoriz+  , bezierVert+  , C.bezierSubsegment+  , C.reorient+  , closedPathCurves+  , openPathCurves+  , curvesToClosed+  , closest+  , unmetaOpen+  , unmetaClosed+  , union+  , bezierIntersection+  , interpolateVector+  , vectorDistance+  , findBezierInflection+  , findBezierCusp+  ) where++import qualified Data.Vector.Unboxed as V+import qualified Geom2D.CubicBezier  as C+import           Graphics.SvgTree    (FillRule (..))+import           Linear.V2++------------------------------------------------------------+-- Data types++-- | A bezier curve of any degree.+newtype AnyBezier a = AnyBezier (V.Vector (V2 a))++-- | A cubic bezier curve.+data CubicBezier a = CubicBezier+  { cubicC0 :: !(V2 a)+  , cubicC1 :: !(V2 a)+  , cubicC2 :: !(V2 a)+  , cubicC3 :: !(V2 a)+  } deriving (Show, Eq)++-- | A quadratic bezier curve.+data QuadBezier a = QuadBezier+  { quadC0 :: !(V2 a)+  , quadC1 :: !(V2 a)+  , quadC2 :: !(V2 a)+  } deriving (Show, Eq)++-- | Open cubicbezier path.+data OpenPath a = OpenPath [(V2 a, PathJoin a)] (V2 a)+  deriving (Show, Eq)++-- | Closed cubicbezier path.+data ClosedPath a = ClosedPath [(V2 a, PathJoin a)]+  deriving (Show, Eq)++-- | Join two points with either a straight line or a bezier+--   curve with two control points.+data PathJoin a+  = JoinLine+  | JoinCurve (V2 a) (V2 a)+  deriving (Show, Eq)++-- | Closed meta path.+data ClosedMetaPath a = ClosedMetaPath [(V2 a, MetaJoin a)]+  deriving (Show, Eq)++-- | Open meta path+data OpenMetaPath a = OpenMetaPath [(V2 a, MetaJoin a)] (V2 a)+  deriving (Show, Eq)++-- | The tension value specifies how /tense/ the curve is.+--   A higher value means the curve approaches a line segment,+--   while a lower value means the curve is more round. Metafont+--   doesn't allow values below 3/4.+data Tension a+  = Tension+  { tensionValue :: a }+  | TensionAtLeast -- ^ Like Tension, but keep the segment inside the+                   --   bounding triangle defined by the control points,+                   --   if there is one.+  { tensionValue :: a }+  deriving (Functor, Foldable, Traversable, Eq, Show)++-- | Join two meta points with either a bezier curve or tension+--   contraints.+data MetaJoin a+  = MetaJoin+  { metaTypeL :: MetaNodeType a+  , tensionL  :: Tension a+  , tensionR  :: Tension a+  , metaTypeR :: MetaNodeType a+  }+  | Controls (V2 a) (V2 a)+  deriving (Show, Eq)++-- | Node constraint type.+data MetaNodeType a+  = Open+  | Curl { curlgamma :: a }+  | Direction { nodedir :: V2 a }+  deriving (Show, Eq)++------------------------------------------------------------+-- Methods++-- | Convert a quadratic bezier to a cubic bezier.+quadToCubic :: Fractional a => QuadBezier a -> CubicBezier a+quadToCubic = upCast . C.quadToCubic . downCast++-- | @arcLength c t tol@ finds the arclength of the bezier @c@ at @t@,+--   within given tolerance @tol@.+arcLength :: CubicBezier Double -> Double -> Double -> Double+arcLength bezier t tol = C.arcLength (downCast bezier) t tol++-- | @arcLengthParam c len tol@ finds the parameter where the curve @c@+--   has the arclength @len@, within tolerance @tol@.+arcLengthParam :: CubicBezier Double -> Double -> Double -> Double+arcLengthParam bezier t tol = C.arcLengthParam (downCast bezier) t tol++-- | Return @False@ if some points fall outside a line with a thickness of the given tolerance.+colinear :: CubicBezier Double -> Double -> Bool+colinear bezier tol = C.colinear (downCast bezier) tol++-- | Calculate a value on the bezier curve.+evalBezier :: (C.GenericBezier b, V.Unbox a, Fractional a) => b a -> a -> V2 a+evalBezier c p = upCast $ C.evalBezier c p++-- | Calculate a value and the first derivative on the curve.+evalBezierDeriv :: (V.Unbox a, Fractional a,C.GenericBezier b) => b a -> a -> (V2 a, V2 a)+evalBezierDeriv c p = upCast $ C.evalBezierDeriv c p++-- | Find the parameter where the bezier curve is horizontal.+bezierHoriz :: CubicBezier Double -> [Double]+bezierHoriz = C.bezierHoriz . downCast++-- | Find the parameter where the bezier curve is vertical.+bezierVert :: CubicBezier Double -> [Double]+bezierVert = C.bezierVert . downCast++-- | Create a normal path from a metapath.+unmetaOpen :: OpenMetaPath Double -> OpenPath Double+unmetaOpen = upCast . C.unmetaOpen . downCast++-- | Create a normal path from a metapath.+unmetaClosed :: ClosedMetaPath Double -> ClosedPath Double+unmetaClosed = upCast . C.unmetaClosed . downCast++-- | `O((n+m)*log(n+m))`, for n segments and m intersections.+--   Union of paths, removing overlap and rounding to the given tolerance.+union :: [ClosedPath Double] -> FillRule -> Double -> [ClosedPath Double]+union p fill tol = upCast (C.union (downCast p) (downCast fill) tol)++-- | Find the intersections between two Bezier curves, using the Bezier Clip algorithm.+--   Returns the parameters for both curves.+bezierIntersection :: CubicBezier Double -> CubicBezier Double -> Double -> [(Double, Double)]+bezierIntersection a b t = C.bezierIntersection (downCast a) (downCast b) t++-- | Find the closest value on the bezier to the given point, within tolerance.+--   Return the first value found.+closest :: CubicBezier Double -> V2 Double -> Double -> Double+closest c p t = C.closest (downCast c) (downCast p) t++-- | Return the closed path as a list of curves.+closedPathCurves :: Fractional a => ClosedPath a -> [CubicBezier a]+closedPathCurves = upCast . C.closedPathCurves . downCast++-- | Return the open path as a list of curves.+openPathCurves :: Fractional a => OpenPath a -> [CubicBezier a]+openPathCurves = upCast . C.openPathCurves . downCast++-- | Make an open path from a list of curves. The last control point of each curve is ignored.+curvesToClosed :: [CubicBezier a] -> ClosedPath a+curvesToClosed = upCast . C.curvesToClosed . downCast++-- | Interpolate between two vectors.+interpolateVector :: Num a => V2 a -> V2 a -> a -> V2 a+interpolateVector a b p = upCast $ C.interpolateVector (downCast a) (downCast b) p++-- | Distance between two vectors.+vectorDistance :: Floating a => V2 a -> V2 a -> a+vectorDistance a b = C.vectorDistance (downCast a) (downCast b)++-- | Find inflection points on the curve.+findBezierInflection :: CubicBezier Double -> [Double]+findBezierInflection = C.findBezierInflection . downCast++-- | Find the cusps of a bezier.+findBezierCusp :: CubicBezier Double -> [Double]+findBezierCusp = C.findBezierCusp . downCast++------------------------------------------------------------+-- Instances++instance C.GenericBezier QuadBezier where+  degree = C.degree . downCast+  toVector = C.toVector . downCast+  unsafeFromVector = upCast . C.unsafeFromVector++instance C.GenericBezier CubicBezier where+  degree = C.degree . downCast+  toVector = C.toVector . downCast+  unsafeFromVector = upCast . C.unsafeFromVector++instance C.GenericBezier AnyBezier where+  degree = C.degree . downCast+  toVector = C.toVector . downCast+  unsafeFromVector = upCast . C.unsafeFromVector++------------------------------------------------------------+-- Casting++class Cast a b | a -> b, b -> a where+  downCast :: a -> b+  upCast   :: b -> a++instance Cast a b => Cast [a] [b] where+  downCast = map downCast+  upCast = map upCast++instance (Cast a a', Cast b b') => Cast (a,b) (a',b') where+  downCast (a, b) = (downCast a, downCast b)+  upCast (a, b) = (upCast a, upCast b)++instance Cast (V2 a) (C.Point a) where+  downCast (V2 a b) = C.Point a b+  upCast (C.Point a b) = V2 a b++instance Cast FillRule C.FillRule where+  downCast FillEvenOdd = C.EvenOdd+  downCast FillNonZero = C.NonZero+  upCast C.EvenOdd = FillEvenOdd+  upCast C.NonZero = FillNonZero++instance Cast (CubicBezier a) (C.CubicBezier a) where+  downCast (CubicBezier a b c d) = C.CubicBezier+    (downCast a) (downCast b) (downCast c) (downCast d)+  upCast (C.CubicBezier a b c d) = CubicBezier+    (upCast a) (upCast b) (upCast c) (upCast d)++instance Cast (QuadBezier a) (C.QuadBezier a) where+  downCast (QuadBezier a b c) = C.QuadBezier+    (downCast a) (downCast b) (downCast c)+  upCast (C.QuadBezier a b c)= QuadBezier+    (upCast a) (upCast b) (upCast c)++instance V.Unbox a => Cast (AnyBezier a) (C.AnyBezier a) where+  downCast (AnyBezier arr) = C.AnyBezier $+    V.map (\(V2 a b) -> (a,b)) arr+  upCast (C.AnyBezier arr) = AnyBezier $+    V.map (\(a, b) -> V2 a b) arr++instance Cast (MetaNodeType a) (C.MetaNodeType a) where+  downCast Open            = C.Open+  downCast (Curl gamma)    = C.Curl gamma+  downCast (Direction dir) = C.Direction (downCast dir)+  upCast C.Open            = Open+  upCast (C.Curl gamma)    = Curl gamma+  upCast (C.Direction dir) = Direction (upCast dir)++instance Cast (Tension a) (C.Tension a) where+  downCast (Tension v)        = C.Tension v+  downCast (TensionAtLeast v) = C.TensionAtLeast v+  upCast (C.Tension v)        = Tension v+  upCast (C.TensionAtLeast v) = TensionAtLeast v++instance Cast (MetaJoin a) (C.MetaJoin a) where+  downCast (MetaJoin tyL tL tR tyR) =+    C.MetaJoin (downCast tyL) (downCast tL) (downCast tR) (downCast tyR)+  downCast (Controls p1 p2) = C.Controls (downCast p1) (downCast p2)+  upCast (C.MetaJoin tyL tL tR tyR) =+    MetaJoin (upCast tyL) (upCast tL) (upCast tR) (upCast tyR)+  upCast (C.Controls p1 p2)         = Controls (upCast p1) (upCast p2)++instance Cast (PathJoin a) (C.PathJoin a) where+  downCast JoinLine        = C.JoinLine+  downCast (JoinCurve a b) = C.JoinCurve (downCast a) (downCast b)+  upCast C.JoinLine        = JoinLine+  upCast (C.JoinCurve a b) = JoinCurve (upCast a) (upCast b)++instance Cast (OpenMetaPath a) (C.OpenMetaPath a) where+  downCast (OpenMetaPath lst end) = C.OpenMetaPath+    [ (downCast p, downCast j)+    | (p, j) <- lst ] (downCast end)+  upCast (C.OpenMetaPath lst end) = OpenMetaPath+    [ (upCast p, upCast j)+    | (p, j) <- lst ] (upCast end)++instance Cast (ClosedMetaPath a) (C.ClosedMetaPath a) where+  downCast (ClosedMetaPath lst) = C.ClosedMetaPath+    [ (downCast p, downCast j)+    | (p, j) <- lst ]+  upCast (C.ClosedMetaPath lst) = ClosedMetaPath+    [ (upCast p, upCast j)+    | (p, j) <- lst ]++instance Cast (OpenPath a) (C.OpenPath a) where+  downCast (OpenPath lst end) = C.OpenPath+    [ (downCast p, downCast j)+    | (p, j) <- lst ] (downCast end)+  upCast (C.OpenPath lst end) = OpenPath+    [ (upCast p, upCast j)+    | (p, j) <- lst ] (upCast end)++instance Cast (ClosedPath a) (C.ClosedPath a) where+  downCast (ClosedPath lst) = C.ClosedPath+    [ (downCast p, downCast j)+    | (p, j) <- lst ]+  upCast (C.ClosedPath lst) = ClosedPath+    [ (upCast p, upCast j)+    | (p, j) <- lst ]

@@ -8,8 +8,8 @@ Portability : POSIX  Reanimate is an animation library based on SVGs. It is designed to act like glue-between external components such as 'latex', 'ffmpeg', 'gnuplot', 'diagrams',-and 'povray'.+between external components such as \'latex\', \'ffmpeg\', \'gnuplot\', \'diagrams\',+and \'povray\'.  = Canvas @@ -39,7 +39,7 @@     SVG,     Time,     Duration,-    Animation(..),+    Animation,     mkAnimation,     animate,     staticFrame,@@ -70,12 +70,11 @@     fromToS,     reverseS,     curveS,+    powerS,     bellS,     oscillateS,-    fromListS,     cubicBezierS,     -- ** Scenes-    (#),     Scene   , ZIndex   , sceneAnimation    -- :: (forall s. Scene s a) -> Animation@@ -116,7 +115,8 @@   , spriteTween       -- :: Sprite s -> Duration -> (Double -> SVG -> SVG) -> Scene s ()   , spriteVar         -- :: Sprite s -> a -> (a -> SVG -> SVG) -> Scene s (Var s a)   , spriteE           -- :: Sprite s -> Effect -> Scene s ()-  , spriteZ,          -- :: Sprite s -> ZIndex -> Scene s ()+  , spriteZ           -- :: Sprite s -> ZIndex -> Scene s ()+  , spriteScope,      -- :: Scene s a -> Scene s a      -- ** Effects     Effect,

@@ -1,8 +1,20 @@+{-|+Module      : Reanimate.Animation+Copyright   : Written by David Himmelstrup+License     : Unlicense+Maintainer  : lemmih@gmail.com+Stability   : experimental+Portability : POSIX++Declarative animation API based on combinators. For a higher-level interface,+see 'Reanimate.Scene'.++-} module Reanimate.Animation   ( Duration   , Time   , SVG-  , Animation(..) -- TODO should this be exposed? The constructor is used directly in Effect.hs+  , Animation   -- * Creating animations   , mkAnimation   , animate@@ -27,7 +39,6 @@   , pauseAtEnd   , pauseAtBeginning   , pauseAround-  , pauseUntil   , repeatA   , reverseA   , playThenReverseA@@ -35,7 +46,6 @@   , freezeAtPercentage   , addStatic   -- * Misc-  , (#)   , getAnimationFrame   , Sync(..)   -- * Rendering@@ -60,11 +70,13 @@ -- | Time signal. Goes from 0 to 1, inclusive. type Time = Double +-- | SVG node. type SVG = Tree  -- | Animations are SVGs over a finite time. data Animation = Animation Duration (Time -> SVG) +-- | Construct an animation with a given duration. mkAnimation :: Duration -> (Time -> SVG) -> Animation mkAnimation = Animation @@ -183,9 +195,11 @@   where     t' = clamp 0 1 (t/d) +-- | Helper function for pretty-printing SVG nodes. renderTree :: SVG -> String renderTree t = maybe "" ppElement $ xmlOfTree t +-- | Helper function for pretty-printing SVG nodes as SVG documents. renderSvg :: Maybe Number -- ^ The number to use as value of the @width@ attribute of the resulting top-level svg element. If @Nothing@, the width attribute won't be rendered.           -> Maybe Number -- ^ Similar to previous argument, but for @height@ attribute.           -> SVG          -- ^ SVG to render@@ -247,11 +261,6 @@ pauseAround :: Duration -> Duration -> Animation -> Animation pauseAround start end = pauseAtEnd end . pauseAtBeginning start --- XXX: Rename to 'setDurationFreeze'. Add 'setDurationDrop' and---      'setDurationLoop'.-pauseUntil :: Duration -> Animation -> Animation-pauseUntil d a = pauseAtEnd (d-duration a) a- -- Freeze frame at time @t@. freezeFrame :: Time -> Animation -> (Time -> SVG) freezeFrame t (Animation d f) = const $ f (t/d)@@ -354,6 +363,7 @@   where     len' = d - clamp 0 d len +-- | @lastA duration animation@ return the last @duration@ seconds of the animation. lastA :: Duration -> Animation -> Animation lastA len a = dropA (duration a - len) a @@ -362,9 +372,10 @@   | a < b     = max a (min b number)   | otherwise = max b (min a number) -(#) :: a -> (a -> b) -> b-o # f = f o+-- (#) :: a -> (a -> b) -> b+-- o # f = f o +-- | Ask for an animation frame using a given synchronization policy. getAnimationFrame :: Sync -> Animation -> Time -> Duration -> SVG getAnimationFrame sync (Animation aDur aGen) t d =   case sync of@@ -375,6 +386,7 @@   where     takeFrac f = snd (properFraction f :: (Int, Double)) +-- | Animation synchronization policies. data Sync   = SyncStretch   | SyncLoop

@@ -1,40 +1,73 @@ {-# LANGUAGE OverloadedStrings #-}+{-|+  [Blender](https://www.blender.org/) is a free and open-source 3D graphics toolkit.+  It is usually used through a graphical user-interface but can also be+  scripted via Python. These Blender scripts can access 100% of Blender's+  functionality and offer a convenient way of coding 3D effects.++  Running Blender can be time-consuming but heavy caching means scripts+  are only run when they change.++  Blender cheatsheet:++> # To generate with a transparent background, set film_transparent = True:+> bpy.context.scene.render.film_transparent = True+>+> # Filmic is great for photorealism but bad for animations.+> # If you want your textures to keep their exact color values,+> # set the view_transform to 'Standard':+> bpy.context.scene.view_settings.view_transform = 'Standard'+>+> # Blender's default render engine is 'EEVEE', fast but not a raytracer.+> # To switch to raytracing, set the engine to 'CYCLES':+> bpy.context.scene.render.engine = 'CYCLES'+>+> # Rendering at full resolution can be slow. When developing, try+> # decreasing the resolution_percentage for faster renders.+> bpy.context.scene.render.resolution_percentage = 10+>+> # The resolution of the final image are set by resolution_x and resolution_y:+> bpy.context.scene.render.resolution_x = 320+> bpy.context.scene.render.resolution_y = 180++-} module Reanimate.Blender   ( blender   , blender'   ) where -import           Codec.Picture.Png-import qualified Data.ByteString            as B+import           Data.Hashable import           Data.Text                  (Text)--- import qualified Data.Text                  as T import qualified Data.Text.IO               as T import           Graphics.SvgTree           (Tree (..))+import           Reanimate.Animation import           Reanimate.Cache+import           Reanimate.Constants import           Reanimate.Misc-import           Reanimate.Raster import           Reanimate.Parameters-import           Reanimate.Animation+import           Reanimate.Raster import           Reanimate.Svg.Constructors import           System.FilePath            (replaceExtension, (<.>)) import           System.IO.Unsafe           (unsafePerformIO)-import           Data.Hashable +-- | Run a Blender script and embed the resulting image file. The+--   image will be scaled to fit the screen exactly (assuming a default+--   canvas layout). Note that Blender resolution defaults to 1920x1080+--   but can be changed in the script code. blender :: Text -> SVG blender script =   unsafePerformIO $ mkBlenderImage script +-- | Generate Blender image as a separate PNG file. Can be embedded with+--   `mkImage`. blender' :: Text -> FilePath blender' script =   unsafePerformIO $ mkBlenderImage' script  mkBlenderImage :: Text -> IO Tree mkBlenderImage script | pNoExternals = pure $ mkText script-mkBlenderImage script = do-    png <- B.readFile =<< mkBlenderImage' script-    case decodePng png of-      Left{}    -> error "bad image"-      Right img -> return $ center $ scaleToSize 16 9 $ embedDynamicImage img+mkBlenderImage script =+  mkImage screenWidth screenHeight <$> mkBlenderImage' script  mkBlenderImage' :: Text -> IO FilePath mkBlenderImage' _ | pNoExternals = pure "/blender/has/been/disabled"@@ -46,4 +79,4 @@                 , "--python-exit-code", "1"                 , "--render-output", target, "--python", py_file]   where-    template = show (hash script) <.> "png"+    template = encodeInt (hash script) <.> "png"

@@ -1,3 +1,14 @@+{-|+Module      : Reanimate.Builtin.CirclePlot+Copyright   : Written by David Himmelstrup+License     : Unlicense+Maintainer  : lemmih@gmail.com+Stability   : experimental+Portability : POSIX++Convenience module for rendering circle plots.++-} module Reanimate.Builtin.CirclePlot where  import           Codec.Picture

@@ -1,3 +1,15 @@+{-|+Module      : Reanimate.Builtin.Documentation+Copyright   : Written by David Himmelstrup+License     : Unlicense+Maintainer  : lemmih@gmail.com+Stability   : experimental+Portability : POSIX++This module contains convenience functions used in documention+GIFs for a consistent look and feel.++-} module Reanimate.Builtin.Documentation where  import Reanimate.Animation@@ -6,6 +18,7 @@ import Reanimate.Constants import Codec.Picture +-- | Default environment for API documentation GIFs. docEnv :: Animation -> Animation docEnv = mapA $ \svg -> mkGroup   [ mkBackground "white"@@ -25,11 +38,6 @@   partialSvg t $ pathify $   mkCircle (screenHeight/3) -drawBall :: Animation-drawBall = mkAnimation 2 $ \t ->-  scale t $ withFillOpacity 1 $ withFillColor "red" $-  mkCircle (screenHeight/3)- -- | <<docs/gifs/doc_drawProgress.gif>> drawProgress :: Animation drawProgress = mkAnimation 2 $ \t ->@@ -41,6 +49,7 @@   where     widthP = 0.8 +-- | Render a full-screen view of a color-map. showColorMap :: (Double -> PixelRGB8) -> SVG showColorMap f = center $ scaleToSize screenWidth screenHeight $ embedImage img   where@@ -49,5 +58,6 @@     img = generateImage pixelRenderer width height     pixelRenderer x _y = f (fromIntegral x / fromIntegral (width-1)) +-- | Default background color for videos on reanimate.rtfd.io rtfdBackgroundColor :: PixelRGBA8 rtfdBackgroundColor = PixelRGBA8 252 252 252 0xFF

@@ -3,11 +3,17 @@ {-# LANGUAGE RecordWildCards   #-} {-# LANGUAGE ApplicativeDo     #-} {- HLINT ignore -}+{-|+Copyright   : Written by David Himmelstrup+License     : Unlicense+Maintainer  : lemmih@gmail.com+Stability   : experimental+Portability : POSIX+-} module Reanimate.Builtin.Flip   ( FlipSprite(..)   , flipSprite   , flipTransition-  , flipTransitionOpts   ) where  import           Reanimate.Animation@@ -21,6 +27,7 @@ import           NeatInterpolation (text) import qualified Data.Text           as T +-- | Control structure with parameters for the blender script. data FlipSprite s = FlipSprite   { fsSprite :: Sprite s   , fsBend   :: Var s Double@@ -28,6 +35,8 @@   , fsWobble :: Var s Double   } +-- | Project two animations on each side of a plane and flip the plane+--   upside down. flipSprite :: Animation -> Animation -> Scene s (FlipSprite s) flipSprite front back = do     bend <- newVar 0@@ -61,6 +70,7 @@   where     dur = max (duration a) (duration b) +-- | 3D flip transition. flipTransition :: Transition flipTransition = flipTransitionOpts bend zoom wobble   where

@@ -1,3 +1,14 @@+{-|+Module      : Reanimate.Builtin.Images+Copyright   : Written by David Himmelstrup+License     : Unlicense+Maintainer  : lemmih@gmail.com+Stability   : experimental+Portability : POSIX++Collection of built-in images.++-} module Reanimate.Builtin.Images   ( svgLogo   , haskellLogo@@ -46,6 +57,7 @@ githubIcon = unsafePerformIO $ embedImage "data/github-icon.svg"  {-# NOINLINE githubWhiteIcon #-}+-- | <<docs/gifs/doc_githubWhiteIcon.gif>> githubWhiteIcon :: SVG githubWhiteIcon = unsafePerformIO $ embedImage "data/github-icon-white.svg" 

@@ -1,3 +1,10 @@+{-|+Copyright   : Written by David Himmelstrup+License     : Unlicense+Maintainer  : lemmih@gmail.com+Stability   : experimental+Portability : POSIX+-} module Reanimate.Builtin.Slide where  import Reanimate.Transition@@ -13,6 +20,7 @@     moveRight = constE (translate screenWidth 0)     andE a b d t = a d t . b d t +-- | <<docs/gifs/doc_slideDownT.gif>> slideDownT :: Transition slideDownT = effectT slideDown (andE slideDown moveUp)   where@@ -20,6 +28,7 @@     moveUp = constE (translate 0 screenHeight)     andE a b d t = a d t . b d t +-- | <<docs/gifs/doc_slideUpT.gif>> slideUpT :: Transition slideUpT = effectT slideUp (andE slideUp moveDown)   where

@@ -1,19 +1,56 @@-module Reanimate.Builtin.TernaryPlot where+{-|+Module      : Reanimate.Builtin.TernaryPlot+Copyright   : Written by David Himmelstrup+License     : Unlicense+Maintainer  : lemmih@gmail.com+Stability   : experimental+Portability : POSIX +Implementation of ternary plots: <https://en.wikipedia.org/wiki/Ternary_plot>++-}+module Reanimate.Builtin.TernaryPlot+  ( ACoord+  , BCoord+  , CCoord+  , ternaryPlot+  -- , atCenter+  -- , radius+  , toCartesianCoords+  , toOffsetCartesianCoords+  , fromCartesianCoords+  ) where+ import           Codec.Picture import           Graphics.SvgTree (Tree) import           Reanimate.Raster import           Reanimate.Svg --- (top, left, right) -- a+b+c=1+-- | Left-most coordinate. type ACoord = Double+-- | Top-most coordinate. type BCoord = Double+-- | Right-most coordinate. type CCoord = Double --- Creates a centered ternary plot with a width of 5.-ternaryPlot :: Int -- ^ Pixels in the X-axis.-            -> (ACoord -> BCoord -> CCoord -> PixelRGBA8) -> Tree+-- | Creates a centered ternary plot with a width of 5.+--+--   Example:+--+--   > ternaryPlot 100 $ \aCoord bCoord cCoord -> promotePixel $+--   >   let red   = round $ aCoord*255+--   >       green = round $ bCoord*255+--   >       blue  = round $ cCoord*255+--   >   in PixelRGB8 red green blue+--+--   <<docs/gifs/doc_ternaryPlot.gif>>+ternaryPlot :: Int -- ^ Pixels in the X-axis. More pixels => higher quality.+            -> (ACoord -> BCoord -> CCoord -> PixelRGBA8)+            -- ^ a+b+c=1. A=1 is the left-most position,+            --   B=1 is the top-most position, and+            --   C=1 is the right-most position.+            -> Tree ternaryPlot density fn =     scaleToWidth stdWidth $     translate (-cX) (-cY) $@@ -36,22 +73,27 @@         then PixelRGBA8 0 0 0 0         else fn aCoord bCoord cCoord -atCenter :: Double -> Tree -> Tree-atCenter stdWidth = translate (-cX*stdWidth) (-cY*stdWidth)-  where-    (cX, cY) = toCartesianCoords (1/3) (1/3)+-- atCenter :: Double -> Tree -> Tree+-- atCenter stdWidth = translate (-cX*stdWidth) (-cY*stdWidth)+--   where+--     (cX, cY) = toCartesianCoords (1/3) (1/3) -radius :: Double-radius = sqrt (cX*cX + cY*cY)-  where-    (cX, cY) = toCartesianCoords (1/3) (1/3)+-- radius :: Double+-- radius = sqrt (cX*cX + cY*cY)+--   where+--     (cX, cY) = toCartesianCoords (1/3) (1/3) +-- | Compute the XY coordinates from ternary coordinates.+--   Note that @CCoord@ is given because @a+b+c=1@. toCartesianCoords :: ACoord -> BCoord -> (Double, Double) toCartesianCoords a b = (x, y)   where     x = (a+2*b)/2     y = (sqrt 3 / 2) * a +-- | Compute the XY coordinates relative from the center of the+--   ternary plot.+--   Note that @CCoord@ is given because @a+b+c=1@. toOffsetCartesianCoords :: ACoord -> BCoord -> (Double, Double) toOffsetCartesianCoords a b =     (tx-zx, ty-zy)@@ -59,6 +101,7 @@     (zx,zy) = toCartesianCoords (1/3) (1/3)     (tx,ty) = toCartesianCoords a b +-- | Compute ternary coordinates from XY coordinates. fromCartesianCoords :: Double -> Double -> (ACoord, BCoord, CCoord) fromCartesianCoords x y = (a,b,1-a-b)   where

@@ -1,97 +0,0 @@-module Reanimate.Chiphunk-  ( simulate-  , BodyStore-  , newBodyStore-  , addToBodyStore-  , spaceFreeRecursive-  , polyShapesToBody-  , polygonsToBody-  ) where--import           Chiphunk.Low-import           Control.Monad-import           Data.IORef-import           Data.Map            (Map)-import qualified Data.Map            as Map-import qualified Data.Vector         as V-import qualified Data.Vector.Mutable as V-import           Foreign.Ptr-import           Graphics.SvgTree    (Tree)-import           Linear.V2 (V2(..))-import           Reanimate.Animation-import           Reanimate.PolyShape-import           Reanimate.Svg.Constructors--type BodyStore = IORef (Map WordPtr Tree)--newBodyStore :: IO BodyStore-newBodyStore = newIORef Map.empty--addToBodyStore :: BodyStore -> Body -> Tree -> IO ()-addToBodyStore store body svg = do-  key <- atomicModifyIORef' store $ \m ->-          case Map.maxViewWithKey m of-            Nothing -> (Map.singleton 1 svg, 1)-            Just ((maxKey,_),_) ->-              (Map.insert (maxKey+1) svg m, maxKey+1)-  bodyUserData body $= wordPtrToPtr key--renderBodyStore :: Space -> BodyStore -> IO Tree-renderBodyStore space store = do-  m <- readIORef store-  lst <- newIORef []-  spaceEachBody space (\body _dat -> do-    key <- get (bodyUserData body)-    case Map.lookup (ptrToWordPtr key) m of-      Nothing -> putStrLn "Body doesn't have an associated SVG"-      Just svg -> do-        Vect posX posY <- get $ bodyPosition body-        angle <- get $ bodyAngle body-        let bodySvg =-              translate posX posY $-              rotate (angle/pi*180)-              svg-        modifyIORef lst (bodySvg:)-    ) nullPtr-  result <- readIORef lst-  return $ mkGroup result---simulate :: Space -> BodyStore -> Double -> Int -> Double -> IO Animation-simulate space store fps stepsPerFrame dur = do-  let timeStep = 1/(fps*fromIntegral stepsPerFrame)-      frames = round (dur * fps)-  v <- V.new frames-  forM_ [0..frames-1] $ \nth -> do-    svg <- renderBodyStore space store-    V.write v nth svg-    replicateM_ stepsPerFrame $ spaceStep space timeStep-  frozen <- V.unsafeFreeze v-  return $ mkAnimation dur $ \t ->-    let key = round (t * fromIntegral (frames-1))-    in frozen V.! key--polyShapesToBody :: Space -> [PolyShape] -> IO Body-polyShapesToBody space poly =-    polygonsToBody space (map (map toVect) $ plDecompose poly)-  where-    toVect (V2 x y) = Vect x y--polygonsToBody :: Space -> [[Vect]] -> IO Body-polygonsToBody space polygons = do-  plBody <- bodyNew 0 0-  spaceAddBody space plBody--  forM_ polygons $ \vects -> do-    polyShape <- polyShapeNewRaw plBody vects 0.00-    shapeDensity polyShape $= 1-    spaceAddShape space polyShape-    shapeFriction polyShape $= 0.7-    shapeElasticity polyShape $= 0.5-  return plBody--spaceFreeRecursive :: Space -> IO ()-spaceFreeRecursive space = do-  spaceEachBody space (\body _ -> bodyFree body) nullPtr-  spaceEachShape space (\shape _ -> shapeFree shape) nullPtr-  spaceFree space

@@ -1,6 +1,27 @@ {-# LANGUAGE RecordWildCards #-}-module Reanimate.ColorComponents where+{- |+  Colors are three dimensional and can be projected into many color spaces+  with different properties. +  Interpolating directly in the RGB color space is unintuitive and rarely useful.+  If you want to transition through color, you most likely want either the XYZ space+  (for physically accurate color transitions) or the LAB space (for esthetically+  pleasing colors).+-}+module Reanimate.ColorComponents+  ( ColorComponents(..)+  , rgbComponents+  , hsvComponents+  , labComponents+  , xyzComponents+  , lchComponents+  , interpolate+  , interpolateRGB8+  , interpolateRGBA8+  , toRGB8+  , fromRGB8+  ) where+ import           Codec.Picture import           Codec.Picture.Types import           Data.Colour@@ -12,9 +33,13 @@ import           Data.Fixed import           Reanimate.Ease +-- | Constructor and destructor for color's three components. data ColorComponents = ColorComponents   { colorUnpack :: Colour Double -> (Double, Double, Double)-  , colorPack   :: Double -> Double -> Double -> Colour Double }+    -- ^ Unpack a color into its three components.+  , colorPack   :: Double -> Double -> Double -> Colour Double+    -- ^ Restore a color from three coordinates.+  }  -- | > interpolate rgbComponents yellow blue --@@ -71,6 +96,7 @@     pack l c h =       cieLAB d65 l (cos (toRad h) * c) (sin (toRad h) * c) +-- | Smoothly interpolate between two colors using the given color components. interpolate :: ColorComponents -> Colour Double -> Colour Double -> (Double -> Colour Double) interpolate ColorComponents{..} from to = \d ->     colorPack (a1 + (a2-a1)*d) (b1 + (b2-b1)*d) (c1 + (c2-c1)*d)@@ -78,9 +104,11 @@     (a1,b1,c1) = colorUnpack from     (a2,b2,c2) = colorUnpack to +-- | Convenience interpolation function for RGB8 values. interpolateRGB8 :: ColorComponents -> PixelRGB8 -> PixelRGB8 -> (Double -> PixelRGB8) interpolateRGB8 comps from to = toRGB8 . interpolate comps (fromRGB8 from) (fromRGB8 to) +-- | Convenience interpolation function for RGBA8 values. interpolateRGBA8 :: ColorComponents -> PixelRGBA8 -> PixelRGBA8 -> (Double -> PixelRGBA8) interpolateRGBA8 comps from to = \t ->   case interp t of@@ -90,10 +118,12 @@   where     interp = interpolateRGB8 comps (dropTransparency from) (dropTransparency to) +-- | Convenience function for expressing a color as an RGB8 value. toRGB8 :: Colour Double -> PixelRGB8 toRGB8 c = PixelRGB8 r g b   where     RGB r g b = toSRGBBounded c +-- | Convenience function for expressing an RGB8 value as a color. fromRGB8 :: PixelRGB8 -> Colour Double fromRGB8 (PixelRGB8 r g b) = sRGB24 r g b

@@ -1,4 +1,9 @@ {-# LANGUAGE OverloadedStrings #-}+{-|+  A colormap takes a number between 0 and 1 (inclusive) and spits out a color.+  The colors do not have an alpha component but one can be added with+  `Codec.Picture.Types.promotePixel`.+-} module Reanimate.ColorMap   ( turbo   , viridis

@@ -1,8 +1,20 @@-module Reanimate.ColorSpace where+{-|+Copyright   : Written by David Himmelstrup+License     : Unlicense+Maintainer  : lemmih@gmail.com+Stability   : experimental+Portability : POSIX+-}+module Reanimate.ColorSpace+  ( Nanometer+  , coneSensitivity+  , bigXYZCoordinates+  , lightXYZCoordinates+  , nmToColor+  ) where  import qualified Data.ByteString.Lazy       as BS import           Data.Colour.CIE-import           Data.Colour.CIE.Illuminant (d65) import           Data.Csv import           Data.Map                   (Map) import qualified Data.Map                   as Map@@ -11,12 +23,11 @@ import           Paths_reanimate import           System.IO.Unsafe -import           Graphics.SvgTree           (Tree)-import           Reanimate.Svg.Constructors-+-- | Wavelengths in nanometers. type Nanometer = Integer  {-# NOINLINE lightXYZCoordinates #-}+-- | (small) xyz values for each wavelength of light. lightXYZCoordinates :: Map Nanometer (Double, Double, Double) lightXYZCoordinates = unsafePerformIO $ do   dat <- BS.readFile =<< getDataFileName "data/CIExyz.csv"@@ -26,6 +37,7 @@       [ (nm, (x,y,z)) | (nm,x,y,z) <- V.toList vec, nm <= 700 ]  {-# NOINLINE bigXYZCoordinates #-}+-- | (big) XYZ values for each wavelength of light. bigXYZCoordinates :: Map Nanometer (Double, Double, Double) bigXYZCoordinates = unsafePerformIO $ do   dat <- BS.readFile =<< getDataFileName "data/CIE_XYZ.csv"@@ -34,34 +46,16 @@     Right vec -> return $ Map.fromList       [ (nm, (x,y,z)) | (nm,x,y,z) <- V.toList vec, nm <= 700 ] +-- | Helper function for converting a wavelength of light into the+--   perceived color. nmToColor :: Nanometer -> Maybe (Colour Double) nmToColor nm = do   (x, y, z) <- Map.lookup nm bigXYZCoordinates   return $ cieXYZ x y z -renderXYZCoordinates :: Tree-renderXYZCoordinates =-  withFillOpacity 0 $-  mkLinePath-  [ (x, 1-y)-  | (_nm, (x,y,_z)) <- Map.toList lightXYZCoordinates-  ]--lightLABCoordinates :: Map Nanometer (Double, Double, Double)-lightLABCoordinates = Map.map fn lightXYZCoordinates-  where-    fn (x,y,z) = cieLABView d65 (cieXYZ x y z)--renderLABCoordinates :: Tree-renderLABCoordinates =-  withFillOpacity 0 $-  mkLinePath-  [ (a/350, (1-b)/150)-  | (_nm, (_l,a,b)) <- Map.toList lightLABCoordinates-  ]- {-# NOINLINE coneSensitivity #-} -- (Long, Medium, Short)+-- | Cone sensitivity by light wavelength. coneSensitivity :: Map Nanometer (Double, Double, Double) coneSensitivity = unsafePerformIO $ do   dat <- BS.readFile =<< getDataFileName "data/cone_sensitivity_lms.csv"@@ -69,19 +63,3 @@     Left err -> error err     Right vec -> return $ Map.fromList       [ (nm, (l,m,fromMaybe 0 s)) | (nm,l,m,s) <- V.toList vec, nm <= 700 ]--renderSensitivity :: Tree-renderSensitivity = mkGroup-  [ withStrokeColor "blue"  $ draw (\(_,_,s) -> s)-  , withStrokeColor "green" $ draw (\(_,m,_) -> m)-  , withStrokeColor "red"   $ draw (\(l,_,_) -> l)-  ]-  where-    draw fn = withFillOpacity 0 $ mkLinePath-      [ (fromIntegral (ang-minAng) / maxAng * width, fn val * height)-      | (ang, val) <- Map.toList coneSensitivity-      ]-    width = 100-    height = -50-    maxAng = fromIntegral $ fst (Map.findMax coneSensitivity) - minAng-    minAng = fst (Map.findMin coneSensitivity)

@@ -1,3 +1,8 @@+{- |+  Reanimate configures a consistent, default canvas. The values of this default+  can be observed via the constants in this module. Keep in mind, these values+  describe the /default/ canvas and will not apply to custom viewports.+-} module Reanimate.Constants   ( screenWidth   , screenHeight@@ -11,9 +16,24 @@  import           Graphics.SvgTree -screenWidth, screenHeight, screenTop :: Fractional a => a-screenBottom, screenLeft, screenRight :: Fractional a => a+-- | Number of units from the left-most point to the right-most point on the screen.+screenWidth :: Fractional a => a +-- | Number of units from the bottom to the top of the screen.+screenHeight :: Fractional a => a++-- | Position of the top of the screen.+screenTop :: Fractional a => a++-- | Position of the bottom of the screen.+screenBottom :: Fractional a => a++-- | Position of the left side of the screen.+screenLeft :: Fractional a => a++-- | Position of the right side of the screen.+screenRight :: Fractional a => a+ screenWidth = 16 screenHeight = 9 screenTop = screenHeight/2@@ -21,8 +41,11 @@ screenLeft = -screenWidth/2 screenRight = screenWidth/2 +-- | SVG allows measurements in inches which have to be converted to local units.+--   This value describes how many local units there are in an inch. defaultDPI :: Dpi defaultDPI = 96 +-- | Default thickness of lines. defaultStrokeWidth :: Double defaultStrokeWidth = 0.05

@@ -1,3 +1,10 @@+{-|+Copyright   : Written by David Himmelstrup+License     : Unlicense+Maintainer  : lemmih@gmail.com+Stability   : experimental+Portability : POSIX+-} module Reanimate.Debug   ( traceSVG   , traceA@@ -20,16 +27,19 @@ traceBuffer = unsafePerformIO (newIORef [])  {-# NOINLINE traceSVG #-}+-- | Add SVG image to trace stack. traceSVG :: SVG -> a -> a traceSVG = traceA . staticFrame (recip 60)  {-# NOINLINE traceA #-}+-- | Add animation to trace stack. traceA :: Animation -> a -> a traceA a v = unsafePerformIO $ do   modifyIORef' traceBuffer (a :)   evaluate v  {-# NOINLINE playTraces #-}+-- | Evaluate argument and play back the trace stack. playTraces :: a -> Animation playTraces v = unsafePerformIO $ do   _   <- evaluate v

@@ -87,7 +87,7 @@ >   view                     Play animation in browser window. >   render                   Render animation to file. -Neither the 'check' nor the 'view' command take any additional arguments.+Neither the \'check\' nor the \'view\' command take any additional arguments. Rendering animation can be controlled with these arguments:  > Usage: PROG render [-o|--target FILE] [--fps FPS] [-w|--width PIXELS]@@ -109,7 +109,9 @@ reanimate animation = do   Options {..} <- getDriverOptions   case optsCommand of-    Raw  -> setFPS 60 >> renderSvgs animation+    Raw {..} -> do+      setFPS 60+      renderSvgs rawOutputFolder rawFrameOffset rawPrettyPrint animation     Test -> do       setNoExternals True       -- hSetBinaryMode stdout True

@@ -22,6 +22,10 @@  data Command   = Raw+    { rawOutputFolder :: FilePath+    , rawFrameOffset  :: Int+    , rawPrettyPrint  :: Bool+    }   | Test   | Check   | View@@ -99,14 +103,15 @@ options = Options <$> commandP  commandP :: Parser Command-commandP = subparser(command "raw" rawCommand-  <> command "test" testCommand+commandP = subparser(+     command "test" testCommand   <> commandGroup "Internal commands"   <> internal )   <|> hsubparser     ( command "check" checkCommand     <> command "view" viewCommand     <> command "render" renderCommand+    <> command "raw" rawCommand     )   <|> infoParser viewCommand @@ -114,7 +119,22 @@ rawCommand = info parse     (progDesc "Output raw SVGs for animation at 60 fps. Used internally by viewer.")   where-    parse = pure Raw+    parse = Raw+      <$> strOption+        ( long "output" <>+          short 'o' <>+          metavar "PATH" <>+          help "Output folder" <>+          value ".")+      <*> option auto+        ( long "offset" <>+          metavar "NUMBER" <>+          help "Frame offset" <>+          value 0)+      <*> switch+        ( long "pretty-print" <>+          short 'p' <>+          help "Pretty print svg")  testCommand :: ParserInfo Command testCommand = info (parse <**> helper)

@@ -6,12 +6,12 @@ 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.+-- 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+-- 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"

@@ -1,3 +1,4 @@+{-# LANGUAGE OverloadedStrings   #-} {-# LANGUAGE ScopedTypeVariables #-} module Reanimate.Driver.Server   ( serve@@ -5,30 +6,30 @@   ) where  import           Control.Concurrent-import           Control.Exception       (SomeException, catch, finally)+import           Control.Exception      (SomeException, catch, finally) import           Control.Monad-import           Control.Monad.Fix       (fix)-import           Data.Text               (Text)-import qualified Data.Text               as T-import qualified Data.Text.IO            as T-import qualified Data.Text.Read          as T-import           GHC.Environment         (getFullArgs)+import           Data.IORef+import           Data.Text              (Text)+import qualified Data.Text              as T+import qualified Data.Text.Read         as T+import           Data.Time+import           GHC.Environment        (getFullArgs)+import           Language.Haskell.Ghcid import           Network.WebSockets import           Paths_reanimate-import           Reanimate.Misc          (runCmdLazy, runCmd_)-import           System.Directory        (createDirectoryIfMissing,-                                          doesFileExist, findFile,-                                          listDirectory, makeAbsolute,-                                          removeDirectoryRecursive,-                                          withCurrentDirectory)-import           System.Environment      (getProgName)+import           Reanimate.Misc         (runCmdLazy, runCmd_)+import           System.Directory       (createDirectoryIfMissing,+                                         doesFileExist, findFile, listDirectory,+                                         makeAbsolute,+                                         withCurrentDirectory)+import           System.Environment     (getProgName) import           System.Exit-import           System.Process import           System.FilePath import           System.FSNotify import           System.IO import           System.IO.Temp-import           Web.Browser             (openBrowser)+import           System.Process+import           Web.Browser            (openBrowser)  opts :: ConnectionOptions opts = defaultConnectionOptions@@ -39,49 +40,56 @@   hSetBuffering stdin NoBuffering   self <- maybe requireOwnSource pure mbSelfPath   when verbose $-    putStrLn $ "Found own source code at: " ++ self+    logMsg $ "Found own source code at: " ++ self   hasConnectionVar <- newMVar False +  ghci <- ghciBackend mbGHCPath self+   -- There might already browser window open. Wait 2s to see if that window   -- connects to us. If not, open a new window.   _ <- forkIO $ do     threadDelay (2*10^(6::Int))     hasConn <- readMVar hasConnectionVar     unless hasConn openViewer--  putStrLn "Listening..."+  logMsg "Listening..."   let options = ServerOptions         { serverHost = "127.0.0.1"         , serverPort = 9161         , serverConnectionOptions = opts         , serverRequirePong = Nothing }-  runServerWithOptions options $ \pending -> do-    putStrLn "New connection received."-    hasConn <- swapMVar hasConnectionVar True-    if hasConn-      then do-        putStrLn "Already connected to browser. Rejecting."-        rejectRequestWith pending defaultRejectRequest-      else withSystemTempDirectory "reanimate-svgs" $ \tmpDir -> do-        createDirectoryIfMissing True tmpDir-        conn <- acceptRequest pending-        slave <- newEmptyMVar-        let handler = modifyMVar_ slave $ \tid -> do-              putStrLn "Reloading code..."-              killThread tid-              forkIO $ ignoreErrors $ slaveHandler verbose mbGHCPath extraGHCOpts conn self tmpDir-            killSlave = do-              tid <- takeMVar slave-              killThread tid-        stop <- watchFile watch self handler-        putMVar slave =<< forkIO (return ())-        handler-        let loop = do-              -- FIXME: We don't use msg here.-              _msg <- receiveData conn :: IO T.Text-              handler-              loop-        loop `finally` (removeDirectoryRecursive tmpDir >> swapMVar hasConnectionVar False >> stop >> killSlave)+  withSystemTempDirectory "reanimate-svgs" $ \tmpDir ->+    runServerWithOptions options $ \pending -> do+      logMsg "New connection received."+      hasConn <- swapMVar hasConnectionVar True+      if hasConn+        then do+          logMsg "Already connected to browser. Rejecting."+          rejectRequestWith pending defaultRejectRequest+        else do+          createDirectoryIfMissing True tmpDir+          conn <- acceptRequest pending+          slave <- newEmptyMVar+          let handler = modifyMVar_ slave $ \tid -> do+                logMsg "Reloading code..."+                killThread tid+                forkIO $ ignoreErrors $ slaveHandler verbose mbGHCPath extraGHCOpts conn ghci self tmpDir+              killSlave = do+                tid <- takeMVar slave+                killThread tid+          stop <- watchFile watch self handler+          putMVar slave =<< forkIO (return ())+          handler+          let loop = do+                -- FIXME: We don't use msg here.+                _msg <- receiveData conn :: IO T.Text+                handler+                loop+              cleanup = do+                stop+                killSlave+                _ <- swapMVar hasConnectionVar False+                return ()+          loop `finally` cleanup  ignoreErrors :: IO () -> IO () ignoreErrors action = action `catch` \(_::SomeException) -> return ()@@ -89,76 +97,97 @@ openViewer :: IO () openViewer = do   url <- getDataFileName "viewer-elm/dist/index.html"-  putStrLn "Opening browser..."+  logMsg "Opening browser..."   bSucc <- openBrowser url   if bSucc-      then putStrLn "Browser opened."+      then logMsg "Browser opened."       else hPutStrLn stderr $ "Failed to open browser. Manually visit: " ++ url -slaveHandler :: Bool -> Maybe FilePath -> [String] -> Connection -> FilePath -> FilePath -> IO ()-slaveHandler verbose mbGHCPath extraGHCOpts conn self svgDir =+slaveHandler :: Bool -> Maybe FilePath -> [String] -> Connection -> GhciBackend+             -> FilePath -> FilePath -> IO ()+slaveHandler verbose mbGHCPath extraGHCOpts conn ghci self svgDir =   withCurrentDirectory (takeDirectory self) $   withSystemTempDirectory "reanimate" $ \tmpDir ->   withTempFile tmpDir "reanimate.exe" $ \tmpExecutable handle -> do-    -- cap <- getNumCapabilities-    let n = 25-    sem <- newQSemN n+    outputFolder <- createTempDirectory svgDir "svgs"+    let frameFileName frameIdx =+          outputFolder </> show frameIdx <.> "svg"++    sentFrameCount <- newMVar False     hClose handle     lock <- newMVar ()-    sendTextData conn (T.pack "status\nCompiling")+    sendWebMessage conn $ WebStatus "Compiling"+    ghciThread <- forkIO $ do+      firstFrame <- newIORef True+      ghciReload ghci+      logMsg "GHCi reload done."+      ghciGenerate ghci outputFolder $ \frameIdx -> do+        first <- readIORef firstFrame+        writeIORef firstFrame False+        if first+          then do+            modifyMVar_ sentFrameCount $ \sent -> do+              unless sent $+                sendWebMessage conn $ WebFrameCount frameIdx+              logMsg "Framecount sent."+              return True+          else+            withMVar lock $ \_ ->+              sendWebMessage conn $ WebFrame frameIdx (frameFileName frameIdx)+      logMsg "GHCi render done."     ret <- case mbGHCPath of       Nothing -> do         let args = ["ghc", "--"] ++ ghcOptions tmpDir ++ extraGHCOpts ++ [takeFileName self, "-o", tmpExecutable]         when verbose $-          putStrLn $ "Running: " ++ showCommandForUser "stack" args+          logMsg $ "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+          logMsg $ "Running: " ++ showCommandForUser ghc args         runCmd_ ghc args+    logMsg "Compile done."     case ret of       Left 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)-        fix $ \loop -> do-          (frameIdx, frame) <- expectFrame sem =<< getFrame-          -- putStrLn $ "Got frame: " ++ show frameIdx-          let fileName = svgDir </> takeBaseName tmpExecutable <.> show frameIdx <.> "svg"-              -- pngName = replaceExtension fileName "png"-          _ <- forkIO $ do-            waitQSemN sem 1-            T.writeFile fileName frame-            -- runCmd "rsvg-convert"-            --   [ fileName-            --   , "--width=256" -- "--width=1024"-            --   , "--height=144" -- "--height=576"-            --   , "--output", pngName ]-            withMVar lock $ \_ ->-              sendTextData conn (T.pack $ "frame\n" ++ show frameIdx ++ "\n" ++ fileName)-            signalQSemN sem 1-          loop+        sendWebMessage conn $ WebError $ unlines (lines err)+      Right{} -> runCmdLazy tmpExecutable (execOpts outputFolder) $ \getFrame -> do+        frameCount <- expectFrame =<< getFrame+        modifyMVar_ sentFrameCount $ \sent -> do+          unless sent $+            sendWebMessage conn $ WebFrameCount frameCount+          return True+        replicateM_ frameCount $ do+          frameIdx <- expectFrame =<< getFrame+          withMVar lock $ \_ ->+            sendWebMessage conn $ WebFrame frameIdx (frameFileName frameIdx)+        logMsg "Optimized render done."+        killThread ghciThread   where-    execOpts = ["raw", "+RTS", "-N", "-M2G", "-RTS"]-    expectFrame :: QSemN -> Either String Text -> IO (Integer, Text)-    expectFrame sem (Left "") = do-      waitQSemN sem 25 -- =<< getNumCapabilities-      sendTextData conn (T.pack "status\nDone")+    execOpts output =+      [ "raw", "--output", output, "--offset", "1"+      , "+RTS", "-N", "-M2G", "-RTS"]+    expectFrame :: Either String Text -> IO Int+    expectFrame (Left "") = do+      sendWebMessage conn $ WebStatus "Done"       exitSuccess-    expectFrame _ (Left err) = do-      sendTextData conn $ T.pack $ "error\n" ++ err+    expectFrame (Left err) = do+      sendWebMessage conn $ WebError err       exitWith (ExitFailure 1)-    expectFrame _ (Right frame) =+    expectFrame (Right frame) =       case T.decimal frame of         Left err -> do           hPutStrLn stderr (T.unpack frame)           hPutStrLn stderr $ "expectFrame: " ++ err-          sendTextData conn $ T.pack $ "error\n" ++ err+          sendWebMessage conn $ WebError err           exitWith (ExitFailure 1)-        Right (frameNumber, rest) ->-          pure (frameNumber, rest)+        Right (frameNumber, "") ->+          pure frameNumber+        Right {} -> do+          let err = "Unexpected output"+          hPutStrLn stderr (T.unpack frame)+          hPutStrLn stderr $ "expectFrame: " ++ err+          sendWebMessage conn $ WebError err+          exitWith (ExitFailure 1)  watchFile :: WatchManager -> FilePath -> IO () -> IO StopListening watchFile watch file action = watchTree watch (takeDirectory file) check (const action)@@ -205,3 +234,65 @@  isHaskellFile :: FilePath -> Bool isHaskellFile path = takeExtension path `elem` [".hs", ".lhs"]++logMsg :: String -> IO ()+logMsg msg = do+    now <- getCurrentTime+    putStrLn $ formatTime defaultTimeLocale fmt now ++ ": " ++ msg+  where+    fmt = "%F %T%2Q"++-------------------------------------------------------------------------------+-- Ghci interface++-- stack+-- cabal+-- raw+-- none?+data GhciBackend = GhciBackend (MVar Ghci)++ghciBackend :: Maybe FilePath -> FilePath -> IO GhciBackend+ghciBackend mbGHCPath self = do+  let ghciProc =+        case mbGHCPath of+          Just ghcPath ->+            proc ghcPath $ ["--interactive", "+RTS"] ++ words memoryLimit ++ ["-RTS"]+          Nothing ->+            proc "stack" ["exec", "ghci", "--rts-options="++memoryLimit]+  (ghci, _loads) <- startGhciProcess ghciProc $ \_stream _msg -> return ()+  void $ exec ghci $ ":load " ++ self+  ref <- newMVar ghci+  return $ GhciBackend ref++ghciReload :: GhciBackend -> IO ()+ghciReload (GhciBackend ref) =+  withMVar ref $ \ghci ->+    void $ reload ghci++ghciGenerate :: GhciBackend -> FilePath -> (Int -> IO ()) -> IO ()+ghciGenerate (GhciBackend ref) target cb = withMVar ref $ \ghci -> do+  execStream ghci (":main raw --output=" ++ target ++ " --offset=1")+    $ \_ msg ->+      case reads msg of+        [(frameIdx,"")] -> cb frameIdx+        _               -> return ()++memoryLimit :: String+memoryLimit = "-M1G"++-------------------------------------------------------------------------------+-- Websocket API++data WebMessage+  = WebStatus String+  | WebError String+  | WebFrameCount Int+  | WebFrame Int FilePath++sendWebMessage :: Connection -> WebMessage -> IO ()+sendWebMessage conn msg = sendTextData conn $+  case msg of+    WebStatus txt   -> T.pack "status\n" <> T.pack txt+    WebError txt    -> T.pack "error\n" <> T.pack txt+    WebFrameCount n -> T.pack $ "frame_count\n" ++ show n+    WebFrame n path -> T.pack $ "frame\n" ++ show n ++ "\n" ++ path

@@ -1,3 +1,7 @@+{-|+  Easing functions modify the rate of change in animations.+  More examples can be seen here: <https://easings.net/>.+-} module Reanimate.Ease   ( Signal   , constantS@@ -7,7 +11,6 @@   , powerS   , bellS   , oscillateS-  , fromListS   , cubicBezierS   ) where @@ -15,15 +18,6 @@ --   composition. type Signal = Double -> Double -fromListS :: [(Double, Signal)] -> Signal-fromListS fns t = worker 0 fns-  where-    worker _ [] = 0-    worker now [(len, fn)] = fn (min 1 ((t-now) / min (1-now) len))-    worker now ((len, fn):rest)-      | now+len < t = worker (now+len) rest-      | otherwise = fn ((t-now) / len)- -- | Constant signal. -- --   Example:@@ -67,6 +61,13 @@     then 0.5 * (2*s)**steepness     else 1-0.5 * (2 - 2*s)**steepness +-- | Power curve signal. Takes a steepness parameter. 2 is a good default.+--+--   Example:+--+--   > signalA (powerS 2) drawProgress+--+--   <<docs/gifs/doc_powerS.gif>> powerS :: Double -> Signal powerS steepness s = s**steepness @@ -94,7 +95,7 @@ bellS steepness = curveS steepness . oscillateS  -- | Cubic Bezier signal. Gives you a fair amount of control over how the---   signal will 'curve'.+--   signal will curve. -- --   Example: --

@@ -79,7 +79,8 @@  -- | Modify the animation by applying the effect. If desired, you can apply multiple effects to single animation by calling this function multiple times. applyE :: Effect -> Animation -> Animation-applyE fn (Animation d genFrame) = Animation d $ \t -> fn d (d*t) $ genFrame t+applyE fn ani = let d = duration ani+                in mkAnimation d $ \t -> fn d (d*t) $ frameAt (d*t) ani  -- | Build an effect from an image-modifying function. This effect does not change as time passes. constE :: (Tree -> Tree) -> Effect

@@ -1,6 +1,19 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE MagicHash    #-} {-# LANGUAGE MultiWayIf   #-}+{-|+Module      : Reanimate.GeoProjection+Copyright   : Written by David Himmelstrup+License     : Unlicense+Maintainer  : lemmih@gmail.com+Stability   : experimental+Portability : POSIX++This module provides functions for mapping the surface of+a sphere on to a 2D plane. It also has convenience functions+for loading GeoJSON data.++-} module Reanimate.GeoProjection   ( Projection(..)   , XYCoord(..)@@ -108,143 +121,8 @@     !xPx = round $ ((lam+pi)/tau) * wMax     !yPx = round $ (1-((phi+halfPi)/pi)) * hMax -{- HLINT ignore -}--- findValidCoord :: Int -> Int -> Double -> Double -> (XYCoord -> LonLat) -> XYCoord -> XYCoord--- findValidCoord !w !h !wMax !hMax !p_inv (XYCoord x y) = foldr const (XYCoord x y)---     [ XYCoord x' y'---     | let !xi = round $ x * wMax---           !yi = round $ y * hMax---     , !ax <- [xi, xi-1, xi+1]---     , ax >= 0---     , ax < w---     , let !x' = fromIntegral ax / wMax---     , !ay <- [yi, yi-1, yi+1]---     , ay >= 0---     , ay < h---     , let !y' = fromIntegral ay / hMax---     , validLonLat $! p_inv $! XYCoord x' y'---     ]---- isInWorld :: Projection -> XYCoord -> Bool--- isInWorld p coord =---     odd $ length $ isInWorld' p coord------ isInWorld' :: Projection -> XYCoord -> [(Double, Double)]--- isInWorld' p (XYCoord x y) =---     [ (x1, y1)---     | (XYCoord x1 y1, XYCoord x2 y2) <- world---     , (y1 > y) /= (y2 > y) -- y is between y1 and y2---     , x < (x2 - x1) * (y - y1) / (y2 - y1) + x1 -- x is to the left of the line---     ]---   where---     world = worldPolygon p------ worldPolygon :: Projection -> [(XYCoord, XYCoord)]--- worldPolygon p =---     interp (-pi, -halfPi) (-pi, halfPi) ++---     interp (-pi, halfPi) (pi, halfPi) ++---     interp (pi, halfPi) (pi, -halfPi) ++---     interp (pi, -halfPi) (-pi, -halfPi)---   where---     apply (lam, phi) = projectionForward p $ LonLat lam phi---     steps = 100---     interp (x1, y1) (x2,y2) =---       [ ( apply (fromToS x1 x2 (n/steps), fromToS y1 y2 (n/steps))---         , apply (fromToS x1 x2 ((n+1)/steps), fromToS y1 y2 ((n+1)/steps)))---       | n <- [0..steps-1]]---- findNearestPixel :: MutableImage s PixelRGBA8 -> Int -> Int -> Int -> Int -> ST s PixelRGBA8--- findNearestPixel src w h srcX srcY = worker $ take 20---     [ (x, y)---     | n <- [1..]---     , x <- [srcX-n .. srcY+n]---     , y <- if x == srcX-n || x == srcX+n then [srcY-n,srcY+n] else [srcY-n .. srcY+n]---     , x >= 0---     , y >= 0---     , x < w---     , y < h---     ]---   where---     worker [] = pure $ PixelRGBA8 0xFF 0x00 0x00 0xFF---     worker ((x,y):rest) = do---       this <- readPixel src x y---       if this == blank---         then worker rest---         else return this---     blank = PixelRGBA8 0x00 0x00 0x00 0x00----- Original version:        134,925 pixels/second--- Inlined projections:     136,332 pixels/second--- TEST: no write pixels:   134,288 pixels/second !!!--- Fast theta:            1,489,719 pixels/second--- Cached theta:          3,622,254 pixels/second---- to equirectangularP:   9,015,326 pixels/second---                        9,680,217---                        9,466,744---                       14,830,330--- to lambertP:           6,735,973--- to mercatorP:          4,248,927--- to mollweideP:         3,593,545--- to hammerP:            3,237,699--- to bottomleyP:         3,864,848--- to sinusoidalP:        7,020,756--- to wernerP:            4,433,295--- to bonneP:             4,071,187--- to augustP:            2,553,177--- to collignonP:         5,486,849--- to eckert1P:           7,428,849--- to eckert3P:           6,666,936--- to eckert5P:           6,106,492--- to faheyP:             5,137,291--- to foucautP:           3,983,151--- to lagrangeP:          3,850,611--- interpFastP :: Image PixelRGBA8 -> Projection -> Projection -> Double -> Image PixelRGBA8--- interpFastP !src (Projection _ p1 p1_inv) (Projection _ p2 p2_inv) !t = runST $ do---     unsafeIOToST $ putStrLn "Allocating new array"---     !img <- newMutableImage w h---     unsafeIOToST $ putStrLn "done"---     start <- unsafeIOToST $ getCurrentTime---     let factor = 2---         total = w*factor * h*factor---     let l1 =---           loopTo (w*factor) $ \x -> do---             loopTo (h*factor) $ \y -> do---               let thisIndex = (x*h*factor+y)---               when (thisIndex `mod` 1000000 == 0) $ unsafeIOToST $ do---                 now <- getCurrentTime---                 let diff = realToFrac (diffUTCTime now start):: Double---                 printf "%.2f pixels/second\n" (fromIntegral (total-thisIndex) / diff)---               let !x1' = fromIntegral x / (wMax*fromIntegral factor)---                   !y1' = fromIntegral y / (hMax*fromIntegral factor)---                   !lonlat = p1_inv $! XYCoord x1' y1'---                   -- p = srcPixel src lonlat---               -- unsafeIOToST (evaluate lonlat)------               when (validLonLat lonlat) $ do---                 p <- srcPixelFast src wMax hMax lonlat---                 when (pixelOpacity p /= 0) $ do---                   let XYCoord !x1 !y1 = p1 lonlat---                       -- !coord = p2 lonlat---                       XYCoord !x2 !y2 = p2 lonlat -- findValidCoord w h wMax hMax p2_inv $ p2 lonlat---                       !x3 = round $ fromToS x1 x2 t * wMax---                       !y3 = round $ (1 - fromToS y1 y2 t) * hMax :: Int---                   -- unsafeIOToST (evaluate coord)---                   -- return ()---                   when (x3 >= 0 && x3 < w && y3 >= 0 && y3 < h) $---                     writePixel img x3 y3 p---     l1---     unsafeFreezeImage img---   where---     loopTo m fn = go m---       where go 0 = return ()---             go n = fn (n-1) >> go (n-1)---     !w = imageWidth src---     !h = imageHeight src---     !wMax = fromIntegral (w-1)---     !hMax = fromIntegral (h-1)-+-- | Interpolate between two projections and apply the result to an image in+--   equirectangular format. The source image must have an aspect ratio of 2:1. interpP :: Image PixelRGBA8 -> Projection -> Projection -> Double -> Image PixelRGBA8 interpP src p1 _ 0 = project src p1 interpP src _ p2 1 = project src p2@@ -252,49 +130,32 @@     !img <- newMutableImage w h      let factor = 2-        -- total = w*factor * h*factor     let l1 = do-          -- start <- unsafeIOToST $ getCurrentTime           loopTo (w*factor) $ \x -> do             loopTo (h*factor) $ \y -> do-              -- let thisIndex = (x*h*factor+y)-              -- when (thisIndex `mod` 1000000 == 0) $ unsafeIOToST $ do-              --   now <- getCurrentTime-              --   let diff = realToFrac (diffUTCTime now start):: Double-              --   printf "%.2f pixels/second: %s\n" (fromIntegral (total-thisIndex) / diff) label1               let !x1' = fromIntegral x / (wMax*fromIntegral factor)                   !y1' = fromIntegral y / (hMax*fromIntegral factor)                   !lonlat = p1_inv $! XYCoord x1' y1'-                  -- p = srcPixel src lonlat                when (validLonLat lonlat) $ do                 p <- srcPixelFast src wMax hMax lonlat                 when (pixelOpacity p /= 0) $ do                   let XYCoord x1 y1 = p1 lonlat-                      -- XYCoord x2 y2 = findValidCoord w h wMax hMax p2_inv $ p2 lonlat                       XYCoord x2 y2 = p2 lonlat                       !x3 = round $ fromToS x1 x2 t * wMax                       !y3 = round $ (1 - fromToS y1 y2 t) * hMax                   when (x3 >= 0 && x3 < w && y3 >= 0 && y3 < h) $                     writePixel img x3 y3 p         l2 = do-          -- start <- unsafeIOToST $ getCurrentTime           loopTo (w*factor) $ \x ->             loopTo (h*factor) $ \y -> do-              -- let thisIndex = (x*h*factor+y)-              -- when (thisIndex `mod` 1000000 == 0) $ unsafeIOToST $ do-              --   now <- getCurrentTime-              --   let diff = realToFrac (diffUTCTime now start):: Double-              --   printf "%.2f pixels/second: %s\n" (fromIntegral (total-thisIndex) / diff) label2               let !x2' = fromIntegral x / (wMax*fromIntegral factor)                   !y2' = fromIntegral y / (hMax*fromIntegral factor)                   !lonlat = p2_inv (XYCoord x2' y2')-                  -- p = srcPixel src lonlat               when (validLonLat lonlat) $ do                 p <- srcPixelFast src wMax hMax lonlat                 when (pixelOpacity p /= 0) $ do                   let XYCoord x2 y2 = p2 lonlat-                      -- XYCoord x1 y1 = findValidCoord w h wMax hMax p1_inv $ p1 lonlat                       XYCoord x1 y1 = p1 lonlat                       !x3 = round $ fromToS x1 x2 t * wMax                       !y3 = round $ (1 - fromToS y1 y2 t) * hMax@@ -313,6 +174,11 @@     !wMax = fromIntegral (w-1)     !hMax = fromIntegral (h-1) +-- | Interpolate between two projections and apply the result to an image in+--   equirectangular format. The source image must have an aspect ratio of 2:1.+--   Only the areas inside of the two bounding boxes (applying to the source and+--   target projection, respectively) are mapped. Pixels outside of these bounding-boxes+--   are undefined. interpBBP :: Image PixelRGBA8 -> Projection -> Projection ->             (Double,Double,Double,Double) -> (Double,Double,Double,Double) -> Double -> Image PixelRGBA8 interpBBP !src (Projection _ p1 p1_inv) !(Projection _ p2 p2_inv) (fx,fy,fw,fh) (tx, ty, tw, th) !t = runST $ do@@ -325,18 +191,12 @@                   !y1' = fromIntegral y / (hMax*fromIntegral factor)               when (x1' >= fx && x1' <= fx+fw && y1' >= fy && y1' <= fy+fh) $ do                 let !lonlat = p1_inv $! XYCoord x1' y1'-                      -- p = srcPixel src lonlat                  when (validLonLat lonlat) $ do-                    -- let LonLat lam phi = lonlat-                    --     !xPx = ((lam+pi)/tau)-                    --     !yPx = (((phi+halfPi)/pi))-                    -- when (xPx >= fx && xPx <= fx+fw && yPx >= fy && yPx <= fy+fh) $ do                     p <- srcPixelFast src wMax hMax lonlat                     when (pixelOpacity p /= 0) $ do                       let XYCoord x1 y1 = p1 lonlat                           XYCoord x2 y2 = p2 lonlat-                          -- XYCoord x2 y2 = findValidCoord w h wMax hMax p2_inv $ p2 lonlat                           !x3 = round $ fromToS x1 x2 t * wMax                           !y3 = round $ (1 - fromToS y1 y2 t) * hMax                       when (x3 >= 0 && x3 < w && y3 >= 0 && y3 < h) $@@ -348,12 +208,10 @@                   !y2' = fromIntegral y / (hMax*fromIntegral factor)               when (x2' >= tx && x2' <= tx+tw && y2' >= ty && y2' <= ty+th) $ do                 let !lonlat = p2_inv (XYCoord x2' y2')-                    -- p = srcPixel src lonlat                 when (validLonLat lonlat) $ do                   p <- srcPixelFast src wMax hMax lonlat                   when (pixelOpacity p /= 0) $ do                     let XYCoord x2 y2 = p2 lonlat-                        -- XYCoord x1 y1 = findValidCoord w h wMax hMax p1_inv $ p1 lonlat                         XYCoord x1 y1 = p1 lonlat                         !x3 = round $ fromToS x1 x2 t * wMax                         !y3 = round $ (1 - fromToS y1 y2 t) * hMax@@ -363,15 +221,6 @@       then l1 >> l2       else l2 >> l1 -    -- when False $-    --   forM_ [0..w-1] $ \x ->-    --     forM_ [0..h-1] $ \y -> do-    --       let x1 = fromIntegral x / (wMax)-    --           y1 = 1 - fromIntegral y / (hMax)-    --       this <- readPixel img x y-    --       when (isBlank this) $-    --         when (isInWorld (mergeP p1 p2 t) (XYCoord x1 y1)) $-    --           writePixel img x y =<< findNearestPixel img w h x y     unsafeFreezeImage img   where     loopTo m fn = go m@@ -394,21 +243,32 @@ eqDouble :: Double -> Double -> Bool eqDouble a b = abs (a-b) < epsilon +-- | XY coordinates on a 2D plane. Valid ranges go from 0 to 1, inclusive. data XYCoord = XYCoord !Double !Double -- 0 to 1   deriving (Read,Show,Eq,Ord)++-- | Longitude and latitude. Valid range for longitude is -pi to +pi.+--   Valid range for latitude is -pi/2 to +pi/2. data LonLat = LonLat !Double !Double -- -pi to +pi, -halfPi to +halfPi   deriving (Read,Show,Eq,Ord) instance Hashable LonLat where   hashWithSalt s (LonLat a b) = hashWithSalt s (a,b)++-- | Projections are named bi-directional mappings between a sphere+--   and a 2D plane. data Projection = Projection-  { projectionLabel   :: String+  { projectionLabel   :: String -- ^ Name of the projection.   , projectionForward :: !(LonLat -> XYCoord)-    ---    -- (Double# -> Double# -> (# Double#, Double# #))+    -- ^ Mapping from longitude and latitude on a sphere to+    --   XY coordinates on a 2D plane.   , projectionInverse :: !(XYCoord -> LonLat)+    -- ^ Mapping from XY coordinates on a 2D plane to longitude+    --   and latitude on a sphere.   }  -- FIXME: Verify that 'src' has an aspect ratio of 2:1.+-- | Apply on an image in equirectangular format. The source image+--   therfore must have an aspect ratio of 2:1. project :: Image PixelRGBA8 -> Projection -> Image PixelRGBA8 project src (Projection _label _ pInv) = generateImage fn w h   where@@ -430,6 +290,7 @@ _validXYCoord :: XYCoord -> Bool _validXYCoord (XYCoord x y) = x >= 0 && x <= 1 && y >= 0 && y <= 1 +-- | Returns @True@ iff a projection is consistent and complete. isValidP :: Projection -> Bool isValidP (Projection _label p pInv) = and     [ check x y@@ -446,6 +307,7 @@       in not (validLonLat lonlat) || eqLonLat lonlat lonlat2           || trace (show (lonlat, lonlat2)) False +-- | Translate the lower-most point of a projection by an offset. moveBottomP :: Double -> Projection -> Projection moveBottomP offset (Projection label p pInv) = Projection label p' pInv'   where@@ -454,9 +316,11 @@         XYCoord x y -> XYCoord x (fromToS offset 1 y)     pInv' (XYCoord x y) = pInv (XYCoord x ((y-offset)/(1-offset))) +-- | Translate the top-most point of a projection by an offset. moveTopP :: Double -> Projection -> Projection moveTopP offset = flipYAxisP . moveBottomP offset . flipYAxisP +-- | Invert the Y axis of projection. flipYAxisP :: Projection -> Projection flipYAxisP (Projection label p pInv) = Projection label p' pInv'   where@@ -467,6 +331,7 @@       let LonLat lam phi = pInv (XYCoord x (1-y))       in LonLat lam (negate phi) +-- | Scale X and Y axis of projection. scaleP :: Double -> Double -> Projection -> Projection scaleP xScale yScale (Projection label p pInv) = Projection label forward inverse   where@@ -476,7 +341,8 @@     inverse (XYCoord x y) =       pInv $ XYCoord ((x-0.5)/xScale+0.5) ((y-0.5)/yScale+0.5) -+-- | Attempt to smoothly interpolate two projections. The result may not be continuous+--   and 'interpP' may give prettier results. mergeP :: Projection -> Projection -> Double -> Projection mergeP p1 p2 t = Projection (projectionLabel p1 ++ "/" ++ projectionLabel p2) p pInv   where@@ -587,6 +453,7 @@         lam = 2 * atan2 (z*x) (2*(2*z**2-1))         phi = asin (z*y) +-- | <<docs/gifs/doc_cylindricalEqualAreaP.gif>> cylindricalEqualAreaP :: Double -> Projection cylindricalEqualAreaP phi0 = Projection "lambert" forward inverse   where@@ -723,6 +590,7 @@           | v < lower = v+upper-lower           | otherwise = v +-- | <<docs/gifs/doc_cassiniP.gif>> cassiniP :: Projection cassiniP = Projection "cassini" forward inverse   where@@ -735,7 +603,7 @@         lam = atan2 (tan x) (cos y)         phi = asin (sin y * cos x) -+-- | <<docs/gifs/doc_augustP.gif>> augustP :: Projection augustP = scaleP 0.70 0.70 $ Projection "august"  forward inverse   where@@ -875,6 +743,7 @@         phi = 2 * atan2 y (1 + faheyK)  {-# INLINE foucautP #-}+-- | <<docs/gifs/doc_foucautP.gif>> foucautP :: Projection foucautP = Projection "foucaut" forward inverse   where@@ -898,6 +767,7 @@         lam = x * sqrtPi / 2 / (cos phi * cosk * cosk)  {-# INLINE lagrangeP #-}+-- | <<docs/gifs/doc_lagrangeP.gif>> lagrangeP :: Projection lagrangeP = Projection "lagrange" forward inverse   where@@ -944,7 +814,7 @@   -+-- | Map for all features and render the geometry. drawFeatureCollection :: GeoFeatureCollection a -> (a -> SVG -> SVG) -> SVG drawFeatureCollection geo fn = mkGroup   [ fn (feature ^. properties) $ renderGeometry (feature ^. geometry)@@ -952,6 +822,7 @@   ]  {-# INLINE loadFeatureCollection #-}+-- | Load GeoJSON from a filepath and render the geometry. loadFeatureCollection :: FromJSON a => FilePath -> (a -> SVG -> SVG) -> SVG loadFeatureCollection path = unsafePerformIO $ do   mbGeo <- decodeFileStrict path@@ -965,6 +836,7 @@ -- pointsToRadians :: SVG -> SVG -- applyProjection :: Projection -> SVG -> SVG +-- | Render GeoJSON geometry as SVG. renderGeometry :: GeospatialGeometry -> SVG renderGeometry shape =   case shape of@@ -988,9 +860,15 @@     _ -> None  +-- | Apply a projection to an SVG image. This is a lossy transformation+--   but the default tolerance is low enough that inaccuracies should not+--   be visible. applyProjection :: Projection -> SVG -> SVG applyProjection = applyProjection' 1e-2 +-- | Apply a projection to an SVG image with a specified tolerance.+--   Projections may turn straight lines into disjointed curves and+--   the tolerance argument determined the accuracy of this transformation. applyProjection' :: Double -> Projection -> SVG -> SVG applyProjection' tolerance p = mapSvgLines start   where

@@ -1,5 +1,12 @@ {-# LANGUAGE OverloadedStrings   #-} {-# LANGUAGE ScopedTypeVariables #-}+{-|+Copyright   : Written by David Himmelstrup+License     : Unlicense+Maintainer  : lemmih@gmail.com+Stability   : experimental+Portability : POSIX+-} module Reanimate.LaTeX   ( latex   , latexWithHeaders@@ -40,6 +47,7 @@ latex :: T.Text -> Tree latex = latexWithHeaders [] +-- | Invoke latex with extra script headers. latexWithHeaders :: [T.Text] -> T.Text -> Tree latexWithHeaders = someTexWithHeaders "latex" "dvi" [] @@ -51,6 +59,7 @@  where   script = mkTexScript exec args headers tex +-- | Invoke latex and separate results. latexChunks :: [T.Text] -> [Tree] latexChunks chunks | pNoExternals = map mkText chunks latexChunks chunks                = worker (svgGlyphs $ latex $ T.concat chunks) chunks@@ -67,6 +76,7 @@ xelatex :: Text -> Tree xelatex = xelatexWithHeaders [] +-- | Invoke xelatex with extra script headers. xelatexWithHeaders :: [T.Text] -> T.Text -> Tree xelatexWithHeaders = someTexWithHeaders "xelatex" "xdv" ["-no-pdf"] @@ -82,6 +92,7 @@ ctex :: T.Text -> Tree ctex = ctexWithHeaders [] +-- | Invoke xelatex with extra script headers + ctex headers. ctexWithHeaders :: [T.Text] -> T.Text -> Tree ctexWithHeaders headers = xelatexWithHeaders ("\\usepackage[UTF8]{ctex}" : headers) 

@@ -1,6 +1,16 @@ {-# LANGUAGE MultiWayIf        #-} {-# LANGUAGE OverloadedStrings #-}-module Reanimate.Math.Balloon where+{-|+Copyright   : Written by David Himmelstrup+License     : Unlicense+Maintainer  : lemmih@gmail.com+Stability   : experimental+Portability : POSIX+-}+module Reanimate.Math.Balloon+  ( balloon+  , balloon'+  ) where  import           Control.Lens import qualified Data.Vector                as V@@ -15,9 +25,20 @@  -- import           Debug.Trace +-- | Inflate SVG shapes like a balloon. This works by hiding corners+--   that are more than @t@ percent distant from the starting point+--   relative to the maximum diameter of the shape.+--+--   Example:+--+--   > animate $ balloon (scale 8 $ center $ latex "X")+--+--   <<docs/gifs/doc_balloon.gif>> balloon :: SVG -> (Double -> SVG) balloon = balloon' 0.01 +-- | Same as @balloon'@ but with a given tolerance for converting+--   SVG shapes to polygons. balloon' :: Double -> SVG -> (Double -> SVG) balloon' tol svg = \t ->     mkGroup

@@ -1,3 +1,16 @@+{-# LANGUAGE FlexibleInstances #-}+{-# OPTIONS_GHC -Wno-orphans #-}+{-|+Module      : Reanimate.Math.Common+Copyright   : Written by David Himmelstrup+License     : Unlicense+Maintainer  : lemmih@gmail.com+Stability   : experimental+Portability : POSIX++Low-level primitives related to computational geometry.++-} module Reanimate.Math.Common   ( -- * Ring     Ring(..)@@ -11,14 +24,13 @@     -- * Math   , area                -- :: Fractional a => V2 a -> V2 a -> V2 a -> a   , area2X              -- :: Fractional a => V2 a -> V2 a -> V2 a -> a-  , epsilon             -- :: Fractional a => a-  , epsEq               -- :: (Ord a, Fractional a) => a -> a -> Bool-  , isLeftTurn          -- :: (Fractional a, Ord a) => V2 a -> V2 a -> V2 a -> Bool-  , isLeftTurnOrLinear  -- :: (Fractional a, Ord a) => V2 a -> V2 a -> V2 a -> Bool-  , isRightTurn         -- :: (Fractional a, Ord a) => V2 a -> V2 a -> V2 a -> Bool-  , isRightTurnOrLinear -- :: (Fractional a, Ord a) => V2 a -> V2 a -> V2 a -> Bool-  , direction           -- :: Fractional a => V2 a -> V2 a -> V2 a -> a+  , isLeftTurn          -- :: (Num a, Ord a) => V2 a -> V2 a -> V2 a -> Bool+  , isLeftTurnOrLinear  -- :: (Num a, Ord a) => V2 a -> V2 a -> V2 a -> Bool+  , isRightTurn         -- :: (Num a, Ord a) => V2 a -> V2 a -> V2 a -> Bool+  , isRightTurnOrLinear -- :: (Num a, Ord a) => V2 a -> V2 a -> V2 a -> Bool+  , direction           -- :: Num a => V2 a -> V2 a -> V2 a -> a   , isInside            -- :: (Fractional a, Ord a) => V2 a -> V2 a -> V2 a -> V2 a -> Bool+  , isInsideStrict      -- :: (Fractional a, Ord a) => V2 a -> V2 a -> V2 a -> V2 a -> Bool   , barycentricCoords   -- :: Fractional a => V2 a -> V2 a -> V2 a -> V2 a -> (a, a, a)   , rayIntersect        -- :: (Fractional a, Ord a) => (V2 a,V2 a) -> (V2 a,V2 a) -> Maybe (V2 a)   , isBetween           -- :: (Ord a, Fractional a) => V2 a -> (V2 a, V2 a) -> Bool@@ -27,6 +39,7 @@   , approxDist          -- :: (Real a, Fractional a) => V2 a -> V2 a -> a   , distance'           -- :: (Real a, Fractional a) => V2 a -> V2 a -> Double   , triangleAngles      -- :: V2 Double -> V2 Double -> V2 Double -> (Double, Double, Double)+  , Epsilon(..)   ) where  import           Data.Vector    (Vector)@@ -36,84 +49,111 @@ import           Linear.V2 import           Linear.V3 import           Linear.Vector+import           Linear.Epsilon +instance Epsilon Rational where+  nearZero r = r==0++-- | Circular collection of pairs. newtype Ring a = Ring (Vector (V2 a)) +-- | Number of elements in the ring. ringSize :: Ring a -> Int ringSize (Ring v) = length v +-- | Safe method for accessing elements in the ring. ringAccess :: Ring a -> Int -> V2 a ringAccess (Ring v) i = v V.! mod i (length v) +-- | Clamp index to within the usable range for the ring. ringClamp :: Ring a -> Int -> Int ringClamp (Ring v) i = mod i (length v) +-- | Convert ring to a vector. ringUnpack :: Ring a -> Vector (V2 a) ringUnpack (Ring v) = v +-- | Convert vector to a ring. ringPack :: Vector (V2 a) -> Ring a ringPack = Ring +-- | Map each element of a ring. ringMap :: (V2 a -> V2 b) -> Ring a -> Ring b ringMap fn (Ring v) = Ring (V.map fn v) +-- | Compute the intersection of two pairs of nodes in the ring. ringRayIntersect :: Ring Rational -> (Int, Int) -> (Int,Int) -> Maybe (V2 Rational) ringRayIntersect p (a,b) (c,d) =   rayIntersect (ringAccess p a, ringAccess p b) (ringAccess p c, ringAccess p d) -+-- | Compute area of triangle. area :: Fractional a => V2 a -> V2 a -> V2 a -> a area a b c = 1/2 * area2X a b c +-- | Compute 2x area of triangle. This avoids a division. area2X :: Fractional a => V2 a -> V2 a -> V2 a -> a area2X (V2 a1 a2) (V2 b1 b2) (V2 c1 c2) =   det33 (V3 (V3 a1 a2 1)             (V3 b1 b2 1)             (V3 c1 c2 1)) -epsilon :: Fractional a => a-epsilon = 1e-13--epsEq :: (Ord a, Fractional a) => a -> a -> Bool-epsEq a b = abs (a-b) < epsilon+compareEpsZero :: (Ord a, Fractional a, Epsilon a) => a -> Ordering+compareEpsZero val+  | nearZero val  = EQ+  | otherwise     = compare val 0  {-# INLINE isLeftTurn #-}--- Left turn.-isLeftTurn :: (Fractional a, Ord a) => V2 a -> V2 a -> V2 a -> Bool+-- | Return @True@ iff the line from @p1@ to @p2@ makes a left-turn to @p3@.+isLeftTurn :: (Fractional a, Ord a, Epsilon a) => V2 a -> V2 a -> V2 a -> Bool isLeftTurn p1 p2 p3 =-  case compare (direction p1 p2 p3) 0 of+  case compareEpsZero (direction p1 p2 p3) of     LT -> True-    EQ -> False -- colnear+    EQ -> False -- colinear     GT -> False  {-# INLINE isLeftTurnOrLinear #-}-isLeftTurnOrLinear :: (Fractional a, Ord a) => V2 a -> V2 a -> V2 a -> Bool+-- | Return @True@ iff the line from @p1@ to @p2@ does not make a right-turn to @p3@.+isLeftTurnOrLinear :: (Fractional a, Ord a, Epsilon a) => V2 a -> V2 a -> V2 a -> Bool isLeftTurnOrLinear p1 p2 p3 =-  case compare (direction p1 p2 p3) 0 of+  case compareEpsZero (direction p1 p2 p3) of     LT -> True-    EQ -> True -- colnear+    EQ -> True -- colinear     GT -> False  {-# INLINE isRightTurn #-}-isRightTurn :: (Fractional a, Ord a) => V2 a -> V2 a -> V2 a -> Bool+-- | Return @True@ iff the line from @p1@ to @p2@ makes a right-turn to @p3@.+isRightTurn :: (Fractional a, Ord a, Epsilon 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+-- | Return @True@ iff the line from @p1@ to @p2@ does not make a left-turn to @p3@.+isRightTurnOrLinear :: (Fractional a, Ord a, Epsilon 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+-- | Compute the change in direction in a line between the three points.+direction :: Num a => V2 a -> V2 a -> V2 a -> a direction p1 p2 p3 = crossZ (p3-p1) (p2-p1)  {-# INLINE isInside #-}+-- | Returns @True@ if the fourth argument is inside the triangle or+--   on the border. 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+    s >= 0 && s <= 1 && t >= 0 && t <= 1 && i >= 0 && i <= 1   where-    (s, t, _) = barycentricCoords a b c d+    (s, t, i) = barycentricCoords a b c d +{-# INLINE isInsideStrict #-}+-- | Returns @True@ iff the fourth argument is inside the triangle.+isInsideStrict :: (Fractional a, Ord a) => V2 a -> V2 a -> V2 a -> V2 a -> Bool+isInsideStrict a b c d =+    s > 0 && s < 1 && t > 0 && t < 1 && i > 0 && i < 1+  where+    (s, t, i) = barycentricCoords a b c d+ {-# INLINE barycentricCoords #-}+-- | Compute relative coordinates inside the triangle. Invariant: @a+b+c=1@ 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)@@ -126,6 +166,7 @@   {-# INLINE rayIntersect #-}+-- | Compute intersection of two infinite lines. rayIntersect :: (Fractional a, Ord a) => (V2 a,V2 a) -> (V2 a,V2 a) -> Maybe (V2 a) rayIntersect (V2 x1 y1,V2 x2 y2) (V2 x3 y3, V2 x4 y4)   | yBot == 0 = Nothing@@ -138,12 +179,14 @@     yBot = (x1-x2)*(y3-y4) - (y1-y2)*(x3-x4)  {-# INLINE isBetween #-}+-- | Returns @True@ iff a point is on a line segment. isBetween :: (Ord a, Fractional a) => V2 a -> (V2 a, V2 a) -> Bool isBetween (V2 x y) (V2 x1 y1, V2 x2 y2) =   ((y1 > y) /= (y2 > y) || y == y1 || y == y2) && -- y is between y1 and y2   ((x1 > x) /= (x2 > x) || x == x1 || x == x2)  {-# INLINE lineIntersect #-}+-- | Compute intersection of two line segments. lineIntersect :: (Ord a, Fractional a) => (V2 a, V2 a) -> (V2 a, V2 a) -> Maybe (V2 a) lineIntersect a b =   case rayIntersect a b of@@ -153,16 +196,20 @@  -- circleIntersect :: (Ord a, Fractional a) => (V2 a, V2 a) -> (V2 a, V2 a) -> [V2 a] -distSquared :: (Fractional a) => V2 a -> V2 a -> a+-- | Compute the square of the distance between two points.+distSquared :: (Num a) => V2 a -> V2 a -> a distSquared a b = quadrance (a ^-^ b) +-- | Approximate the distance between two points. approxDist :: (Real a, Fractional a) => V2 a -> V2 a -> a approxDist a b = realToFrac (sqrt (realToFrac (distSquared a b) :: Double)) +-- | Approximate the distance between two points. distance' :: (Real a, Fractional a) => V2 a -> V2 a -> Double distance' a b = sqrt (realToFrac (distSquared a b))  -- sum of angles is always pi.+-- | Approximate the angles of a triangle. triangleAngles :: V2 Double -> V2 Double -> V2 Double -> (Double, Double, Double) triangleAngles a b c =     (findAngle (b-a) (c-a)

@@ -1,325 +0,0 @@-{-# LANGUAGE MultiWayIf #-}-module Reanimate.Math.Compatible where--import           Data.List-import           Data.Maybe-import           Data.Ord-import qualified Data.Vector                   as V-import           Linear.V2-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--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_---- 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--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-  = 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-        ]-  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]--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--- 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 _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"--- [(P, Vis)] -> Polygon -> [P]-{--If there is a 1-link path, connect it.-  Recurse into the two new polygon pairs.--If there is a 2-link path, connect it, possibly add bogus steiner point.-  Recurse into the two new polygon pairs.--If there is a n-link path, connect it, add bogus steiner points.-  Recurse into the two new polygon pairs.--}---- a 2 b 1 c--- ab = 2-link of (a,b)--- abc = 2-link of (cut-a-ab-b, c)--- steps: a ab abc c--- a, [(2,b), (1,c)]--- [(ab, p1,p2)]--{--, mkGroup-  [ withStrokeColor "green" $mkGroup-    [ mkLine (x1,y1) (x2,y2)-    , mkLine (x1',y1') (x2',y2') ]-  | (a,b) <- mWins-  , (i,j) <- oWins-  , a == i || a == j || b == i || b == j-  , not (sort [a,b] == sort [i,j])-  , let V2 x1 y1 = realToFrac <$> a-        V2 x2 y2 = realToFrac <$> b-        V2 x1' y1' = realToFrac <$> i-        V2 x2' y2' = realToFrac <$> j-  ]--}----type Points = V.Vector (V2 Rational)-type Edges = [(Int, Int, Int)]-data Mesh = Mesh { meshPoints :: Points, meshEdges :: Edges }-data MeshPair = MeshPair Points Points Edges--- The points in a RelMesh are:---   relMeshStatic ++ x where Ax = B--- data RelMesh = RelMesh---   { relMeshStatic :: Points---   , relMeshEdges  :: Edges---   , relMeshA      :: Matrix Double---   , relMeshB      :: Matrix Double---   }--- data RelMeshPair = RelMeshPair Points Edges (Matrix Double) (Matrix Double) (Matrix Double) (Matrix Double)---------- Use SSSP to find 1-link connections--- Compute visibility windows for each node--- Check windows for ovelap, giving 2-link connections.--- Use floyd to generate all other connections--- (a,b,1)--- (a,b,2)--- floyd-compatiblyTriangulateP :: Polygon -> Polygon -> [(Polygon, Polygon)]-compatiblyTriangulateP a b-  | pSize a /= pSize b = error "polygon size mismatch"-  | 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-  | n == 3 = traceSVG (showStep a b) $ {- trace ("Done") $ -} [(a, b)]-  | otherwise =-    -- 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--- oneBendBetween p a b =---     direction---       (pAccess p b)---       (pAccess p (pParent p a b))---       (pAccess p $ obstructedBy b) == 0 &&---     (pParent p a b) /= obstructedBy b---   where---     obstructedBy n =---       case pParent p a n of---         i -> if i == a then n else obstructedBy i--polygonTwoLinks :: Polygon -> [(Int, Int)]-polygonTwoLinks p =-  [ (i, j)-  | 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-        isStraightLine = oneBendBetween p i j--- Points on a straight line should be 2-link even though they are not--- direct grandparents.-  , isTwoLink || isStraightLine-  ]-  where n = pSize p--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)-  , pParent p i j == i-  ]

@@ -1,891 +0,0 @@-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TemplateHaskell #-}--- Code originally from: https://github.com/wereHamster/haskell-half-edge-mesh-module Reanimate.Math.DCEL where--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.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--type VertexId = Int-type EdgeId = Int-type FaceId = 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 Vertex a = Vertex-    { _vertexId       :: VertexId-    , _vertexPosition :: a-    -- , _vertexEdge     :: EdgeId -- Index to CCW edge pointing to this vertex.-    } deriving (Show)--data Edge = Edge-    { _edgeId     :: EdgeId-    , _edgeVertex :: VertexId-    , _edgeTwin   :: EdgeId-    , _edgeNext   :: EdgeId-    , _edgePrev   :: EdgeId-    , _edgeFace   :: FaceId-    } deriving (Show)--data Face = Face-    { _faceId   :: FaceId-    , _faceEdge :: EdgeId-    } deriving (Show)--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--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-    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--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 "%4d %10s" _vertexId  (show _vertexPosition)-    | Vertex{..} <- M.elems _meshVertices-    ]-  , "Edges:"-  , printf "%4s %3s %4s %4s %4s %4s"-    ("ID"::String) ("Vtx"::String) ("Twin"::String) ("Next"::String)-    ("Prev"::String) ("Face"::String)-  , unlines-    [ printf "%4d %3d %4d %4d %4d %4d" _edgeId _edgeVertex _edgeTwin _edgeNext _edgePrev _edgeFace-    | Edge{..} <- M.elems _meshEdges-    ]-  , "Faces:"-  , unlines-    [ printf "%4d %4d" _faceId _faceEdge-    | Face{..} <- M.elems _meshFaces-    ]-  ]--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 ]--{----}-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-    notSteiner = S.fromList-      [ _edgeVertex edge-      | edge <- M.elems _meshEdges-      , _edgeFace edge == _meshOuterFace ]---- 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"-      ]-

@@ -1,119 +0,0 @@-module Reanimate.Math.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-earClip = last . earClip'--earClip' :: (Fractional a, Ord a) => Ring a -> [Triangulation]-earClip' p = map (edgesToTriangulation $ ringSize p) $ inits $-  let ears = Set.fromList [ i-             | i <- elts-             , isEarCorner p elts (mod (i-1) n) i (mod (i+1) n) ]-  in worker ears (mkQueue elts)-  where-    n = ringSize p-    elts = [0 .. n-1]-    -- worker :: Set.Set Int -> PolyQueue Int -> [(P,P)]-    worker _ears queue | isSimpleQ queue = []-    worker ears queue-      | x `Set.member` ears =-        let dq = dropQ queue-            v0 = prevQ 1 queue-            v1 = prevQ 0 queue-            v3 = peekQ dq-            v4 = peekQ (nextQ dq)-            e1 = if isEarCorner p (toList dq) v0 v1 v3-                  then Set.insert v1 ears-                  else Set.delete v1 ears-            e2 = if isEarCorner p (toList dq) v1 v3 v4-                  then Set.insert v3 e1-                  else Set.delete v3 e1-        in (v1,v3) : worker e2 dq-      | otherwise = worker ears (nextQ queue)-      where-        x = peekQ queue--data PolyQueue a = PolyQueue a [a] [a] [a]---- sizeQ :: PolyQueue a -> Int--- sizeQ (PolyQueue _ a b _) = 1 + length a + length b--mkQueue :: [a] -> PolyQueue a-mkQueue (x:xs) = PolyQueue x xs [] (reverse (x:xs))-mkQueue []     = error "mkQueue: empty"--toList :: PolyQueue a -> [a]-toList (PolyQueue e a b _) = e : a ++ b--isSimpleQ :: PolyQueue a -> Bool-isSimpleQ (PolyQueue _ xs ys _) =-  case xs ++ ys of-    [_,_] -> True-    _     -> False--peekQ :: PolyQueue a -> a-peekQ (PolyQueue e _ _ _) = e--nextQ :: PolyQueue a -> PolyQueue a-nextQ (PolyQueue x [] ys p)     =-  let (y:xs) = reverse (x:ys)-  in PolyQueue y xs [] (x:p)-nextQ (PolyQueue x (y:xs) ys p) = PolyQueue y xs (x:ys) (x:p)--dropQ :: PolyQueue a -> PolyQueue a-dropQ (PolyQueue _ [] ys p)    =-  let (x:xs) = reverse ys-  in PolyQueue x xs [] p-dropQ (PolyQueue _ (x:xs) ys p) = PolyQueue x xs ys p--prevQ :: Int -> PolyQueue a -> a-prevQ nth (PolyQueue _ _ _ p) = p!!nth---- O(n)--- Returns true if ac can be cut from polygon. That is, true if 'b' is an ear.--- isEarCorner polygon a b c = True iff ac can be cut-isEarCorner :: (Fractional a, Ord a) => Ring a -> [Int] -> Int -> Int -> Int -> Bool-isEarCorner p polygon a b c =-    isLeftTurn aP bP cP &&-    -- If it is a right turn then the line ac will be outside the polygon-    and [ not (isInside aP bP cP (ringAccess p k))-    | k <- polygon, k /= a && k /= b && k /= c-    ]-  where-    aP = ringAccess p a-    bP = ringAccess p b-    cP = ringAccess p c

@@ -1,3 +1,6 @@+{-# LANGUAGE BangPatterns    #-}+{-# LANGUAGE ConstraintKinds #-}+{-# OPTIONS_HADDOCK hide #-} module Reanimate.Math.Polygon   ( APolygon(..)   , Polygon@@ -5,6 +8,7 @@   , P   , mkPolygon     -- :: (Fractional a, Ord a) => V.Vector (V2 a) -> APolygon a   , mkPolygonFromRing -- :: (Fractional a, Ord a) => Ring a -> APolygon a+  , castPolygon   -- :: (Real a, Fractional b, Ord a) => APolygon a -> APolygon b   , pParent       -- :: Polygon -> Int -> Int -> Int   , pSetOffset    -- :: APolygon a -> Int -> APolygon a   , pAdjustOffset -- :: APolygon a -> Int -> APolygon a@@ -33,7 +37,10 @@   , pCircumference   -- :: (Real a, Fractional a) => APolygon a -> a   , pCircumference'  -- :: (Real a, Fractional a) => APolygon a -> Double   , pAddPoints       -- :: Int -> Polygon -> Polygon+  , pAddPointsRestricted -- :: [Int] -> Int -> Polygon -> Polygon+  , pAddPointsBetween -- :: (Fractional a, Ord a, Real a) => (Int, Int) -> Int -> APolygon a -> APolygon a   , pRayIntersect    -- :: Polygon -> (Int, Int) -> (Int,Int) -> Maybe (V2 Rational)+  , pOverlap         -- :: Polygon -> Polygon -> Polygon   , pCuts         -- :: Polygon -> [(Polygon,Polygon)]   , pCutEqual     -- :: Polygon -> (Polygon, Polygon)   -- * Triangulation@@ -77,6 +84,7 @@   , pCopy       -- :: Polygon -> Polygon   , pGenerate   -- :: [(Double, Double)] -> Polygon   , pUnGenerate -- :: Polygon -> [(Double, Double)]+  , Epsilon   ) where  -- import           Control.Exception@@ -91,7 +99,7 @@ import           Linear.V2 import           Linear.Vector import           Reanimate.Math.Common-import           Reanimate.Math.EarClip+-- import           Reanimate.Math.EarClip import           Reanimate.Math.SSSP import           Reanimate.Math.Triangulate @@ -119,14 +127,16 @@ instance Hashable a => Hashable (APolygon a) where   hashWithSalt s p = V.foldl' hashWithSalt s (polygonPoints p) -instance (Real a, Fractional a, Ord a, Serialize a) => Serialize (APolygon a) where+instance (PolyCtx 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 :: (Real a, Fractional a, Ord a) => V.Vector (V2 a) -> APolygon a+type PolyCtx a = (Real a, Fractional a, Epsilon a)++mkPolygon :: PolyCtx a => V.Vector (V2 a) -> APolygon a mkPolygon points = Polygon     { polygonPoints = points     , polygonOffset = 0@@ -136,17 +146,20 @@   where     n = length points     ring = ringPack points-    trig = earCut ring+    trig = triangulate ring       -- earClip ring -mkPolygonFromRing :: (Real a, Fractional a, Ord a) => Ring a -> APolygon a+castPolygon :: (PolyCtx a, PolyCtx b) => APolygon a -> APolygon b+castPolygon = mkPolygon . V.map (fmap realToFrac) . polygonPoints++mkPolygonFromRing :: PolyCtx a => Ring a -> APolygon a mkPolygonFromRing = mkPolygon . ringUnpack  pUnsafeMap :: (Ring a -> Ring a) -> APolygon a -> APolygon a pUnsafeMap fn p = p{ polygonPoints = ringUnpack (fn (pRing p)) }  -- pParent p i j = shortest-path parent from j to i-pParent :: Polygon -> Int -> Int -> Int+pParent :: APolygon a -> Int -> Int -> Int pParent p i j =     (sTree V.! mod (j + polygonOffset p) n - polygonOffset p) `mod` n   where@@ -164,6 +177,7 @@ pAdjustOffset p offset =   p { polygonOffset = (polygonOffset p + offset) `mod` pSize p } +{-# INLINE pSize #-} pSize :: APolygon a -> Int pSize = length . polygonPoints @@ -316,9 +330,10 @@ --     findSmallest = minimumBy (comparing area2X) --     shareEdge p1 p2 = -+{-# INLINE pAccess #-} pAccess :: APolygon a -> Int -> V2 a-pAccess p i = polygonPoints p V.! ((polygonOffset p + i) `mod` pSize p)+pAccess p i = -- polygonPoints p V.! ((polygonOffset p + i) `mod` pSize p)+  polygonPoints p `V.unsafeIndex` ((polygonOffset p + i) `mod` pSize p)  triangle :: Polygon triangle = mkPolygon $ V.fromList [V2 1 1, V2 0 0, V2 2 0]@@ -503,10 +518,10 @@           in lerp 0.99999 this prev         else pAccess p n -pCycles :: Polygon -> [Polygon]+pCycles :: APolygon a -> [APolygon a] pCycles p = map (pAdjustOffset p) [0 .. pSize p-1] -pCycle :: (Real a, Fractional a, Ord a) => APolygon a -> Double -> APolygon a+pCycle :: PolyCtx a => APolygon a -> Double -> APolygon a pCycle p 0 = p pCycle p t = mkPolygon $ worker 0 0   where@@ -526,7 +541,7 @@     len = pCircumference' p     limit = t * len -pCentroid :: Polygon -> V2 Rational+pCentroid :: Fractional a => APolygon a -> V2 a pCentroid p = V2 cx cy   where     a = pArea p@@ -535,13 +550,29 @@     fnX (V2 x y) (V2 x' y') = (x+x')*(x*y' - x'*y)     fnY (V2 x y) (V2 x' y') = (y+y')*(x*y' - x'*y) -pMapEdges :: (V2 Rational -> V2 Rational -> a) -> Polygon -> V.Vector a-pMapEdges fn p = V.generate (pSize p) $ \i ->-  fn (pAccess p i) (pAccess p $ i+1)+{-# INLINE pMapEdges #-}+pMapEdges :: (V2 a -> V2 a -> b) -> APolygon a -> V.Vector b+pMapEdges fn p = V.generate n $ \i ->+  if i == n-1+    then fn (arr `V.unsafeIndex` i) (arr `V.unsafeIndex` 0)+    else fn (arr `V.unsafeIndex` i) (arr `V.unsafeIndex` (i+1))+  where+    n = pSize p+    arr = polygonPoints p -pArea :: Polygon -> Rational+{-# SPECIALIZE pArea :: APolygon Double -> Double #-}+{-# SPECIALIZE pArea :: APolygon Rational -> Rational #-}+pArea :: (Fractional a) => APolygon a -> a pArea p =-  0.5 * V.sum (pMapEdges (\(V2 x y) (V2 x' y') -> x*y' - x'*y) p)+  -- 0.5 * V.sum (pMapEdges (\(V2 x y) (V2 x' y') -> x*y' - x'*y) p)+  0.5 * worker 0 0+  where+    fn (V2 x y) (V2 x' y') = x*y' - x'*y+    arr = polygonPoints p+    worker !acc i+      | i == pSize p - 1 = acc + fn (arr `V.unsafeIndex` i) (arr `V.unsafeIndex` 0)+      | otherwise =+        worker (acc + fn (arr `V.unsafeIndex` i) (arr `V.unsafeIndex` (i+1))) (i+1)  pCircumference :: (Real a, Fractional a) => APolygon a -> a pCircumference p = sum@@ -555,7 +586,7 @@   -- Add points by splitting the longest lines in half repeatedly.-pAddPoints :: Int -> Polygon -> Polygon+pAddPoints :: PolyCtx a => Int -> APolygon a -> APolygon a pAddPoints n p | n <= 0 = p pAddPoints n p = pAddPoints (n-1) $     mkPolygon $ V.fromList $ concatMap worker [0 .. pSize p-1]@@ -572,6 +603,45 @@       distSquared (pAccess p a) (pAccess p $ a+1) `compare`       distSquared (pAccess p b) (pAccess p $ b+1) +pAddPointsRestricted :: PolyCtx a => [(V2 a, V2 a)] -> Int -> APolygon a -> APolygon a+pAddPointsRestricted _immutableEdges n p | n <= 0 = p+pAddPointsRestricted immutableEdges n p = pAddPointsRestricted immutableEdges (n-1) $+    mkPolygon $ V.fromList $ concatMap worker [0 .. pSize p-1]+  where+    isImmutable idx =+      (pAccess p idx, pAccess p $ idx+1) `elem` immutableEdges ||+      (pAccess p $ idx+1, pAccess p idx) `elem` immutableEdges+    worker idx+      | idx == longestEdge && not (isImmutable idx) =+        let start = pAccess p idx+            end = pAccess p $ idx+1+            middle = lerp 0.5 end start+        in [start, middle]+      | otherwise = [pAccess p idx]+    longestEdge = maximumBy cmpLength [0 .. pSize p-1]+    cmpLength a _ | isImmutable a = LT+    cmpLength _ b | isImmutable b = GT+    cmpLength a b =+      distSquared (pAccess p a) (pAccess p $ a+1) `compare`+      distSquared (pAccess p b) (pAccess p $ b+1)++pAddPointsBetween :: PolyCtx a => (Int, Int) -> Int -> APolygon a -> APolygon a+pAddPointsBetween _ n p | n <= 0 = p+pAddPointsBetween (i,l) n p = pAddPointsBetween (i,l+1) (n-1) $+    mkPolygon $ V.fromList $ concatMap worker [0 .. pSize p-1]+  where+    worker idx+      | idx == longestEdge =+        let start = pAccess p idx+            end = pAccess p $ idx+1+            middle = lerp 0.5 end start+        in [start, middle]+      | otherwise = [pAccess p idx]+    longestEdge = maximumBy cmpLength [i .. i+l-1]+    cmpLength a b =+      distSquared (pAccess p a) (pAccess p $ a+1) `compare`+      distSquared (pAccess p b) (pAccess p $ b+1)+ -- addPoints :: Int -> Polygon -> Polygon -- addPoints n p = mkPolygon $ V.fromList $ worker n 0 (map (pAccess p) [0..s]) --   where@@ -603,11 +673,11 @@     fn (V2 x1 y1) (V2 x2 y2) = (x2-x1)*(y2+y1)  {-# INLINE pRayIntersect #-}-pRayIntersect :: Polygon -> (Int, Int) -> (Int,Int) -> Maybe (V2 Rational)+pRayIntersect :: PolyCtx a => APolygon a -> (Int, Int) -> (Int,Int) -> Maybe (V2 a) pRayIntersect p (a,b) (c,d) =   rayIntersect (pAccess p a, pAccess p b) (pAccess p c, pAccess p d) -pCuts :: Polygon -> [(Polygon,Polygon)]+pCuts :: (Real a, Fractional a, Epsilon a) => APolygon a -> [(APolygon a,APolygon a)] pCuts p =   [ pCutAt (pAdjustOffset p i) (j-i)   | i <- [0 .. pSize p-1 ]@@ -615,26 +685,41 @@   , (j+1) `mod` pSize p /= i   , pParent p i j == i ] -pCutEqual :: Polygon -> (Polygon, Polygon)+pCutEqual :: PolyCtx a => APolygon a -> (APolygon a, APolygon a) 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 :: PolyCtx a => APolygon a -> Int -> (APolygon a, APolygon a) 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]) -+pOverlap :: PolyCtx a => APolygon a -> APolygon a -> APolygon a+pOverlap a b = mkPolygon $ V.fromList $ clearDups $ concatMap edgeIntersect [0 .. pSize a-1]+  where+    clearDups (x:y:xs)+      | x == y = clearDups (y:xs)+      | otherwise = x : clearDups (y:xs)+    clearDups xs = xs+    edgeIntersect edge =+      sortOn (distSquared (pAccess a edge)) $ catMaybes+      [ lineIntersect (aP, aP') (bP, bP')+      | i <- [0 .. pSize b-1]+      , let aP = pAccess a edge+            aP' = pAccess a (edge+1)+            bP = pAccess b i+            bP' = pAccess b (i+1)+      ]  --------------------------------------------------------- -- SSSP visibility and SSSP windows -ssspVisibility :: Polygon -> Polygon+ssspVisibility :: PolyCtx a => APolygon a -> APolygon a ssspVisibility p = mkPolygon $     V.fromList $ clearDups $ go [0 .. pSize p-1] -- ([root..pSize p-1]  ++ [0 .. root-1])   where