diff --git a/haddock.txt b/haddock.txt index 9029746..6c5d904 100644 --- a/haddock.txt +++ b/haddock.txt @@ -4,6 +4,7 @@ 100% ( 40 / 40) in 'Reanimate.GeoProjection' 100% ( 25 / 25) in 'Reanimate.PolyShape' 100% ( 22 / 22) in 'Reanimate.Effect' + 100% ( 18 / 18) in 'Reanimate.Svg' 100% ( 17 / 17) in 'Reanimate.Parameters' 100% ( 14 / 14) in 'Reanimate.Raster' 100% ( 13 / 13) in 'Reanimate.Render' @@ -16,24 +17,23 @@ 100% ( 9 / 9) in 'Reanimate.LaTeX' 100% ( 9 / 9) in 'Reanimate.Constants' 100% ( 8 / 8) in 'Reanimate.Transition' + 100% ( 8 / 8) in 'Reanimate.Svg.LineCommand' 100% ( 8 / 8) in 'Reanimate.Builtin.TernaryPlot' - 100% ( 7 / 7) in 'Reanimate.Svg.LineCommand' 100% ( 7 / 7) in 'Reanimate.Builtin.Documentation' 100% ( 6 / 6) in 'Reanimate.Morph.Linear' + 100% ( 6 / 6) in 'Reanimate.ColorSpace' 100% ( 6 / 6) in 'Reanimate.Builtin.Images' 100% ( 5 / 5) in 'Reanimate.Transform' 100% ( 4 / 4) in 'Reanimate.Svg.Unuse' 100% ( 4 / 4) in 'Reanimate.Svg.BoundingBox' 100% ( 4 / 4) in 'Reanimate.Morph.Rotational' 100% ( 4 / 4) in 'Reanimate.Debug' + 100% ( 4 / 4) in 'Reanimate.Builtin.Slide' + 100% ( 4 / 4) in 'Reanimate.Builtin.Flip' 100% ( 3 / 3) in 'Reanimate.Memo' 100% ( 3 / 3) in 'Reanimate.Math.Balloon' 100% ( 3 / 3) in 'Reanimate.Blender' 100% ( 2 / 2) in 'Reanimate.Builtin.CirclePlot' 97% ( 28 / 29) in 'Reanimate.Math.Common' 89% (101 /113) in 'Reanimate.Scene' - 84% ( 31 / 37) in 'Geom2D.CubicBezier.Linear' - 61% ( 11 / 18) in 'Reanimate.Svg' - 50% ( 2 / 4) in 'Reanimate.Builtin.Slide' - 20% ( 1 / 5) in 'Reanimate.Builtin.Flip' - 10% ( 1 / 10) in 'Reanimate.ColorSpace' + 89% ( 32 / 36) in 'Geom2D.CubicBezier.Linear' diff --git a/haddock_badge.json b/haddock_badge.json index d0298ce..34b3093 100644 --- a/haddock_badge.json +++ b/haddock_badge.json @@ -1 +1 @@ - { "schemaVersion": 1, "label": "api docs", "message": "94%", "color": "success" } + { "schemaVersion": 1, "label": "api docs", "message": "99%", "color": "success" } diff --git a/hpc_index.html b/hpc_index.html index 556c84d..2ff4285 100644 --- a/hpc_index.html +++ b/hpc_index.html @@ -8,7 +8,7 @@ table.dashboard { border-collapse: collapse ; border: solid 1px black } - + @@ -23,7 +23,7 @@ table.dashboard { border-collapse: collapse ; border: solid 1px black } - + @@ -125,5 +125,5 @@ table.dashboard { border-collapse: collapse ; border: solid 1px black } - +
moduleTop Level DefinitionsAlternativesExpressions
%covered / total%covered / total%covered / total
  module reanimate-0.4.1.0-inplace/Geom2D.CubicBezier.Linear23%20/86
7%2/26
30%102/337
20%20/99
5%2/36
28%102/356
  module reanimate-0.4.1.0-inplace/Paths_reanimate 20%3/15
- 0/0 20%12/58
57%4/7
25%1/4
48%24/49
  module reanimate-0.4.1.0-inplace/Reanimate.Builtin.Slide33%1/3
- 0/0 30%18/60
100%3/3
- 0/0 90%54/60
  module reanimate-0.4.1.0-inplace/Reanimate.Cache 0%0/8
0%0/12
0%0/160
100%6/6
50%1/2
95%43/45
  Program Coverage Total31%246/785
16%131/805
29%4646/15511
31%248/798
16%131/815
30%4682/15530
diff --git a/hpc_index_alt.html b/hpc_index_alt.html index d9ca8cf..abacd8c 100644 --- a/hpc_index_alt.html +++ b/hpc_index_alt.html @@ -56,7 +56,7 @@ table.dashboard { border-collapse: collapse ; border: solid 1px black } 33%4/12
11%1/9
7%12/167
  module reanimate-0.4.1.0-inplace/Geom2D.CubicBezier.Linear -23%20/86
7%2/26
30%102/337
+20%20/99
5%2/36
28%102/356
  module reanimate-0.4.1.0-inplace/Reanimate.Math.Polygon 8%7/82
5%4/79
2%58/2494
@@ -110,7 +110,7 @@ table.dashboard { border-collapse: collapse ; border: solid 1px black } 100%6/6
- 0/0 100%117/117
  module reanimate-0.4.1.0-inplace/Reanimate.Builtin.Slide -33%1/3
- 0/0 30%18/60
+100%3/3
- 0/0 90%54/60
  module reanimate-0.4.1.0-inplace/Reanimate.Constants 37%3/8
- 0/0 16%3/18
@@ -125,5 +125,5 @@ table.dashboard { border-collapse: collapse ; border: solid 1px black } 15%3/20
- 0/0 14%7/49
  Program Coverage Total -31%246/785
16%131/805
29%4646/15511
+31%248/798
16%131/815
30%4682/15530
diff --git a/hpc_index_exp.html b/hpc_index_exp.html index 22f0704..68d2ffd 100644 --- a/hpc_index_exp.html +++ b/hpc_index_exp.html @@ -19,6 +19,9 @@ table.dashboard { border-collapse: collapse ; border: solid 1px black }   module reanimate-0.4.1.0-inplace/Reanimate.Transition 100%6/6
50%1/2
95%43/45
+  module reanimate-0.4.1.0-inplace/Reanimate.Builtin.Slide +100%3/3
- 0/0 90%54/60
+   module reanimate-0.4.1.0-inplace/Reanimate.Animation 90%28/31
57%8/14
87%298/341
@@ -50,10 +53,7 @@ table.dashboard { border-collapse: collapse ; border: solid 1px black } 30%40/130
60%15/25
36%545/1483
  module reanimate-0.4.1.0-inplace/Geom2D.CubicBezier.Linear -23%20/86
7%2/26
30%102/337
- -  module reanimate-0.4.1.0-inplace/Reanimate.Builtin.Slide -33%1/3
- 0/0 30%18/60
+20%20/99
5%2/36
28%102/356
  module reanimate-0.4.1.0-inplace/Reanimate.Morph.Linear 40%2/5
16%1/6
26%22/83
@@ -125,5 +125,5 @@ table.dashboard { border-collapse: collapse ; border: solid 1px black } 0%0/1
0%0/4
0%0/61
  Program Coverage Total -31%246/785
16%131/805
29%4646/15511
+31%248/798
16%131/815
30%4682/15530
diff --git a/hpc_index_fun.html b/hpc_index_fun.html index 698e4e2..31f0016 100644 --- a/hpc_index_fun.html +++ b/hpc_index_fun.html @@ -10,6 +10,9 @@ table.dashboard { border-collapse: collapse ; border: solid 1px black }   module reanimate-0.4.1.0-inplace/Reanimate.Builtin.Documentation 100%6/6
- 0/0 100%117/117
+  module reanimate-0.4.1.0-inplace/Reanimate.Builtin.Slide +100%3/3
- 0/0 90%54/60
+   module reanimate-0.4.1.0-inplace/Reanimate.ColorMap 100%14/14
60%3/5
99%1176/1180
@@ -52,9 +55,6 @@ table.dashboard { border-collapse: collapse ; border: solid 1px black }   module reanimate-0.4.1.0-inplace/Reanimate.Constants 37%3/8
- 0/0 16%3/18
-  module reanimate-0.4.1.0-inplace/Reanimate.Builtin.Slide -33%1/3
- 0/0 30%18/60
-   module reanimate-0.4.1.0-inplace/Reanimate.LaTeX 33%4/12
11%1/9
7%12/167
@@ -67,12 +67,12 @@ table.dashboard { border-collapse: collapse ; border: solid 1px black }   module reanimate-0.4.1.0-inplace/Reanimate.Scene 30%40/130
60%15/25
36%545/1483
-  module reanimate-0.4.1.0-inplace/Geom2D.CubicBezier.Linear -23%20/86
7%2/26
30%102/337
-   module reanimate-0.4.1.0-inplace/Reanimate.PolyShape 22%8/35
27%13/48
18%127/691
+  module reanimate-0.4.1.0-inplace/Geom2D.CubicBezier.Linear +20%20/99
5%2/36
28%102/356
+   module reanimate-0.4.1.0-inplace/Paths_reanimate 20%3/15
- 0/0 20%12/58
@@ -125,5 +125,5 @@ table.dashboard { border-collapse: collapse ; border: solid 1px black } 0%0/1
0%0/4
0%0/61
  Program Coverage Total -31%246/785
16%131/805
29%4646/15511
+31%248/798
16%131/815
30%4682/15530
diff --git a/playground/snippets.js b/playground/snippets.js index 54ca0f2..75ab582 100644 --- a/playground/snippets.js +++ b/playground/snippets.js @@ -9,4 +9,4 @@ const snippets = [{"title": "Hello World","url": "https://reanimate.clozecards.c ,{"title": "Object Positions","url": "https://reanimate.clozecards.com/IAQhjO0Ke7h/195.svg","code": "env =\n addStatic (mkBackground \"white\") .\n mapA (withStrokeColor \"black\")\n\nanimation :: Animation\nanimation = env $\n sceneAnimation $ do\n -- Configure objects\n txt <- newText \"Center\"\n top <- newText \"Top\"\n oModifyS top $ \n oTopY .= screenTop\n topR <- newText \"Top right\"\n oModifyS topR $ do\n oTopY .= screenTop\n oRightX .= screenRight\n botR <- newText \"Bottom right\"\n oModifyS botR $ do\n oBottomY .= screenBottom\n oRightX .= screenRight\n botL <- newText \"Bottom left\"\n oModifyS botL $ do\n oBottomY .= screenBottom\n oLeftX .= screenLeft\n topL <- newText \"Top left\"\n oModifyS topL $ do\n oTopY .= screenTop\n oLeftX .= screenLeft\n -- Show objects\n oShow txt\n wait 1\n switchTo txt top\n switchTo top topR\n switchTo topR botR\n switchTo botR botL\n switchTo botL topL\n switchTo topL txt\n\nswitchTo src dst = do\n fork $ oFadeOut src 1\n oModify dst $ oOpacity .~ 1\n oFadeIn dst 1\n wait 1\n\nnewText txt =\n newObject $ scale 1.5 $ center $ latex txt\n"} ,{"title": "Camera","url": "https://reanimate.clozecards.com/CD5Bg7AwVkF/150.svg","code": "animation :: Animation\nanimation = docEnv $ mapA (withFillOpacity 1) $ sceneAnimation $ do\n cam <- newObject Camera\n\n txt <- newObject $ center $ latex \"Fixed (non-cam)\"\n oModifyS txt $ do\n oTopY .= screenTop \n oZIndex .= 2\n\n circle <- newObject $ Circle 1\n cameraAttach cam circle\n oModify circle $ oContext .~ withFillColor \"blue\"\n circleRight <- oRead circle oRightX\n\n box <- newObject $ Rectangle 2 2\n cameraAttach cam box\n oModify box $ oContext .~ withFillColor \"green\"\n oModify box $ oLeftX .~ circleRight\n boxCenter <- oRead box oCenterXY\n\n small <- newObject $ center $ latex \"This text is very small\"\n cameraAttach cam small\n oModifyS small $ do\n oCenterXY .= boxCenter\n oScale .= 0.1\n \n oShow txt\n oShow small\n oShow circle\n oShow box\n\n wait 1\n\n cameraFocus cam boxCenter\n waitOn $ do\n fork $ cameraPan cam 3 boxCenter\n fork $ cameraZoom cam 3 15\n \n wait 2\n cameraZoom cam 3 1\n cameraPan cam 1 (0,0)\n"} ]; -const playgroundVersion = "2020-08-27 (aa465)"; +const playgroundVersion = "2020-08-27 (aed34)"; diff --git a/reanimate-0.4.1.0-inplace/Geom2D.CubicBezier.Linear.hs.html b/reanimate-0.4.1.0-inplace/Geom2D.CubicBezier.Linear.hs.html index 1f9ea81..8f8d0a4 100644 --- a/reanimate-0.4.1.0-inplace/Geom2D.CubicBezier.Linear.hs.html +++ b/reanimate-0.4.1.0-inplace/Geom2D.CubicBezier.Linear.hs.html @@ -17,320 +17,350 @@ span.spaces { background: white } never executed always true always false 
-    1 {-# LANGUAGE FunctionalDependencies #-}
-    2 {-# LANGUAGE MultiParamTypeClasses  #-}
-    3 {-# LANGUAGE UndecidableInstances   #-}
-    4 {-|
-    5 Module      : Geom2D.CubicBezier.Linear
-    6 Copyright   : Written by David Himmelstrup
-    7 License     : Unlicense
-    8 Maintainer  : lemmih@gmail.com
-    9 Stability   : experimental
-   10 Portability : POSIX
-   11 
-   12 Convenience wrapper around 'Geom2D.CubicBezier'
-   13 
-   14 -}
-   15 module Geom2D.CubicBezier.Linear
-   16   ( AnyBezier(..)
-   17   , CubicBezier(..)
-   18   , QuadBezier(..)
-   19   , OpenPath(..)
-   20   , ClosedPath(..)
-   21   , PathJoin(..)
-   22   , ClosedMetaPath(..)
-   23   , OpenMetaPath(..)
-   24   , MetaJoin(..)
-   25   , MetaNodeType(..)
-   26   , C.GenericBezier(..)
-   27   , C.FillRule(..)
-   28   , C.Tension(..)
-   29   , quadToCubic
-   30   , arcLength
-   31   , arcLengthParam
-   32   , C.splitBezier
-   33   , colinear
-   34   , evalBezier
-   35   , evalBezierDeriv
-   36   , bezierHoriz
-   37   , bezierVert
-   38   , C.bezierSubsegment
-   39   , C.reorient
-   40   , closedPathCurves
-   41   , openPathCurves
-   42   , curvesToClosed
-   43   , closest
-   44   , unmetaOpen
-   45   , unmetaClosed
-   46   , union
-   47   , bezierIntersection
-   48   , interpolateVector
-   49   , vectorDistance
-   50   , findBezierInflection
-   51   , findBezierCusp
-   52   ) where
-   53 
-   54 import qualified Data.Vector.Unboxed as V
-   55 import qualified Geom2D.CubicBezier  as C
-   56 import           Linear.V2
-   57 
-   58 ------------------------------------------------------------
-   59 -- Data types
+    1 {-# LANGUAGE DeriveFoldable         #-}
+    2 {-# LANGUAGE DeriveFunctor          #-}
+    3 {-# LANGUAGE DeriveTraversable      #-}
+    4 {-# LANGUAGE FunctionalDependencies #-}
+    5 {-# LANGUAGE MultiParamTypeClasses  #-}
+    6 {-# LANGUAGE UndecidableInstances   #-}
+    7 {-|
+    8 Module      : Geom2D.CubicBezier.Linear
+    9 Copyright   : Written by David Himmelstrup
+   10 License     : Unlicense
+   11 Maintainer  : lemmih@gmail.com
+   12 Stability   : experimental
+   13 Portability : POSIX
+   14 
+   15 Convenience wrapper around 'Geom2D.CubicBezier'
+   16 
+   17 -}
+   18 module Geom2D.CubicBezier.Linear
+   19   ( AnyBezier(..)
+   20   , CubicBezier(..)
+   21   , QuadBezier(..)
+   22   , OpenPath(..)
+   23   , ClosedPath(..)
+   24   , PathJoin(..)
+   25   , ClosedMetaPath(..)
+   26   , OpenMetaPath(..)
+   27   , MetaJoin(..)
+   28   , MetaNodeType(..)
+   29   , FillRule(..)
+   30   , Tension(..)
+   31   , quadToCubic
+   32   , arcLength
+   33   , arcLengthParam
+   34   , C.splitBezier
+   35   , colinear
+   36   , evalBezier
+   37   , evalBezierDeriv
+   38   , bezierHoriz
+   39   , bezierVert
+   40   , C.bezierSubsegment
+   41   , C.reorient
+   42   , closedPathCurves
+   43   , openPathCurves
+   44   , curvesToClosed
+   45   , closest
+   46   , unmetaOpen
+   47   , unmetaClosed
+   48   , union
+   49   , bezierIntersection
+   50   , interpolateVector
+   51   , vectorDistance
+   52   , findBezierInflection
+   53   , findBezierCusp
+   54   ) where
+   55 
+   56 import qualified Data.Vector.Unboxed as V
+   57 import qualified Geom2D.CubicBezier  as C
+   58 import           Graphics.SvgTree    (FillRule (..))
+   59 import           Linear.V2
    60 
-   61 -- | A bezier curve of any degree.
-   62 newtype AnyBezier a = AnyBezier (V.Vector (V2 a))
+   61 ------------------------------------------------------------
+   62 -- Data types
    63 
-   64 -- | A cubic bezier curve.
-   65 data CubicBezier a = CubicBezier
-   66   { cubicC0 :: !(V2 a)
-   67   , cubicC1 :: !(V2 a)
-   68   , cubicC2 :: !(V2 a)
-   69   , cubicC3 :: !(V2 a)
-   70   } deriving (Show, Eq)
-   71 
-   72 -- | A quadratic bezier curve.
-   73 data QuadBezier a = QuadBezier
-   74   { quadC0 :: !(V2 a)
-   75   , quadC1 :: !(V2 a)
-   76   , quadC2 :: !(V2 a)
-   77   } deriving (Show, Eq)
-   78 
-   79 -- | Open cubicbezier path.
-   80 data OpenPath a = OpenPath [(V2 a, PathJoin a)] (V2 a)
-   81   deriving (Show, Eq)
-   82 
-   83 -- | Closed cubicbezier path.
-   84 data ClosedPath a = ClosedPath [(V2 a, PathJoin a)]
-   85   deriving (Show, Eq)
-   86 
-   87 -- | Join two points with either a straight line or a bezier
-   88 --   curve with two control points.
-   89 data PathJoin a
-   90   = JoinLine
-   91   | JoinCurve (V2 a) (V2 a)
-   92   deriving (Show, Eq)
-   93 
-   94 -- | Closed meta path.
-   95 data ClosedMetaPath a = ClosedMetaPath [(V2 a, MetaJoin a)]
-   96   deriving (Show, Eq)
-   97 
-   98 -- | Open meta path
-   99 data OpenMetaPath a = OpenMetaPath [(V2 a, MetaJoin a)] (V2 a)
-  100   deriving (Show, Eq)
-  101 
-  102 -- | Join two meta points with either a bezier curve or tension
-  103 --   contraints.
-  104 data MetaJoin a
-  105   = MetaJoin
-  106   { metaTypeL :: MetaNodeType a
-  107   , tensionL  :: C.Tension a
-  108   , tensionR  :: C.Tension a
-  109   , metaTypeR :: MetaNodeType a
-  110   }
-  111   | Controls (V2 a) (V2 a)
-  112   deriving (Show, Eq)
-  113 
-  114 -- | Node constraint type.
-  115 data MetaNodeType a
-  116   = Open
-  117   | Curl { curlgamma :: a }
-  118   | Direction { nodedir :: V2 a }
-  119   deriving (Show, Eq)
-  120 
-  121 ------------------------------------------------------------
-  122 -- Methods
-  123 
-  124 -- | Convert a quadratic bezier to a cubic bezier.
-  125 quadToCubic :: Fractional a => QuadBezier a -> CubicBezier a
-  126 quadToCubic = upCast . C.quadToCubic . downCast
-  127 
-  128 -- | @arcLength c t tol@ finds the arclength of the bezier @c@ at @t@,
-  129 --   within given tolerance @tol@.
-  130 arcLength :: CubicBezier Double -> Double -> Double -> Double
-  131 arcLength bezier t tol = C.arcLength (downCast bezier) t tol
-  132 
-  133 -- | @arcLengthParam c len tol@ finds the parameter where the curve @c@
-  134 --   has the arclength @len@, within tolerance @tol@.
-  135 arcLengthParam :: CubicBezier Double -> Double -> Double -> Double
-  136 arcLengthParam bezier t tol = C.arcLengthParam (downCast bezier) t tol
-  137 
-  138 -- | Return @False@ if some points fall outside a line with a thickness of the given tolerance.
-  139 colinear :: CubicBezier Double -> Double -> Bool
-  140 colinear bezier tol = C.colinear (downCast bezier) tol
-  141 
-  142 -- | Calculate a value on the bezier curve.
-  143 evalBezier :: (C.GenericBezier b, V.Unbox a, Fractional a) => b a -> a -> V2 a
-  144 evalBezier c p = upCast $ C.evalBezier c p
-  145 
-  146 -- | Calculate a value and the first derivative on the curve.
-  147 evalBezierDeriv :: (V.Unbox a, Fractional a,C.GenericBezier b) => b a -> a -> (V2 a, V2 a)
-  148 evalBezierDeriv c p = upCast $ C.evalBezierDeriv c p
-  149 
-  150 -- | Find the parameter where the bezier curve is horizontal.
-  151 bezierHoriz :: CubicBezier Double -> [Double]
-  152 bezierHoriz = C.bezierHoriz . downCast
+   64 -- | A bezier curve of any degree.
+   65 newtype AnyBezier a = AnyBezier (V.Vector (V2 a))
+   66 
+   67 -- | A cubic bezier curve.
+   68 data CubicBezier a = CubicBezier
+   69   { cubicC0 :: !(V2 a)
+   70   , cubicC1 :: !(V2 a)
+   71   , cubicC2 :: !(V2 a)
+   72   , cubicC3 :: !(V2 a)
+   73   } deriving (Show, Eq)
+   74 
+   75 -- | A quadratic bezier curve.
+   76 data QuadBezier a = QuadBezier
+   77   { quadC0 :: !(V2 a)
+   78   , quadC1 :: !(V2 a)
+   79   , quadC2 :: !(V2 a)
+   80   } deriving (Show, Eq)
+   81 
+   82 -- | Open cubicbezier path.
+   83 data OpenPath a = OpenPath [(V2 a, PathJoin a)] (V2 a)
+   84   deriving (Show, Eq)
+   85 
+   86 -- | Closed cubicbezier path.
+   87 data ClosedPath a = ClosedPath [(V2 a, PathJoin a)]
+   88   deriving (Show, Eq)
+   89 
+   90 -- | Join two points with either a straight line or a bezier
+   91 --   curve with two control points.
+   92 data PathJoin a
+   93   = JoinLine
+   94   | JoinCurve (V2 a) (V2 a)
+   95   deriving (Show, Eq)
+   96 
+   97 -- | Closed meta path.
+   98 data ClosedMetaPath a = ClosedMetaPath [(V2 a, MetaJoin a)]
+   99   deriving (Show, Eq)
+  100 
+  101 -- | Open meta path
+  102 data OpenMetaPath a = OpenMetaPath [(V2 a, MetaJoin a)] (V2 a)
+  103   deriving (Show, Eq)
+  104 
+  105 -- | The tension value specifies how /tense/ the curve is.
+  106 --   A higher value means the curve approaches a line segment,
+  107 --   while a lower value means the curve is more round. Metafont
+  108 --   doesn't allow values below 3/4.
+  109 data Tension a
+  110   = Tension
+  111   { tensionValue :: a }
+  112   | TensionAtLeast -- ^ Like Tension, but keep the segment inside the
+  113                    --   bounding triangle defined by the control points,
+  114                    --   if there is one.
+  115   { tensionValue :: a }
+  116   deriving (Functor, Foldable, Traversable, Eq, Show)
+  117 
+  118 -- | Join two meta points with either a bezier curve or tension
+  119 --   contraints.
+  120 data MetaJoin a
+  121   = MetaJoin
+  122   { metaTypeL :: MetaNodeType a
+  123   , tensionL  :: Tension a
+  124   , tensionR  :: Tension a
+  125   , metaTypeR :: MetaNodeType a
+  126   }
+  127   | Controls (V2 a) (V2 a)
+  128   deriving (Show, Eq)
+  129 
+  130 -- | Node constraint type.
+  131 data MetaNodeType a
+  132   = Open
+  133   | Curl { curlgamma :: a }
+  134   | Direction { nodedir :: V2 a }
+  135   deriving (Show, Eq)
+  136 
+  137 ------------------------------------------------------------
+  138 -- Methods
+  139 
+  140 -- | Convert a quadratic bezier to a cubic bezier.
+  141 quadToCubic :: Fractional a => QuadBezier a -> CubicBezier a
+  142 quadToCubic = upCast . C.quadToCubic . downCast
+  143 
+  144 -- | @arcLength c t tol@ finds the arclength of the bezier @c@ at @t@,
+  145 --   within given tolerance @tol@.
+  146 arcLength :: CubicBezier Double -> Double -> Double -> Double
+  147 arcLength bezier t tol = C.arcLength (downCast bezier) t tol
+  148 
+  149 -- | @arcLengthParam c len tol@ finds the parameter where the curve @c@
+  150 --   has the arclength @len@, within tolerance @tol@.
+  151 arcLengthParam :: CubicBezier Double -> Double -> Double -> Double
+  152 arcLengthParam bezier t tol = C.arcLengthParam (downCast bezier) t tol
   153 
-  154 -- | Find the parameter where the bezier curve is vertical.
-  155 bezierVert :: CubicBezier Double -> [Double]
-  156 bezierVert = C.bezierVert . downCast
+  154 -- | Return @False@ if some points fall outside a line with a thickness of the given tolerance.
+  155 colinear :: CubicBezier Double -> Double -> Bool
+  156 colinear bezier tol = C.colinear (downCast bezier) tol
   157 
-  158 -- | Create a normal path from a metapath.
-  159 unmetaOpen :: OpenMetaPath Double -> OpenPath Double
-  160 unmetaOpen = upCast . C.unmetaOpen . downCast
+  158 -- | Calculate a value on the bezier curve.
+  159 evalBezier :: (C.GenericBezier b, V.Unbox a, Fractional a) => b a -> a -> V2 a
+  160 evalBezier c p = upCast $ C.evalBezier c p
   161 
-  162 -- | Create a normal path from a metapath.
-  163 unmetaClosed :: ClosedMetaPath Double -> ClosedPath Double
-  164 unmetaClosed = upCast . C.unmetaClosed . downCast
+  162 -- | Calculate a value and the first derivative on the curve.
+  163 evalBezierDeriv :: (V.Unbox a, Fractional a,C.GenericBezier b) => b a -> a -> (V2 a, V2 a)
+  164 evalBezierDeriv c p = upCast $ C.evalBezierDeriv c p
   165 
-  166 -- | `O((n+m)*log(n+m))`, for n segments and m intersections.
-  167 --   Union of paths, removing overlap and rounding to the given tolerance.
-  168 union :: [ClosedPath Double] -> C.FillRule -> Double -> [ClosedPath Double]
-  169 union p fill tol = upCast (C.union (downCast p) fill tol)
-  170 
-  171 -- | Find the intersections between two Bezier curves, using the Bezier Clip algorithm.
-  172 --   Returns the parameters for both curves.
-  173 bezierIntersection :: CubicBezier Double -> CubicBezier Double -> Double -> [(Double, Double)]
-  174 bezierIntersection a b t = C.bezierIntersection (downCast a) (downCast b) t
-  175 
-  176 -- | Find the closest value on the bezier to the given point, within tolerance.
-  177 --   Return the first value found.
-  178 closest :: CubicBezier Double -> V2 Double -> Double -> Double
-  179 closest c p t = C.closest (downCast c) (downCast p) t
-  180 
-  181 -- | Return the closed path as a list of curves.
-  182 closedPathCurves :: Fractional a => ClosedPath a -> [CubicBezier a]
-  183 closedPathCurves = upCast . C.closedPathCurves . downCast
-  184 
-  185 -- | Return the open path as a list of curves.
-  186 openPathCurves :: Fractional a => OpenPath a -> [CubicBezier a]
-  187 openPathCurves = upCast . C.openPathCurves . downCast
-  188 
-  189 -- | Make an open path from a list of curves. The last control point of each curve is ignored.
-  190 curvesToClosed :: [CubicBezier a] -> ClosedPath a
-  191 curvesToClosed = upCast . C.curvesToClosed . downCast
-  192 
-  193 -- | Interpolate between two vectors.
-  194 interpolateVector :: Num a => V2 a -> V2 a -> a -> V2 a
-  195 interpolateVector a b p = upCast $ C.interpolateVector (downCast a) (downCast b) p
+  166 -- | Find the parameter where the bezier curve is horizontal.
+  167 bezierHoriz :: CubicBezier Double -> [Double]
+  168 bezierHoriz = C.bezierHoriz . downCast
+  169 
+  170 -- | Find the parameter where the bezier curve is vertical.
+  171 bezierVert :: CubicBezier Double -> [Double]
+  172 bezierVert = C.bezierVert . downCast
+  173 
+  174 -- | Create a normal path from a metapath.
+  175 unmetaOpen :: OpenMetaPath Double -> OpenPath Double
+  176 unmetaOpen = upCast . C.unmetaOpen . downCast
+  177 
+  178 -- | Create a normal path from a metapath.
+  179 unmetaClosed :: ClosedMetaPath Double -> ClosedPath Double
+  180 unmetaClosed = upCast . C.unmetaClosed . downCast
+  181 
+  182 -- | `O((n+m)*log(n+m))`, for n segments and m intersections.
+  183 --   Union of paths, removing overlap and rounding to the given tolerance.
+  184 union :: [ClosedPath Double] -> FillRule -> Double -> [ClosedPath Double]
+  185 union p fill tol = upCast (C.union (downCast p) (downCast fill) tol)
+  186 
+  187 -- | Find the intersections between two Bezier curves, using the Bezier Clip algorithm.
+  188 --   Returns the parameters for both curves.
+  189 bezierIntersection :: CubicBezier Double -> CubicBezier Double -> Double -> [(Double, Double)]
+  190 bezierIntersection a b t = C.bezierIntersection (downCast a) (downCast b) t
+  191 
+  192 -- | Find the closest value on the bezier to the given point, within tolerance.
+  193 --   Return the first value found.
+  194 closest :: CubicBezier Double -> V2 Double -> Double -> Double
+  195 closest c p t = C.closest (downCast c) (downCast p) t
   196 
-  197 -- | Distance between two vectors.
-  198 vectorDistance :: Floating a => V2 a -> V2 a -> a
-  199 vectorDistance a b = C.vectorDistance (downCast a) (downCast b)
+  197 -- | Return the closed path as a list of curves.
+  198 closedPathCurves :: Fractional a => ClosedPath a -> [CubicBezier a]
+  199 closedPathCurves = upCast . C.closedPathCurves . downCast
   200 
-  201 -- | Find inflection points on the curve.
-  202 findBezierInflection :: CubicBezier Double -> [Double]
-  203 findBezierInflection = C.findBezierInflection . downCast
+  201 -- | Return the open path as a list of curves.
+  202 openPathCurves :: Fractional a => OpenPath a -> [CubicBezier a]
+  203 openPathCurves = upCast . C.openPathCurves . downCast
   204 
-  205 -- | Find the cusps of a bezier.
-  206 findBezierCusp :: CubicBezier Double -> [Double]
-  207 findBezierCusp = C.findBezierCusp . downCast
+  205 -- | Make an open path from a list of curves. The last control point of each curve is ignored.
+  206 curvesToClosed :: [CubicBezier a] -> ClosedPath a
+  207 curvesToClosed = upCast . C.curvesToClosed . downCast
   208 
-  209 ------------------------------------------------------------
-  210 -- Instances
-  211 
-  212 instance C.GenericBezier QuadBezier where
-  213   degree = C.degree . downCast
-  214   toVector = C.toVector . downCast
-  215   unsafeFromVector = upCast . C.unsafeFromVector
+  209 -- | Interpolate between two vectors.
+  210 interpolateVector :: Num a => V2 a -> V2 a -> a -> V2 a
+  211 interpolateVector a b p = upCast $ C.interpolateVector (downCast a) (downCast b) p
+  212 
+  213 -- | Distance between two vectors.
+  214 vectorDistance :: Floating a => V2 a -> V2 a -> a
+  215 vectorDistance a b = C.vectorDistance (downCast a) (downCast b)
   216 
-  217 instance C.GenericBezier CubicBezier where
-  218   degree = C.degree . downCast
-  219   toVector = C.toVector . downCast
-  220   unsafeFromVector = upCast . C.unsafeFromVector
-  221 
-  222 instance C.GenericBezier AnyBezier where
-  223   degree = C.degree . downCast
-  224   toVector = C.toVector . downCast
-  225   unsafeFromVector = upCast . C.unsafeFromVector
-  226 
-  227 ------------------------------------------------------------
-  228 -- Casting
-  229 
-  230 class Cast a b | a -> b, b -> a where
-  231   downCast :: a -> b
-  232   upCast   :: b -> a
-  233 
-  234 instance Cast a b => Cast [a] [b] where
-  235   downCast = map downCast
-  236   upCast = map upCast
+  217 -- | Find inflection points on the curve.
+  218 findBezierInflection :: CubicBezier Double -> [Double]
+  219 findBezierInflection = C.findBezierInflection . downCast
+  220 
+  221 -- | Find the cusps of a bezier.
+  222 findBezierCusp :: CubicBezier Double -> [Double]
+  223 findBezierCusp = C.findBezierCusp . downCast
+  224 
+  225 ------------------------------------------------------------
+  226 -- Instances
+  227 
+  228 instance C.GenericBezier QuadBezier where
+  229   degree = C.degree . downCast
+  230   toVector = C.toVector . downCast
+  231   unsafeFromVector = upCast . C.unsafeFromVector
+  232 
+  233 instance C.GenericBezier CubicBezier where
+  234   degree = C.degree . downCast
+  235   toVector = C.toVector . downCast
+  236   unsafeFromVector = upCast . C.unsafeFromVector
   237 
-  238 instance (Cast a a', Cast b b') => Cast (a,b) (a',b') where
-  239   downCast (a, b) = (downCast a, downCast b)
-  240   upCast (a, b) = (upCast a, upCast b)
-  241 
-  242 instance Cast (V2 a) (C.Point a) where
-  243   downCast (V2 a b) = C.Point a b
-  244   upCast (C.Point a b) = V2 a b
+  238 instance C.GenericBezier AnyBezier where
+  239   degree = C.degree . downCast
+  240   toVector = C.toVector . downCast
+  241   unsafeFromVector = upCast . C.unsafeFromVector
+  242 
+  243 ------------------------------------------------------------
+  244 -- Casting
   245 
-  246 instance Cast (CubicBezier a) (C.CubicBezier a) where
-  247   downCast (CubicBezier a b c d) = C.CubicBezier
-  248     (downCast a) (downCast b) (downCast c) (downCast d)
-  249   upCast (C.CubicBezier a b c d) = CubicBezier
-  250     (upCast a) (upCast b) (upCast c) (upCast d)
-  251 
-  252 instance Cast (QuadBezier a) (C.QuadBezier a) where
-  253   downCast (QuadBezier a b c) = C.QuadBezier
-  254     (downCast a) (downCast b) (downCast c)
-  255   upCast (C.QuadBezier a b c)= QuadBezier
-  256     (upCast a) (upCast b) (upCast c)
+  246 class Cast a b | a -> b, b -> a where
+  247   downCast :: a -> b
+  248   upCast   :: b -> a
+  249 
+  250 instance Cast a b => Cast [a] [b] where
+  251   downCast = map downCast
+  252   upCast = map upCast
+  253 
+  254 instance (Cast a a', Cast b b') => Cast (a,b) (a',b') where
+  255   downCast (a, b) = (downCast a, downCast b)
+  256   upCast (a, b) = (upCast a, upCast b)
   257 
-  258 instance V.Unbox a => Cast (AnyBezier a) (C.AnyBezier a) where
-  259   downCast (AnyBezier arr) = C.AnyBezier $
-  260     V.map (\(V2 a b) -> (a,b)) arr
-  261   upCast (C.AnyBezier arr) = AnyBezier $
-  262     V.map (\(a, b) -> V2 a b) arr
-  263 
-  264 instance Cast (MetaNodeType a) (C.MetaNodeType a) where
-  265   downCast Open            = C.Open
-  266   downCast (Curl gamma)    = C.Curl gamma
-  267   downCast (Direction dir) = C.Direction (downCast dir)
-  268   upCast C.Open            = Open
-  269   upCast (C.Curl gamma)    = Curl gamma
-  270   upCast (C.Direction dir) = Direction (upCast dir)
-  271 
-  272 instance Cast (MetaJoin a) (C.MetaJoin a) where
-  273   downCast (MetaJoin tyL tL tR tyR) = C.MetaJoin (downCast tyL) tL tR (downCast tyR)
-  274   downCast (Controls p1 p2) = C.Controls (downCast p1) (downCast p2)
-  275   upCast (C.MetaJoin tyL tL tR tyR) = MetaJoin (upCast tyL) tL tR (upCast tyR)
-  276   upCast (C.Controls p1 p2)         = Controls (upCast p1) (upCast p2)
-  277 
-  278 instance Cast (PathJoin a) (C.PathJoin a) where
-  279   downCast JoinLine        = C.JoinLine
-  280   downCast (JoinCurve a b) = C.JoinCurve (downCast a) (downCast b)
-  281   upCast C.JoinLine        = JoinLine
-  282   upCast (C.JoinCurve a b) = JoinCurve (upCast a) (upCast b)
-  283 
-  284 instance Cast (OpenMetaPath a) (C.OpenMetaPath a) where
-  285   downCast (OpenMetaPath lst end) = C.OpenMetaPath
-  286     [ (downCast p, downCast j)
-  287     | (p, j) <- lst ] (downCast end)
-  288   upCast (C.OpenMetaPath lst end) = OpenMetaPath
-  289     [ (upCast p, upCast j)
-  290     | (p, j) <- lst ] (upCast end)
-  291 
-  292 instance Cast (ClosedMetaPath a) (C.ClosedMetaPath a) where
-  293   downCast (ClosedMetaPath lst) = C.ClosedMetaPath
-  294     [ (downCast p, downCast j)
-  295     | (p, j) <- lst ]
-  296   upCast (C.ClosedMetaPath lst) = ClosedMetaPath
-  297     [ (upCast p, upCast j)
-  298     | (p, j) <- lst ]
+  258 instance Cast (V2 a) (C.Point a) where
+  259   downCast (V2 a b) = C.Point a b
+  260   upCast (C.Point a b) = V2 a b
+  261 
+  262 instance Cast FillRule C.FillRule where
+  263   downCast FillEvenOdd = C.EvenOdd
+  264   downCast FillNonZero = C.NonZero
+  265   upCast C.EvenOdd = FillEvenOdd
+  266   upCast C.NonZero = FillNonZero
+  267 
+  268 instance Cast (CubicBezier a) (C.CubicBezier a) where
+  269   downCast (CubicBezier a b c d) = C.CubicBezier
+  270     (downCast a) (downCast b) (downCast c) (downCast d)
+  271   upCast (C.CubicBezier a b c d) = CubicBezier
+  272     (upCast a) (upCast b) (upCast c) (upCast d)
+  273 
+  274 instance Cast (QuadBezier a) (C.QuadBezier a) where
+  275   downCast (QuadBezier a b c) = C.QuadBezier
+  276     (downCast a) (downCast b) (downCast c)
+  277   upCast (C.QuadBezier a b c)= QuadBezier
+  278     (upCast a) (upCast b) (upCast c)
+  279 
+  280 instance V.Unbox a => Cast (AnyBezier a) (C.AnyBezier a) where
+  281   downCast (AnyBezier arr) = C.AnyBezier $
+  282     V.map (\(V2 a b) -> (a,b)) arr
+  283   upCast (C.AnyBezier arr) = AnyBezier $
+  284     V.map (\(a, b) -> V2 a b) arr
+  285 
+  286 instance Cast (MetaNodeType a) (C.MetaNodeType a) where
+  287   downCast Open            = C.Open
+  288   downCast (Curl gamma)    = C.Curl gamma
+  289   downCast (Direction dir) = C.Direction (downCast dir)
+  290   upCast C.Open            = Open
+  291   upCast (C.Curl gamma)    = Curl gamma
+  292   upCast (C.Direction dir) = Direction (upCast dir)
+  293 
+  294 instance Cast (Tension a) (C.Tension a) where
+  295   downCast (Tension v)        = C.Tension v
+  296   downCast (TensionAtLeast v) = C.TensionAtLeast v
+  297   upCast (C.Tension v)        = Tension v
+  298   upCast (C.TensionAtLeast v) = TensionAtLeast v
   299 
-  300 instance Cast (OpenPath a) (C.OpenPath a) where
-  301   downCast (OpenPath lst end) = C.OpenPath
-  302     [ (downCast p, downCast j)
-  303     | (p, j) <- lst ] (downCast end)
-  304   upCast (C.OpenPath lst end) = OpenPath
-  305     [ (upCast p, upCast j)
-  306     | (p, j) <- lst ] (upCast end)
+  300 instance Cast (MetaJoin a) (C.MetaJoin a) where
+  301   downCast (MetaJoin tyL tL tR tyR) =
+  302     C.MetaJoin (downCast tyL) (downCast tL) (downCast tR) (downCast tyR)
+  303   downCast (Controls p1 p2) = C.Controls (downCast p1) (downCast p2)
+  304   upCast (C.MetaJoin tyL tL tR tyR) =
+  305     MetaJoin (upCast tyL) (upCast tL) (upCast tR) (upCast tyR)
+  306   upCast (C.Controls p1 p2)         = Controls (upCast p1) (upCast p2)
   307 
-  308 instance Cast (ClosedPath a) (C.ClosedPath a) where
-  309   downCast (ClosedPath lst) = C.ClosedPath
-  310     [ (downCast p, downCast j)
-  311     | (p, j) <- lst ]
-  312   upCast (C.ClosedPath lst) = ClosedPath
-  313     [ (upCast p, upCast j)
-  314     | (p, j) <- lst ]
+  308 instance Cast (PathJoin a) (C.PathJoin a) where
+  309   downCast JoinLine        = C.JoinLine
+  310   downCast (JoinCurve a b) = C.JoinCurve (downCast a) (downCast b)
+  311   upCast C.JoinLine        = JoinLine
+  312   upCast (C.JoinCurve a b) = JoinCurve (upCast a) (upCast b)
+  313 
+  314 instance Cast (OpenMetaPath a) (C.OpenMetaPath a) where
+  315   downCast (OpenMetaPath lst end) = C.OpenMetaPath
+  316     [ (downCast p, downCast j)
+  317     | (p, j) <- lst ] (downCast end)
+  318   upCast (C.OpenMetaPath lst end) = OpenMetaPath
+  319     [ (upCast p, upCast j)
+  320     | (p, j) <- lst ] (upCast end)
+  321 
+  322 instance Cast (ClosedMetaPath a) (C.ClosedMetaPath a) where
+  323   downCast (ClosedMetaPath lst) = C.ClosedMetaPath
+  324     [ (downCast p, downCast j)
+  325     | (p, j) <- lst ]
+  326   upCast (C.ClosedMetaPath lst) = ClosedMetaPath
+  327     [ (upCast p, upCast j)
+  328     | (p, j) <- lst ]
+  329 
+  330 instance Cast (OpenPath a) (C.OpenPath a) where
+  331   downCast (OpenPath lst end) = C.OpenPath
+  332     [ (downCast p, downCast j)
+  333     | (p, j) <- lst ] (downCast end)
+  334   upCast (C.OpenPath lst end) = OpenPath
+  335     [ (upCast p, upCast j)
+  336     | (p, j) <- lst ] (upCast end)
+  337 
+  338 instance Cast (ClosedPath a) (C.ClosedPath a) where
+  339   downCast (ClosedPath lst) = C.ClosedPath
+  340     [ (downCast p, downCast j)
+  341     | (p, j) <- lst ]
+  342   upCast (C.ClosedPath lst) = ClosedPath
+  343     [ (upCast p, upCast j)
+  344     | (p, j) <- lst ]
diff --git a/reanimate-0.4.1.0-inplace/Reanimate.Builtin.Slide.hs.html b/reanimate-0.4.1.0-inplace/Reanimate.Builtin.Slide.hs.html index 682f0f3..9e8a6c2 100644 --- a/reanimate-0.4.1.0-inplace/Reanimate.Builtin.Slide.hs.html +++ b/reanimate-0.4.1.0-inplace/Reanimate.Builtin.Slide.hs.html @@ -39,19 +39,21 @@ span.spaces { background: white } 20 moveRight = constE (translate screenWidth 0) 21 andE a b d t = a d t . b d t 22 - 23 slideDownT :: Transition - 24 slideDownT = effectT slideDown (andE slideDown moveUp) - 25 where - 26 slideDown = translateE 0 (-screenHeight) - 27 moveUp = constE (translate 0 screenHeight) - 28 andE a b d t = a d t . b d t - 29 - 30 slideUpT :: Transition - 31 slideUpT = effectT slideUp (andE slideUp moveDown) - 32 where - 33 slideUp = translateE 0 screenHeight - 34 moveDown = constE (translate 0 (-screenHeight)) - 35 andE a b d t = a d t . b d t + 23 -- | <<docs/gifs/doc_slideDownT.gif>> + 24 slideDownT :: Transition + 25 slideDownT = effectT slideDown (andE slideDown moveUp) + 26 where + 27 slideDown = translateE 0 (-screenHeight) + 28 moveUp = constE (translate 0 screenHeight) + 29 andE a b d t = a d t . b d t + 30 + 31 -- | <<docs/gifs/doc_slideUpT.gif>> + 32 slideUpT :: Transition + 33 slideUpT = effectT slideUp (andE slideUp moveDown) + 34 where + 35 slideUp = translateE 0 screenHeight + 36 moveDown = constE (translate 0 (-screenHeight)) + 37 andE a b d t = a d t . b d t diff --git a/reanimate-0.4.1.0-inplace/Reanimate.PolyShape.hs.html b/reanimate-0.4.1.0-inplace/Reanimate.PolyShape.hs.html index 896354c..8eb0b0d 100644 --- a/reanimate-0.4.1.0-inplace/Reanimate.PolyShape.hs.html +++ b/reanimate-0.4.1.0-inplace/Reanimate.PolyShape.hs.html @@ -333,13 +333,13 @@ span.spaces { background: white } 314 unionPolyShapes :: [PolyShape] -> [PolyShape] 315 unionPolyShapes shapes = 316 map PolyShape $ - 317 union (map unPolyShape shapes) NonZero (polyShapeTolerance/10000) + 317 union (map unPolyShape shapes) FillNonZero (polyShapeTolerance/10000) 318 319 -- | Merge overlapping shapes to within given tolerance. 320 unionPolyShapes' :: Double -> [PolyShape] -> [PolyShape] 321 unionPolyShapes' tol shapes = 322 map PolyShape $ - 323 union (map unPolyShape shapes) NonZero tol + 323 union (map unPolyShape shapes) FillNonZero tol 324 325 -- | True iff lhs is inside of rhs. 326 -- lhs and rhs may not overlap. diff --git a/reanimate-0.4.1.0-inplace/Reanimate.Svg.LineCommand.hs.html b/reanimate-0.4.1.0-inplace/Reanimate.Svg.LineCommand.hs.html index 9676d24..2a51f7c 100644 --- a/reanimate-0.4.1.0-inplace/Reanimate.Svg.LineCommand.hs.html +++ b/reanimate-0.4.1.0-inplace/Reanimate.Svg.LineCommand.hs.html @@ -25,275 +25,277 @@ span.spaces { background: white } 6 Portability : POSIX 7 -} 8 module Reanimate.Svg.LineCommand - 9 ( LineCommand(..) - 10 , lineLength - 11 , toLineCommands - 12 , lineToPath - 13 , lineToPoints - 14 , partialSvg - 15 ) where - 16 - 17 import Control.Lens ((%~), (&), (.~)) - 18 import Control.Monad.Fix - 19 import Control.Monad.State - 20 import Data.Functor - 21 import qualified Data.Vector.Unboxed as V - 22 import qualified Geom2D.CubicBezier.Linear as Bezier - 23 import Graphics.SvgTree hiding (height, line, path, use, width) - 24 import Linear.Metric - 25 import Linear.V2 hiding (angle) - 26 import Linear.Vector - 27 - 28 type CmdM a = State RPoint a - 29 - 30 -- | Simplified version of a PathCommand where all points are absolute. - 31 data LineCommand - 32 = LineMove RPoint - 33 -- | LineDraw RPoint - 34 | LineBezier [RPoint] - 35 | LineEnd RPoint - 36 deriving (Show) - 37 - 38 -- | Convert from line commands to path commands. - 39 lineToPath :: [LineCommand] -> [PathCommand] - 40 lineToPath = map worker - 41 where - 42 worker (LineMove p) = MoveTo OriginAbsolute [p] - 43 -- worker (LineDraw p) = LineTo OriginAbsolute [p] - 44 worker (LineBezier [a,b,c]) = CurveTo OriginAbsolute [(a,b,c)] - 45 worker (LineBezier [a,b]) = QuadraticBezier OriginAbsolute [(a,b)] - 46 worker (LineBezier [a]) = LineTo OriginAbsolute [a] - 47 worker LineBezier{} = error "Reanimate.Svg.lineToPath: invalid bezier curve" - 48 worker LineEnd{} = EndPath - 49 - 50 -- | Using @n@ control points, approximate the path of the curves. - 51 lineToPoints :: Int -> [LineCommand] -> [RPoint] - 52 lineToPoints nPoints cmds = - 53 map lineEnd lineSegments - 54 where - 55 lineSegments = [ partialLine (fromIntegral n/ fromIntegral nPoints) cmds | n <- [0 .. nPoints-1] ] - 56 lineEnd [LineBezier pts] = last pts - 57 lineEnd (_:xs) = lineEnd xs - 58 lineEnd _ = error "invalid line" - 59 - 60 partialLine :: Double -> [LineCommand] -> [LineCommand] - 61 partialLine alpha cmds = evalState (worker 0 cmds) zero - 62 where - 63 worker _d [] = pure [] - 64 worker d (cmd:xs) = do - 65 from <- get - 66 len <- lineLength cmd - 67 let frac = (targetLen-d) / len - 68 if len == 0 || frac >= 1 - 69 then (cmd:) <$> worker (d+len) xs - 70 else pure [adjustLineLength frac from cmd] - 71 totalLen = evalState (sum <$> mapM lineLength cmds) zero - 72 targetLen = totalLen * alpha - 73 - 74 adjustLineLength :: Double -> RPoint -> LineCommand -> LineCommand - 75 adjustLineLength alpha from cmd = - 76 case cmd of - 77 LineBezier points -> LineBezier $ drop 1 $ partialBezierPoints (from:points) 0 alpha - 78 LineMove p -> LineMove p - 79 -- LineDraw t -> LineDraw (lerp alpha t from) - 80 LineEnd p -> LineBezier [lerp alpha p from] - 81 - 82 -- | Estimated length of all segments in a line. - 83 lineLength :: LineCommand -> CmdM Double - 84 lineLength cmd = - 85 case cmd of - 86 LineMove to -> 0 <$ put to - 87 -- Straight line: - 88 LineBezier [dst] -> gets (distance dst) <* put dst - 89 -- Some kind of curve: - 90 LineBezier lst -> do - 91 from <- get - 92 let bezier = rpointsToBezier (from:lst) - 93 tol = 0.0001 - 94 put (last lst) - 95 pure $ Bezier.arcLength bezier 1 tol - 96 LineEnd to -> gets (distance to) <* put to - 97 - 98 rpointsToBezier :: [RPoint] -> Bezier.CubicBezier Double - 99 rpointsToBezier lst = - 100 case lst of - 101 [a,b] -> Bezier.CubicBezier a a b b - 102 [a,b,c] -> Bezier.quadToCubic (Bezier.QuadBezier a b c) - 103 [a,b,c,d] -> Bezier.CubicBezier a b c d - 104 _ -> error $ "rpointsToBezier: Invalid list of points: " ++ show lst - 105 - 106 -- | Convert from path commands to line commands. - 107 toLineCommands :: [PathCommand] -> [LineCommand] - 108 toLineCommands ps = evalState (worker zero Nothing ps) zero - 109 where - 110 worker _startPos _mbPrevControlPt [] = pure [] - 111 worker startPos mbPrevControlPt (cmd:cmds) = do - 112 lcmds <- toLineCommand startPos mbPrevControlPt cmd - 113 let startPos' = - 114 case lcmds of - 115 [LineMove pos] -> pos - 116 _ -> startPos - 117 (lcmds++) <$> worker startPos' (cmdToControlPoint $ last lcmds) cmds - 118 - 119 cmdToControlPoint :: LineCommand -> Maybe RPoint - 120 cmdToControlPoint (LineBezier points) = Just (last (init points)) - 121 cmdToControlPoint _ = Nothing - 122 - 123 mkStraightLine :: RPoint -> LineCommand - 124 mkStraightLine p = LineBezier [p] - 125 - 126 toLineCommand :: RPoint -> Maybe RPoint -> PathCommand -> CmdM [LineCommand] - 127 toLineCommand startPos mbPrevControlPt cmd = - 128 case cmd of - 129 MoveTo OriginAbsolute [] -> pure [] - 130 MoveTo OriginAbsolute lst -> put (last lst) *> gets (pure.LineMove) - 131 MoveTo OriginRelative lst -> modify (+ sum lst) *> gets (pure.LineMove) - 132 LineTo OriginAbsolute lst -> forM lst (\to -> put to $> mkStraightLine to) - 133 LineTo OriginRelative lst -> forM lst (\to -> modify (+to) *> gets mkStraightLine) - 134 HorizontalTo OriginAbsolute lst -> - 135 forM lst $ \x -> modify (_x .~ x) *> gets mkStraightLine - 136 HorizontalTo OriginRelative lst -> - 137 forM lst $ \x -> modify (_x %~ (+x)) *> gets mkStraightLine - 138 VerticalTo OriginAbsolute lst -> - 139 forM lst $ \y -> modify (_y .~ y) *> gets mkStraightLine - 140 VerticalTo OriginRelative lst -> - 141 forM lst $ \y -> modify (_y %~ (+y)) *> gets mkStraightLine - 142 CurveTo OriginAbsolute quads -> - 143 forM quads $ \(a,b,c) -> put c $> LineBezier [a,b,c] - 144 CurveTo OriginRelative quads -> - 145 forM quads $ \(a,b,c) -> do - 146 from <- get <* modify (+c) - 147 pure $ LineBezier $ map (+from) [a,b,c] - 148 SmoothCurveTo o lst -> mfix $ \result -> do - 149 let ctrl = mbPrevControlPt : map cmdToControlPoint result - 150 forM (zip lst ctrl) $ \((c2,to), mbControl) -> do - 151 from <- get <* adjustPosition o to - 152 let c1 = maybe (makeAbsolute o from c2) (mirrorPoint from) mbControl - 153 pure $ LineBezier [c1,makeAbsolute o from c2,makeAbsolute o from to] - 154 QuadraticBezier OriginAbsolute pairs -> - 155 forM pairs $ \(a,b) -> put b $> LineBezier [a,b] - 156 QuadraticBezier OriginRelative pairs -> - 157 forM pairs $ \(a,b) -> do - 158 from <- get <* modify (+b) - 159 pure $ LineBezier $ map (+from) [a,b] - 160 SmoothQuadraticBezierCurveTo o lst -> mfix $ \result -> do - 161 let ctrl = mbPrevControlPt : map cmdToControlPoint result - 162 forM (zip lst ctrl) $ \(to, mbControl) -> do - 163 from <- get <* adjustPosition o to - 164 let c1 = maybe from (mirrorPoint from) mbControl - 165 pure $ LineBezier [c1,makeAbsolute o from to] - 166 EllipticalArc o points -> concat <$> - 167 forM points (\(rotX, rotY, angle, largeArc, sweepFlag, to) -> do - 168 from <- get <* adjustPosition o to - 169 return $ convertSvgArc from rotX rotY angle largeArc sweepFlag (makeAbsolute o from to)) - 170 EndPath -> put startPos $> [LineEnd startPos] - 171 where - 172 mirrorPoint c p = c*2-p - 173 adjustPosition OriginRelative p = modify (+p) - 174 adjustPosition OriginAbsolute p = put p - 175 makeAbsolute OriginAbsolute _from p = p - 176 makeAbsolute OriginRelative from p = from+p - 177 - 178 - 179 calculateVectorAngle :: Double -> Double -> Double -> Double -> Double - 180 calculateVectorAngle ux uy vx vy - 181 | tb >= ta - 182 = tb - ta - 183 | otherwise - 184 = pi * 2 - (ta - tb) - 185 where - 186 ta = atan2 uy ux - 187 tb = atan2 vy vx - 188 - 189 -- ported from: https://github.com/vvvv/SVG/blob/master/Source/Paths/SvgArcSegment.cs - 190 {- HLINT ignore convertSvgArc -} - 191 convertSvgArc :: RPoint -> Coord -> Coord -> Coord -> Bool -> Bool -> RPoint -> [LineCommand] - 192 convertSvgArc (V2 x0 y0) radiusX radiusY angle largeArcFlag sweepFlag (V2 x y) - 193 | x0 == x && y0 == y - 194 = [] - 195 | radiusX == 0.0 && radiusY == 0.0 - 196 = [LineBezier [V2 x y]] - 197 | otherwise - 198 = calcSegments x0 y0 theta1' segments' - 199 where - 200 sinPhi = sin (angle * pi/180) - 201 cosPhi = cos (angle * pi/180) - 202 - 203 x1dash = cosPhi * (x0 - x) / 2.0 + sinPhi * (y0 - y) / 2.0 - 204 y1dash = -sinPhi * (x0 - x) / 2.0 + cosPhi * (y0 - y) / 2.0 - 205 - 206 numerator = radiusX * radiusX * radiusY * radiusY - radiusX * radiusX * y1dash * y1dash - radiusY * radiusY * x1dash * x1dash + 9 ( CmdM + 10 , LineCommand(..) + 11 , lineLength + 12 , toLineCommands + 13 , lineToPath + 14 , lineToPoints + 15 , partialSvg + 16 ) where + 17 + 18 import Control.Lens ((%~), (&), (.~)) + 19 import Control.Monad.Fix + 20 import Control.Monad.State + 21 import Data.Functor + 22 import qualified Data.Vector.Unboxed as V + 23 import qualified Geom2D.CubicBezier.Linear as Bezier + 24 import Graphics.SvgTree hiding (height, line, path, use, width) + 25 import Linear.Metric + 26 import Linear.V2 hiding (angle) + 27 import Linear.Vector + 28 + 29 -- | Line command monad used for keeping track of the current location. + 30 type CmdM a = State RPoint a + 31 + 32 -- | Simplified version of a PathCommand where all points are absolute. + 33 data LineCommand + 34 = LineMove RPoint + 35 -- | LineDraw RPoint + 36 | LineBezier [RPoint] + 37 | LineEnd RPoint + 38 deriving (Show) + 39 + 40 -- | Convert from line commands to path commands. + 41 lineToPath :: [LineCommand] -> [PathCommand] + 42 lineToPath = map worker + 43 where + 44 worker (LineMove p) = MoveTo OriginAbsolute [p] + 45 -- worker (LineDraw p) = LineTo OriginAbsolute [p] + 46 worker (LineBezier [a,b,c]) = CurveTo OriginAbsolute [(a,b,c)] + 47 worker (LineBezier [a,b]) = QuadraticBezier OriginAbsolute [(a,b)] + 48 worker (LineBezier [a]) = LineTo OriginAbsolute [a] + 49 worker LineBezier{} = error "Reanimate.Svg.lineToPath: invalid bezier curve" + 50 worker LineEnd{} = EndPath + 51 + 52 -- | Using @n@ control points, approximate the path of the curves. + 53 lineToPoints :: Int -> [LineCommand] -> [RPoint] + 54 lineToPoints nPoints cmds = + 55 map lineEnd lineSegments + 56 where + 57 lineSegments = [ partialLine (fromIntegral n/ fromIntegral nPoints) cmds | n <- [0 .. nPoints-1] ] + 58 lineEnd [LineBezier pts] = last pts + 59 lineEnd (_:xs) = lineEnd xs + 60 lineEnd _ = error "invalid line" + 61 + 62 partialLine :: Double -> [LineCommand] -> [LineCommand] + 63 partialLine alpha cmds = evalState (worker 0 cmds) zero + 64 where + 65 worker _d [] = pure [] + 66 worker d (cmd:xs) = do + 67 from <- get + 68 len <- lineLength cmd + 69 let frac = (targetLen-d) / len + 70 if len == 0 || frac >= 1 + 71 then (cmd:) <$> worker (d+len) xs + 72 else pure [adjustLineLength frac from cmd] + 73 totalLen = evalState (sum <$> mapM lineLength cmds) zero + 74 targetLen = totalLen * alpha + 75 + 76 adjustLineLength :: Double -> RPoint -> LineCommand -> LineCommand + 77 adjustLineLength alpha from cmd = + 78 case cmd of + 79 LineBezier points -> LineBezier $ drop 1 $ partialBezierPoints (from:points) 0 alpha + 80 LineMove p -> LineMove p + 81 -- LineDraw t -> LineDraw (lerp alpha t from) + 82 LineEnd p -> LineBezier [lerp alpha p from] + 83 + 84 -- | Estimated length of all segments in a line. + 85 lineLength :: LineCommand -> CmdM Double + 86 lineLength cmd = + 87 case cmd of + 88 LineMove to -> 0 <$ put to + 89 -- Straight line: + 90 LineBezier [dst] -> gets (distance dst) <* put dst + 91 -- Some kind of curve: + 92 LineBezier lst -> do + 93 from <- get + 94 let bezier = rpointsToBezier (from:lst) + 95 tol = 0.0001 + 96 put (last lst) + 97 pure $ Bezier.arcLength bezier 1 tol + 98 LineEnd to -> gets (distance to) <* put to + 99 + 100 rpointsToBezier :: [RPoint] -> Bezier.CubicBezier Double + 101 rpointsToBezier lst = + 102 case lst of + 103 [a,b] -> Bezier.CubicBezier a a b b + 104 [a,b,c] -> Bezier.quadToCubic (Bezier.QuadBezier a b c) + 105 [a,b,c,d] -> Bezier.CubicBezier a b c d + 106 _ -> error $ "rpointsToBezier: Invalid list of points: " ++ show lst + 107 + 108 -- | Convert from path commands to line commands. + 109 toLineCommands :: [PathCommand] -> [LineCommand] + 110 toLineCommands ps = evalState (worker zero Nothing ps) zero + 111 where + 112 worker _startPos _mbPrevControlPt [] = pure [] + 113 worker startPos mbPrevControlPt (cmd:cmds) = do + 114 lcmds <- toLineCommand startPos mbPrevControlPt cmd + 115 let startPos' = + 116 case lcmds of + 117 [LineMove pos] -> pos + 118 _ -> startPos + 119 (lcmds++) <$> worker startPos' (cmdToControlPoint $ last lcmds) cmds + 120 + 121 cmdToControlPoint :: LineCommand -> Maybe RPoint + 122 cmdToControlPoint (LineBezier points) = Just (last (init points)) + 123 cmdToControlPoint _ = Nothing + 124 + 125 mkStraightLine :: RPoint -> LineCommand + 126 mkStraightLine p = LineBezier [p] + 127 + 128 toLineCommand :: RPoint -> Maybe RPoint -> PathCommand -> CmdM [LineCommand] + 129 toLineCommand startPos mbPrevControlPt cmd = + 130 case cmd of + 131 MoveTo OriginAbsolute [] -> pure [] + 132 MoveTo OriginAbsolute lst -> put (last lst) *> gets (pure.LineMove) + 133 MoveTo OriginRelative lst -> modify (+ sum lst) *> gets (pure.LineMove) + 134 LineTo OriginAbsolute lst -> forM lst (\to -> put to $> mkStraightLine to) + 135 LineTo OriginRelative lst -> forM lst (\to -> modify (+to) *> gets mkStraightLine) + 136 HorizontalTo OriginAbsolute lst -> + 137 forM lst $ \x -> modify (_x .~ x) *> gets mkStraightLine + 138 HorizontalTo OriginRelative lst -> + 139 forM lst $ \x -> modify (_x %~ (+x)) *> gets mkStraightLine + 140 VerticalTo OriginAbsolute lst -> + 141 forM lst $ \y -> modify (_y .~ y) *> gets mkStraightLine + 142 VerticalTo OriginRelative lst -> + 143 forM lst $ \y -> modify (_y %~ (+y)) *> gets mkStraightLine + 144 CurveTo OriginAbsolute quads -> + 145 forM quads $ \(a,b,c) -> put c $> LineBezier [a,b,c] + 146 CurveTo OriginRelative quads -> + 147 forM quads $ \(a,b,c) -> do + 148 from <- get <* modify (+c) + 149 pure $ LineBezier $ map (+from) [a,b,c] + 150 SmoothCurveTo o lst -> mfix $ \result -> do + 151 let ctrl = mbPrevControlPt : map cmdToControlPoint result + 152 forM (zip lst ctrl) $ \((c2,to), mbControl) -> do + 153 from <- get <* adjustPosition o to + 154 let c1 = maybe (makeAbsolute o from c2) (mirrorPoint from) mbControl + 155 pure $ LineBezier [c1,makeAbsolute o from c2,makeAbsolute o from to] + 156 QuadraticBezier OriginAbsolute pairs -> + 157 forM pairs $ \(a,b) -> put b $> LineBezier [a,b] + 158 QuadraticBezier OriginRelative pairs -> + 159 forM pairs $ \(a,b) -> do + 160 from <- get <* modify (+b) + 161 pure $ LineBezier $ map (+from) [a,b] + 162 SmoothQuadraticBezierCurveTo o lst -> mfix $ \result -> do + 163 let ctrl = mbPrevControlPt : map cmdToControlPoint result + 164 forM (zip lst ctrl) $ \(to, mbControl) -> do + 165 from <- get <* adjustPosition o to + 166 let c1 = maybe from (mirrorPoint from) mbControl + 167 pure $ LineBezier [c1,makeAbsolute o from to] + 168 EllipticalArc o points -> concat <$> + 169 forM points (\(rotX, rotY, angle, largeArc, sweepFlag, to) -> do + 170 from <- get <* adjustPosition o to + 171 return $ convertSvgArc from rotX rotY angle largeArc sweepFlag (makeAbsolute o from to)) + 172 EndPath -> put startPos $> [LineEnd startPos] + 173 where + 174 mirrorPoint c p = c*2-p + 175 adjustPosition OriginRelative p = modify (+p) + 176 adjustPosition OriginAbsolute p = put p + 177 makeAbsolute OriginAbsolute _from p = p + 178 makeAbsolute OriginRelative from p = from+p + 179 + 180 + 181 calculateVectorAngle :: Double -> Double -> Double -> Double -> Double + 182 calculateVectorAngle ux uy vx vy + 183 | tb >= ta + 184 = tb - ta + 185 | otherwise + 186 = pi * 2 - (ta - tb) + 187 where + 188 ta = atan2 uy ux + 189 tb = atan2 vy vx + 190 + 191 -- ported from: https://github.com/vvvv/SVG/blob/master/Source/Paths/SvgArcSegment.cs + 192 {- HLINT ignore convertSvgArc -} + 193 convertSvgArc :: RPoint -> Coord -> Coord -> Coord -> Bool -> Bool -> RPoint -> [LineCommand] + 194 convertSvgArc (V2 x0 y0) radiusX radiusY angle largeArcFlag sweepFlag (V2 x y) + 195 | x0 == x && y0 == y + 196 = [] + 197 | radiusX == 0.0 && radiusY == 0.0 + 198 = [LineBezier [V2 x y]] + 199 | otherwise + 200 = calcSegments x0 y0 theta1' segments' + 201 where + 202 sinPhi = sin (angle * pi/180) + 203 cosPhi = cos (angle * pi/180) + 204 + 205 x1dash = cosPhi * (x0 - x) / 2.0 + sinPhi * (y0 - y) / 2.0 + 206 y1dash = -sinPhi * (x0 - x) / 2.0 + cosPhi * (y0 - y) / 2.0 207 - 208 s = sqrt(1.0 - numerator / (radiusX * radiusX * radiusY * radiusY)) - 209 rx = if (numerator < 0.0) then (radiusX * s) else radiusX - 210 ry = if (numerator < 0.0) then (radiusY * s) else radiusY - 211 root = if (numerator < 0.0) - 212 then (0.0) - 213 else ((if ((largeArcFlag && sweepFlag) || (not largeArcFlag && not sweepFlag)) then (-1.0) else 1.0) * - 214 sqrt(numerator / (radiusX * radiusX * y1dash * y1dash + radiusY * radiusY * x1dash * x1dash))) - 215 - 216 cxdash = root * rx * y1dash / ry - 217 cydash = -root * ry * x1dash / rx - 218 - 219 cx = cosPhi * cxdash - sinPhi * cydash + (x0 + x) / 2.0 - 220 cy = sinPhi * cxdash + cosPhi * cydash + (y0 + y) / 2.0 - 221 - 222 theta1' = calculateVectorAngle 1.0 0.0 ((x1dash - cxdash) / rx) ((y1dash - cydash) / ry) - 223 dtheta' = calculateVectorAngle ((x1dash - cxdash) / rx) ((y1dash - cydash) / ry) ((-x1dash - cxdash) / rx) ((-y1dash - cydash) / ry) - 224 dtheta = if (not sweepFlag && dtheta' > 0) - 225 then (dtheta' - 2 * pi) - 226 else (if (sweepFlag && dtheta' < 0) then dtheta' + 2 * pi else dtheta') - 227 - 228 segments' = ceiling (abs (dtheta / (pi / 2.0))) - 229 delta = dtheta / fromInteger segments' - 230 t = 8.0 / 3.0 * sin(delta / 4.0) * sin(delta / 4.0) / sin(delta / 2.0) - 231 - 232 calcSegments startX startY theta1 segments - 233 | segments == 0 - 234 = [] - 235 | otherwise - 236 = LineBezier [ V2 (startX + dx1) (startY + dy1) - 237 , V2 (endpointX + dxe) (endpointY + dye) - 238 , V2 endpointX endpointY ] : calcSegments endpointX endpointY theta2 (segments - 1) - 239 where - 240 cosTheta1 = cos theta1 - 241 sinTheta1 = sin theta1 - 242 theta2 = theta1 + delta - 243 cosTheta2 = cos theta2 - 244 sinTheta2 = sin theta2 - 245 - 246 endpointX = cosPhi * rx * cosTheta2 - sinPhi * ry * sinTheta2 + cx - 247 endpointY = sinPhi * rx * cosTheta2 + cosPhi * ry * sinTheta2 + cy - 248 - 249 dx1 = t * (-cosPhi * rx * sinTheta1 - sinPhi * ry * cosTheta1) - 250 dy1 = t * (-sinPhi * rx * sinTheta1 + cosPhi * ry * cosTheta1) - 251 - 252 dxe = t * (cosPhi * rx * sinTheta2 + sinPhi * ry * cosTheta2) - 253 dye = t * (sinPhi * rx * sinTheta2 - cosPhi * ry * cosTheta2) - 254 - 255 partialBezierPoints :: [RPoint] -> Double -> Double -> [RPoint] - 256 partialBezierPoints ps a b = - 257 let c1 = Bezier.AnyBezier (V.fromList ps) - 258 Bezier.AnyBezier os = Bezier.bezierSubsegment c1 a b - 259 in V.toList os - 260 - 261 {- | Create an image showing portion of a path. - 262 Note that this only affects paths (see 'Reanimate.Svg.Constructors.mkPath'). - 263 You can also use this with other SVG shapes if you convert them to path first (see 'Reanimate.Svg.pathify'). - 264 - 265 Typical usage: + 208 numerator = radiusX * radiusX * radiusY * radiusY - radiusX * radiusX * y1dash * y1dash - radiusY * radiusY * x1dash * x1dash + 209 + 210 s = sqrt(1.0 - numerator / (radiusX * radiusX * radiusY * radiusY)) + 211 rx = if (numerator < 0.0) then (radiusX * s) else radiusX + 212 ry = if (numerator < 0.0) then (radiusY * s) else radiusY + 213 root = if (numerator < 0.0) + 214 then (0.0) + 215 else ((if ((largeArcFlag && sweepFlag) || (not largeArcFlag && not sweepFlag)) then (-1.0) else 1.0) * + 216 sqrt(numerator / (radiusX * radiusX * y1dash * y1dash + radiusY * radiusY * x1dash * x1dash))) + 217 + 218 cxdash = root * rx * y1dash / ry + 219 cydash = -root * ry * x1dash / rx + 220 + 221 cx = cosPhi * cxdash - sinPhi * cydash + (x0 + x) / 2.0 + 222 cy = sinPhi * cxdash + cosPhi * cydash + (y0 + y) / 2.0 + 223 + 224 theta1' = calculateVectorAngle 1.0 0.0 ((x1dash - cxdash) / rx) ((y1dash - cydash) / ry) + 225 dtheta' = calculateVectorAngle ((x1dash - cxdash) / rx) ((y1dash - cydash) / ry) ((-x1dash - cxdash) / rx) ((-y1dash - cydash) / ry) + 226 dtheta = if (not sweepFlag && dtheta' > 0) + 227 then (dtheta' - 2 * pi) + 228 else (if (sweepFlag && dtheta' < 0) then dtheta' + 2 * pi else dtheta') + 229 + 230 segments' = ceiling (abs (dtheta / (pi / 2.0))) + 231 delta = dtheta / fromInteger segments' + 232 t = 8.0 / 3.0 * sin(delta / 4.0) * sin(delta / 4.0) / sin(delta / 2.0) + 233 + 234 calcSegments startX startY theta1 segments + 235 | segments == 0 + 236 = [] + 237 | otherwise + 238 = LineBezier [ V2 (startX + dx1) (startY + dy1) + 239 , V2 (endpointX + dxe) (endpointY + dye) + 240 , V2 endpointX endpointY ] : calcSegments endpointX endpointY theta2 (segments - 1) + 241 where + 242 cosTheta1 = cos theta1 + 243 sinTheta1 = sin theta1 + 244 theta2 = theta1 + delta + 245 cosTheta2 = cos theta2 + 246 sinTheta2 = sin theta2 + 247 + 248 endpointX = cosPhi * rx * cosTheta2 - sinPhi * ry * sinTheta2 + cx + 249 endpointY = sinPhi * rx * cosTheta2 + cosPhi * ry * sinTheta2 + cy + 250 + 251 dx1 = t * (-cosPhi * rx * sinTheta1 - sinPhi * ry * cosTheta1) + 252 dy1 = t * (-sinPhi * rx * sinTheta1 + cosPhi * ry * cosTheta1) + 253 + 254 dxe = t * (cosPhi * rx * sinTheta2 + sinPhi * ry * cosTheta2) + 255 dye = t * (sinPhi * rx * sinTheta2 - cosPhi * ry * cosTheta2) + 256 + 257 partialBezierPoints :: [RPoint] -> Double -> Double -> [RPoint] + 258 partialBezierPoints ps a b = + 259 let c1 = Bezier.AnyBezier (V.fromList ps) + 260 Bezier.AnyBezier os = Bezier.bezierSubsegment c1 a b + 261 in V.toList os + 262 + 263 {- | Create an image showing portion of a path. + 264 Note that this only affects paths (see 'Reanimate.Svg.Constructors.mkPath'). + 265 You can also use this with other SVG shapes if you convert them to path first (see 'Reanimate.Svg.pathify'). 266 - 267 > animate $ \t -> partialSvg t myPath - 268 -} - 269 partialSvg :: Double -- ^ number between 0 and 1 inclusively, determining what portion of the path to show - 270 -> Tree -- ^ Image representing a path, of which we only want to display a portion determined by the first argument - 271 -> Tree - 272 partialSvg alpha | alpha >= 1 = id - 273 partialSvg alpha = mapTree worker - 274 where - 275 worker (PathTree path) = - 276 PathTree $ path & pathDefinition %~ lineToPath . partialLine alpha . toLineCommands - 277 worker t = t + 267 Typical usage: + 268 + 269 > animate $ \t -> partialSvg t myPath + 270 -} + 271 partialSvg :: Double -- ^ number between 0 and 1 inclusively, determining what portion of the path to show + 272 -> Tree -- ^ Image representing a path, of which we only want to display a portion determined by the first argument + 273 -> Tree + 274 partialSvg alpha | alpha >= 1 = id + 275 partialSvg alpha = mapTree worker + 276 where + 277 worker (PathTree path) = + 278 PathTree $ path & pathDefinition %~ lineToPath . partialLine alpha . toLineCommands + 279 worker t = t diff --git a/reanimate-0.4.1.0-inplace/Reanimate.Svg.hs.html b/reanimate-0.4.1.0-inplace/Reanimate.Svg.hs.html index bc8ad65..ee69f97 100644 --- a/reanimate-0.4.1.0-inplace/Reanimate.Svg.hs.html +++ b/reanimate-0.4.1.0-inplace/Reanimate.Svg.hs.html @@ -159,199 +159,212 @@ span.spaces { background: white } 140 worker (PathTree p) = p^.pathDefinition 141 worker _ = [] 142 - 143 withSubglyphs :: [Int] -> (Tree -> Tree) -> Tree -> Tree - 144 withSubglyphs target fn = \t -> evalState (worker t) 0 - 145 where - 146 worker :: Tree -> State Int Tree - 147 worker t = - 148 case t of - 149 GroupTree g -> do - 150 cs <- mapM worker (g ^. groupChildren) - 151 return $ GroupTree $ g & groupChildren .~ cs - 152 PathTree{} -> handleGlyph t - 153 CircleTree{} -> handleGlyph t - 154 PolyLineTree{} -> handleGlyph t - 155 PolygonTree{} -> handleGlyph t - 156 EllipseTree{} -> handleGlyph t - 157 LineTree{} -> handleGlyph t - 158 RectangleTree{} -> handleGlyph t - 159 _ -> return t - 160 handleGlyph :: Tree -> State Int Tree - 161 handleGlyph svg = do - 162 n <- get <* modify (+1) - 163 if n `elem` target - 164 then return $ fn svg - 165 else return svg - 166 - 167 splitGlyphs :: [Int] -> Tree -> (Tree, Tree) - 168 splitGlyphs target = \t -> - 169 let (_, l, r) = execState (worker id t) (0, [], []) - 170 in (mkGroup l, mkGroup r) - 171 where - 172 handleGlyph :: Tree -> State (Int, [Tree], [Tree]) () - 173 handleGlyph t = do - 174 (n, l, r) <- get - 175 if n `elem` target - 176 then put (n+1, l, t:r) - 177 else put (n+1, t:l, r) - 178 worker :: (Tree -> Tree) -> Tree -> State (Int, [Tree], [Tree]) () - 179 worker acc t = - 180 case t of - 181 GroupTree g -> do - 182 let acc' sub = acc (GroupTree $ g & groupChildren .~ [sub]) - 183 mapM_ (worker acc') (g ^. groupChildren) - 184 PathTree{} -> handleGlyph $ acc t - 185 CircleTree{} -> handleGlyph $ acc t - 186 PolyLineTree{} -> handleGlyph $ acc t - 187 PolygonTree{} -> handleGlyph $ acc t - 188 EllipseTree{} -> handleGlyph $ acc t - 189 LineTree{} -> handleGlyph $ acc t - 190 RectangleTree{} -> handleGlyph $ acc t - 191 DefinitionTree{} -> return () - 192 _ -> - 193 modify $ \(n, l, r) -> (n, acc t:l, r) - 194 {- - 195 <g transform="translate(10,10)"> - 196 <g transform="scale(2)"> - 197 <circle/> - 198 </g> - 199 <g transform="scale(0.5)"> - 200 <rect/> - 201 </g> - 202 </g> - 203 - 204 [ (\svg -> <g transform="translate(10,10)"><g transform="scale(2)">svg</g></g>, <circle/>) - 205 , (\svg -> <g transform="translate(10,10)"><g transform="scale(0.5)">svg</g></g>, <rect/>)] - 206 -} - 207 svgGlyphs :: Tree -> [(Tree -> Tree, DrawAttributes, Tree)] - 208 svgGlyphs = worker id defaultSvg - 209 where - 210 worker acc attr = - 211 \case - 212 None -> [] - 213 GroupTree g -> - 214 let acc' sub = acc (GroupTree $ g & groupChildren .~ [sub]) - 215 attr' = (g^.drawAttributes) `mappend` attr - 216 in concatMap (worker acc' attr') (g ^. groupChildren) - 217 t -> [(acc, (t^.drawAttributes) `mappend` attr, t)] - 218 - 219 {-| Convert primitive SVG shapes (like those created by 'mkCircle', 'mkRect', 'mkLine' or - 220 'mkEllipse') into SVG path. This can be useful for creating animations of these shapes being - 221 drawn progressively with 'partialSvg'. - 222 - 223 Example: - 224 - 225 > pathifyExample :: Animation - 226 > pathifyExample = animate $ \t -> gridLayout - 227 > [ [ partialSvg t $ pathify $ mkCircle 1 - 228 > , partialSvg t $ pathify $ mkRect 2 2 - 229 > ] - 230 > , [ partialSvg t $ pathify $ mkEllipse 1 0.5 - 231 > , partialSvg t $ pathify $ mkLine (-1, -1) (1, 1) - 232 > ] - 233 > ] - 234 - 235 <<docs/gifs/doc_pathify.gif>> - 236 -} - 237 pathify :: Tree -> Tree - 238 pathify = mapTree worker - 239 where - 240 worker = - 241 \case - 242 RectangleTree rect | Just (x,y,w,h) <- unpackRect rect -> - 243 PathTree $ defaultSvg - 244 & drawAttributes .~ rect ^. drawAttributes - 245 & strokeLineCap .~ pure CapSquare - 246 & pathDefinition .~ - 247 [MoveTo OriginAbsolute [V2 x y] - 248 ,HorizontalTo OriginRelative [w] - 249 ,VerticalTo OriginRelative [h] - 250 ,HorizontalTo OriginRelative [-w] - 251 ,EndPath ] - 252 LineTree line | Just (x1,y1, x2, y2) <- unpackLine line -> - 253 PathTree $ defaultSvg - 254 & drawAttributes .~ line ^. drawAttributes + 143 -- | Map over indexed symbols. + 144 -- + 145 -- @withSubglyphs [0,2] (scale 2) (mkGroup [mkCircle 1, mkRect 2, mkEllipse 1 2]) + 146 -- = mkGroup [scale 2 (mkCircle 1), mkRect 2, scale 2 (mkEllipse 1 2)]@ + 147 withSubglyphs :: [Int] -> (Tree -> Tree) -> Tree -> Tree + 148 withSubglyphs target fn = \t -> evalState (worker t) 0 + 149 where + 150 worker :: Tree -> State Int Tree + 151 worker t = + 152 case t of + 153 GroupTree g -> do + 154 cs <- mapM worker (g ^. groupChildren) + 155 return $ GroupTree $ g & groupChildren .~ cs + 156 PathTree{} -> handleGlyph t + 157 CircleTree{} -> handleGlyph t + 158 PolyLineTree{} -> handleGlyph t + 159 PolygonTree{} -> handleGlyph t + 160 EllipseTree{} -> handleGlyph t + 161 LineTree{} -> handleGlyph t + 162 RectangleTree{} -> handleGlyph t + 163 _ -> return t + 164 handleGlyph :: Tree -> State Int Tree + 165 handleGlyph svg = do + 166 n <- get <* modify (+1) + 167 if n `elem` target + 168 then return $ fn svg + 169 else return svg + 170 + 171 -- | Split symbols. + 172 -- + 173 -- @splitGlyphs [0,2] (mkGroup [mkCircle 1, mkRect 2, mkEllipse 1 2]) + 174 -- = ([mkRect 2], [mkCircle 1, mkEllipse 1 2])@ + 175 splitGlyphs :: [Int] -> Tree -> (Tree, Tree) + 176 splitGlyphs target = \t -> + 177 let (_, l, r) = execState (worker id t) (0, [], []) + 178 in (mkGroup l, mkGroup r) + 179 where + 180 handleGlyph :: Tree -> State (Int, [Tree], [Tree]) () + 181 handleGlyph t = do + 182 (n, l, r) <- get + 183 if n `elem` target + 184 then put (n+1, l, t:r) + 185 else put (n+1, t:l, r) + 186 worker :: (Tree -> Tree) -> Tree -> State (Int, [Tree], [Tree]) () + 187 worker acc t = + 188 case t of + 189 GroupTree g -> do + 190 let acc' sub = acc (GroupTree $ g & groupChildren .~ [sub]) + 191 mapM_ (worker acc') (g ^. groupChildren) + 192 PathTree{} -> handleGlyph $ acc t + 193 CircleTree{} -> handleGlyph $ acc t + 194 PolyLineTree{} -> handleGlyph $ acc t + 195 PolygonTree{} -> handleGlyph $ acc t + 196 EllipseTree{} -> handleGlyph $ acc t + 197 LineTree{} -> handleGlyph $ acc t + 198 RectangleTree{} -> handleGlyph $ acc t + 199 DefinitionTree{} -> return () + 200 _ -> + 201 modify $ \(n, l, r) -> (n, acc t:l, r) + 202 {- + 203 <g transform="translate(10,10)"> + 204 <g transform="scale(2)"> + 205 <circle/> + 206 </g> + 207 <g transform="scale(0.5)"> + 208 <rect/> + 209 </g> + 210 </g> + 211 + 212 [ (\svg -> <g transform="translate(10,10)"><g transform="scale(2)">svg</g></g>, <circle/>) + 213 , (\svg -> <g transform="translate(10,10)"><g transform="scale(0.5)">svg</g></g>, <rect/>)] + 214 -} + 215 -- | Split symbols and include their context and drawing attributes. + 216 svgGlyphs :: Tree -> [(Tree -> Tree, DrawAttributes, Tree)] + 217 svgGlyphs = worker id defaultSvg + 218 where + 219 worker acc attr = + 220 \case + 221 None -> [] + 222 GroupTree g -> + 223 let acc' sub = acc (GroupTree $ g & groupChildren .~ [sub]) + 224 attr' = (g^.drawAttributes) `mappend` attr + 225 in concatMap (worker acc' attr') (g ^. groupChildren) + 226 t -> [(acc, (t^.drawAttributes) `mappend` attr, t)] + 227 + 228 {-| Convert primitive SVG shapes (like those created by 'mkCircle', 'mkRect', 'mkLine' or + 229 'mkEllipse') into SVG path. This can be useful for creating animations of these shapes being + 230 drawn progressively with 'partialSvg'. + 231 + 232 Example: + 233 + 234 > pathifyExample :: Animation + 235 > pathifyExample = animate $ \t -> gridLayout + 236 > [ [ partialSvg t $ pathify $ mkCircle 1 + 237 > , partialSvg t $ pathify $ mkRect 2 2 + 238 > ] + 239 > , [ partialSvg t $ pathify $ mkEllipse 1 0.5 + 240 > , partialSvg t $ pathify $ mkLine (-1, -1) (1, 1) + 241 > ] + 242 > ] + 243 + 244 <<docs/gifs/doc_pathify.gif>> + 245 -} + 246 pathify :: Tree -> Tree + 247 pathify = mapTree worker + 248 where + 249 worker = + 250 \case + 251 RectangleTree rect | Just (x,y,w,h) <- unpackRect rect -> + 252 PathTree $ defaultSvg + 253 & drawAttributes .~ rect ^. drawAttributes + 254 & strokeLineCap .~ pure CapSquare 255 & pathDefinition .~ - 256 [MoveTo OriginAbsolute [V2 x1 y1] - 257 ,LineTo OriginAbsolute [V2 x2 y2] ] - 258 CircleTree circ | Just (x, y, r) <- unpackCircle circ -> - 259 PathTree $ defaultSvg - 260 & drawAttributes .~ circ ^. drawAttributes - 261 & pathDefinition .~ - 262 [MoveTo OriginAbsolute [V2 (x-r) y] - 263 ,EllipticalArc OriginRelative [(r, r, 0,True,False,V2 (r*2) 0) - 264 ,(r, r, 0,True,False,V2 (-r*2) 0)]] - 265 PolyLineTree pl -> - 266 let points = pl ^. polyLinePoints - 267 in PathTree $ defaultSvg - 268 & drawAttributes .~ pl ^. drawAttributes - 269 & pathDefinition .~ pointsToPathCommands points - 270 PolygonTree pg -> - 271 let points = pg ^. polygonPoints - 272 in PathTree $ defaultSvg - 273 & drawAttributes .~ pg ^. drawAttributes - 274 -- Polygon automatically connects the last point to the first. For path we must do - 275 -- it explicitly - 276 & pathDefinition .~ (pointsToPathCommands points ++ [EndPath]) - 277 EllipseTree elip | Just (cx,cy,rx,ry) <- unpackEllipse elip -> - 278 PathTree $ defaultSvg - 279 & drawAttributes .~ elip ^. drawAttributes - 280 & pathDefinition .~ - 281 [ MoveTo OriginAbsolute [V2 (cx-rx) cy] - 282 , EllipticalArc OriginRelative [(rx, ry, 0,True,False,V2 (rx*2) 0) - 283 ,(rx, ry, 0,True,False,V2 (-rx*2) 0)]] - 284 t -> t - 285 unpackCircle circ = do - 286 let (x,y) = circ ^. circleCenter - 287 liftM3 (,,) (unpackNumber x) (unpackNumber y) (unpackNumber $ circ ^. circleRadius) - 288 unpackEllipse elip = do - 289 let (x,y) = elip ^. ellipseCenter - 290 liftM4 (,,,) (unpackNumber x) (unpackNumber y) (unpackNumber $ elip ^. ellipseXRadius) - 291 (unpackNumber $ elip ^. ellipseYRadius) - 292 unpackLine line = do - 293 let (x1,y1) = line ^. linePoint1 - 294 (x2,y2) = line ^. linePoint2 - 295 liftM4 (,,,) (unpackNumber x1) (unpackNumber y1) (unpackNumber x2) (unpackNumber y2) - 296 unpackRect rect = do - 297 let (x', y') = rect ^. rectUpperLeftCorner - 298 x <- unpackNumber x' - 299 y <- unpackNumber y' - 300 w <- unpackNumber =<< rect ^. rectWidth - 301 h <- unpackNumber =<< rect ^. rectHeight - 302 return (x,y,w,h) - 303 pointsToPathCommands points = case points of - 304 [] -> [] - 305 (p:ps) -> [ MoveTo OriginAbsolute [p] - 306 , LineTo OriginAbsolute ps ] - 307 unpackNumber n = - 308 case toUserUnit defaultDPI n of - 309 Num d -> Just d - 310 _ -> Nothing - 311 - 312 mapSvgPaths :: ([PathCommand] -> [PathCommand]) -> SVG -> SVG - 313 mapSvgPaths fn = mapTree worker - 314 where - 315 worker = - 316 \case - 317 PathTree path -> PathTree $ - 318 path & pathDefinition %~ fn - 319 t -> t + 256 [MoveTo OriginAbsolute [V2 x y] + 257 ,HorizontalTo OriginRelative [w] + 258 ,VerticalTo OriginRelative [h] + 259 ,HorizontalTo OriginRelative [-w] + 260 ,EndPath ] + 261 LineTree line | Just (x1,y1, x2, y2) <- unpackLine line -> + 262 PathTree $ defaultSvg + 263 & drawAttributes .~ line ^. drawAttributes + 264 & pathDefinition .~ + 265 [MoveTo OriginAbsolute [V2 x1 y1] + 266 ,LineTo OriginAbsolute [V2 x2 y2] ] + 267 CircleTree circ | Just (x, y, r) <- unpackCircle circ -> + 268 PathTree $ defaultSvg + 269 & drawAttributes .~ circ ^. drawAttributes + 270 & pathDefinition .~ + 271 [MoveTo OriginAbsolute [V2 (x-r) y] + 272 ,EllipticalArc OriginRelative [(r, r, 0,True,False,V2 (r*2) 0) + 273 ,(r, r, 0,True,False,V2 (-r*2) 0)]] + 274 PolyLineTree pl -> + 275 let points = pl ^. polyLinePoints + 276 in PathTree $ defaultSvg + 277 & drawAttributes .~ pl ^. drawAttributes + 278 & pathDefinition .~ pointsToPathCommands points + 279 PolygonTree pg -> + 280 let points = pg ^. polygonPoints + 281 in PathTree $ defaultSvg + 282 & drawAttributes .~ pg ^. drawAttributes + 283 -- Polygon automatically connects the last point to the first. For path we must do + 284 -- it explicitly + 285 & pathDefinition .~ (pointsToPathCommands points ++ [EndPath]) + 286 EllipseTree elip | Just (cx,cy,rx,ry) <- unpackEllipse elip -> + 287 PathTree $ defaultSvg + 288 & drawAttributes .~ elip ^. drawAttributes + 289 & pathDefinition .~ + 290 [ MoveTo OriginAbsolute [V2 (cx-rx) cy] + 291 , EllipticalArc OriginRelative [(rx, ry, 0,True,False,V2 (rx*2) 0) + 292 ,(rx, ry, 0,True,False,V2 (-rx*2) 0)]] + 293 t -> t + 294 unpackCircle circ = do + 295 let (x,y) = circ ^. circleCenter + 296 liftM3 (,,) (unpackNumber x) (unpackNumber y) (unpackNumber $ circ ^. circleRadius) + 297 unpackEllipse elip = do + 298 let (x,y) = elip ^. ellipseCenter + 299 liftM4 (,,,) (unpackNumber x) (unpackNumber y) (unpackNumber $ elip ^. ellipseXRadius) + 300 (unpackNumber $ elip ^. ellipseYRadius) + 301 unpackLine line = do + 302 let (x1,y1) = line ^. linePoint1 + 303 (x2,y2) = line ^. linePoint2 + 304 liftM4 (,,,) (unpackNumber x1) (unpackNumber y1) (unpackNumber x2) (unpackNumber y2) + 305 unpackRect rect = do + 306 let (x', y') = rect ^. rectUpperLeftCorner + 307 x <- unpackNumber x' + 308 y <- unpackNumber y' + 309 w <- unpackNumber =<< rect ^. rectWidth + 310 h <- unpackNumber =<< rect ^. rectHeight + 311 return (x,y,w,h) + 312 pointsToPathCommands points = case points of + 313 [] -> [] + 314 (p:ps) -> [ MoveTo OriginAbsolute [p] + 315 , LineTo OriginAbsolute ps ] + 316 unpackNumber n = + 317 case toUserUnit defaultDPI n of + 318 Num d -> Just d + 319 _ -> Nothing 320 - 321 mapSvgLines :: ([LineCommand] -> [LineCommand]) -> SVG -> SVG - 322 mapSvgLines fn = mapSvgPaths (lineToPath . fn . toLineCommands) - 323 - 324 -- Only maps points in paths - 325 mapSvgPoints :: (RPoint -> RPoint) -> SVG -> SVG - 326 mapSvgPoints fn = mapSvgLines (map worker) - 327 where - 328 worker (LineMove p) = LineMove (fn p) - 329 worker (LineBezier ps) = LineBezier (map fn ps) - 330 worker (LineEnd p) = LineEnd (fn p) - 331 - 332 svgPointsToRadians :: SVG -> SVG - 333 svgPointsToRadians = mapSvgPoints worker - 334 where - 335 worker (V2 x y) = V2 (x/180*pi) (y/180*pi) + 321 -- | Map over all recursively-found path commands. + 322 mapSvgPaths :: ([PathCommand] -> [PathCommand]) -> SVG -> SVG + 323 mapSvgPaths fn = mapTree worker + 324 where + 325 worker = + 326 \case + 327 PathTree path -> PathTree $ + 328 path & pathDefinition %~ fn + 329 t -> t + 330 + 331 -- | Map over all recursively-found line commands. + 332 mapSvgLines :: ([LineCommand] -> [LineCommand]) -> SVG -> SVG + 333 mapSvgLines fn = mapSvgPaths (lineToPath . fn . toLineCommands) + 334 + 335 -- Only maps points in paths + 336 -- | Map over all line command control points. + 337 mapSvgPoints :: (RPoint -> RPoint) -> SVG -> SVG + 338 mapSvgPoints fn = mapSvgLines (map worker) + 339 where + 340 worker (LineMove p) = LineMove (fn p) + 341 worker (LineBezier ps) = LineBezier (map fn ps) + 342 worker (LineEnd p) = LineEnd (fn p) + 343 + 344 -- | Convert coordinate system from degrees to radians. + 345 svgPointsToRadians :: SVG -> SVG + 346 svgPointsToRadians = mapSvgPoints worker + 347 where + 348 worker (V2 x y) = V2 (x/180*pi) (y/180*pi)