diff --git a/haddock.txt b/haddock.txt index c414ab7..1fcc378 100644 --- a/haddock.txt +++ b/haddock.txt @@ -19,21 +19,20 @@ 100% ( 4 / 4) in 'Reanimate.Svg.BoundingBox' 100% ( 3 / 3) in 'Reanimate.Blender' 100% ( 2 / 2) in 'Reanimate.Builtin.CirclePlot' + 97% ( 28 / 29) in 'Reanimate.Math.Common' + 92% ( 12 / 13) in 'Reanimate.Morph.Common' + 89% (101 /113) in 'Reanimate.Scene' 88% ( 7 / 8) in 'Reanimate.Transition' - 86% ( 98 /114) in 'Reanimate.Scene' + 84% ( 31 / 37) in 'Geom2D.CubicBezier.Linear' 75% ( 3 / 4) in 'Reanimate.Svg.Unuse' - 62% ( 23 / 37) in 'Geom2D.CubicBezier.Linear' 56% ( 10 / 18) in 'Reanimate.Svg' 44% ( 4 / 9) in 'Reanimate.LaTeX' 31% ( 4 / 13) in 'Reanimate.Render' 25% ( 1 / 4) in 'Reanimate.Builtin.Slide' 12% ( 2 / 17) in 'Reanimate.Math.SSSP' - 10% ( 3 / 29) in 'Reanimate.Math.Common' 6% ( 5 / 84) in 'Reanimate.Math.Polygon' 6% ( 1 / 18) in 'Reanimate.Svg.LineCommand' - 0% ( 0 / 13) in 'Reanimate.Morph.Common' 0% ( 0 / 10) in 'Reanimate.ColorSpace' - 0% ( 0 / 8) in 'Reanimate.Misc' 0% ( 0 / 7) in 'Reanimate.Morph.Linear' 0% ( 0 / 7) in 'Reanimate.Math.Triangulate' 0% ( 0 / 5) in 'Reanimate.Builtin.Flip' diff --git a/haddock_badge.json b/haddock_badge.json index 0fb4ebc..ea97d81 100644 --- a/haddock_badge.json +++ b/haddock_badge.json @@ -1 +1 @@ - { "schemaVersion": 1, "label": "api docs", "message": "77%", "color": "success" } + { "schemaVersion": 1, "label": "api docs", "message": "69%", "color": "success" } diff --git a/playground/snippets.js b/playground/snippets.js index 57599ae..84e78b7 100644 --- a/playground/snippets.js +++ b/playground/snippets.js @@ -9,4 +9,4 @@ const snippets = [{"title": "Hello World","url": "https://reanimate.clozecards.c ,{"title": "Object Positions","url": "https://reanimate.clozecards.com/IAQhjO0Ke7h/195.svg","code": "env =\n addStatic (mkBackground \"white\") .\n mapA (withStrokeColor \"black\")\n\nanimation :: Animation\nanimation = env $\n sceneAnimation $ do\n -- Configure objects\n txt <- newText \"Center\"\n top <- newText \"Top\"\n oModifyS top $ \n oTopY .= screenTop\n topR <- newText \"Top right\"\n oModifyS topR $ do\n oTopY .= screenTop\n oRightX .= screenRight\n botR <- newText \"Bottom right\"\n oModifyS botR $ do\n oBottomY .= screenBottom\n oRightX .= screenRight\n botL <- newText \"Bottom left\"\n oModifyS botL $ do\n oBottomY .= screenBottom\n oLeftX .= screenLeft\n topL <- newText \"Top left\"\n oModifyS topL $ do\n oTopY .= screenTop\n oLeftX .= screenLeft\n -- Show objects\n oShow txt\n wait 1\n switchTo txt top\n switchTo top topR\n switchTo topR botR\n switchTo botR botL\n switchTo botL topL\n switchTo topL txt\n\nswitchTo src dst = do\n fork $ oFadeOut src 1\n oModify dst $ oOpacity .~ 1\n oFadeIn dst 1\n wait 1\n\nnewText txt =\n newObject $ scale 1.5 $ center $ latex txt\n"} ,{"title": "Camera","url": "https://reanimate.clozecards.com/CD5Bg7AwVkF/150.svg","code": "animation :: Animation\nanimation = docEnv $ mapA (withFillOpacity 1) $ sceneAnimation $ do\n cam <- newObject Camera\n\n txt <- newObject $ center $ latex \"Fixed (non-cam)\"\n oModifyS txt $ do\n oTopY .= screenTop \n oZIndex .= 2\n\n circle <- newObject $ Circle 1\n cameraAttach cam circle\n oModify circle $ oContext .~ withFillColor \"blue\"\n circleRight <- oRead circle oRightX\n\n box <- newObject $ Rectangle 2 2\n cameraAttach cam box\n oModify box $ oContext .~ withFillColor \"green\"\n oModify box $ oLeftX .~ circleRight\n boxCenter <- oRead box oCenterXY\n\n small <- newObject $ center $ latex \"This text is very small\"\n cameraAttach cam small\n oModifyS small $ do\n oCenterXY .= boxCenter\n oScale .= 0.1\n \n oShow txt\n oShow small\n oShow circle\n oShow box\n\n wait 1\n\n cameraFocus cam boxCenter\n waitOn $ do\n fork $ cameraPan cam 3 boxCenter\n fork $ cameraZoom cam 3 15\n \n wait 2\n cameraZoom cam 3 1\n cameraPan cam 1 (0,0)\n"} ]; -const playgroundVersion = "2020-08-26 (efa55)"; +const playgroundVersion = "2020-08-26 (ce105)"; 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 a0657fe..1f9ea81 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 @@ -95,230 +95,242 @@ span.spaces { background: white } 76 , quadC2 :: !(V2 a) 77 } deriving (Show, Eq) 78 - 79 data OpenPath a = OpenPath [(V2 a, PathJoin a)] (V2 a) - 80 deriving (Show, Eq) - 81 data ClosedPath a = ClosedPath [(V2 a, PathJoin a)] - 82 deriving (Show, Eq) - 83 - 84 data PathJoin a - 85 = JoinLine - 86 | JoinCurve (V2 a) (V2 a) - 87 deriving (Show, Eq) - 88 - 89 data ClosedMetaPath a = ClosedMetaPath [(V2 a, MetaJoin a)] - 90 deriving (Show, Eq) - 91 data OpenMetaPath a = OpenMetaPath [(V2 a, MetaJoin a)] (V2 a) + 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 data MetaJoin a - 95 = MetaJoin - 96 { metaTypeL :: MetaNodeType a - 97 , tensionL :: C.Tension a - 98 , tensionR :: C.Tension a - 99 , metaTypeR :: MetaNodeType a - 100 } - 101 | Controls (V2 a) (V2 a) - 102 deriving (Show, Eq) - 103 - 104 data MetaNodeType a - 105 = Open - 106 | Curl { curlgamma :: a } - 107 | Direction { nodedir :: V2 a } - 108 deriving (Show, Eq) - 109 - 110 ------------------------------------------------------------ - 111 -- Methods - 112 - 113 -- | Convert a quadratic bezier to a cubic bezier. - 114 quadToCubic :: Fractional a => QuadBezier a -> CubicBezier a - 115 quadToCubic = upCast . C.quadToCubic . downCast - 116 - 117 -- | @arcLength c t tol@ finds the arclength of the bezier @c@ at @t@, - 118 -- within given tolerance @tol@. - 119 arcLength :: CubicBezier Double -> Double -> Double -> Double - 120 arcLength bezier t tol = C.arcLength (downCast bezier) t tol - 121 - 122 -- | @arcLengthParam c len tol@ finds the parameter where the curve @c@ - 123 -- has the arclength @len@, within tolerance @tol@. - 124 arcLengthParam :: CubicBezier Double -> Double -> Double -> Double - 125 arcLengthParam bezier t tol = C.arcLengthParam (downCast bezier) t tol - 126 - 127 -- | Return @False@ if some points fall outside a line with a thickness of the given tolerance. - 128 colinear :: CubicBezier Double -> Double -> Bool - 129 colinear bezier tol = C.colinear (downCast bezier) tol - 130 - 131 -- | Calculate a value on the bezier curve. - 132 evalBezier :: (C.GenericBezier b, V.Unbox a, Fractional a) => b a -> a -> V2 a - 133 evalBezier c p = upCast $ C.evalBezier c p - 134 - 135 -- | Calculate a value and the first derivative on the curve. - 136 evalBezierDeriv :: (V.Unbox a, Fractional a,C.GenericBezier b) => b a -> a -> (V2 a, V2 a) - 137 evalBezierDeriv c p = upCast $ C.evalBezierDeriv c p - 138 - 139 -- | Find the parameter where the bezier curve is horizontal. - 140 bezierHoriz :: CubicBezier Double -> [Double] - 141 bezierHoriz = C.bezierHoriz . downCast - 142 - 143 -- | Find the parameter where the bezier curve is vertical. - 144 bezierVert :: CubicBezier Double -> [Double] - 145 bezierVert = C.bezierVert . downCast - 146 - 147 -- | Create a normal path from a metapath. - 148 unmetaOpen :: OpenMetaPath Double -> OpenPath Double - 149 unmetaOpen = upCast . C.unmetaOpen . downCast - 150 - 151 unmetaClosed :: ClosedMetaPath Double -> ClosedPath Double - 152 unmetaClosed = upCast . C.unmetaClosed . downCast + 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 153 - 154 -- | `O((n+m)*log(n+m))`, for n segments and m intersections. - 155 -- Union of paths, removing overlap and rounding to the given tolerance. - 156 union :: [ClosedPath Double] -> C.FillRule -> Double -> [ClosedPath Double] - 157 union p fill tol = upCast (C.union (downCast p) fill tol) - 158 - 159 -- | Find the intersections between two Bezier curves, using the Bezier Clip algorithm. - 160 -- Returns the parameters for both curves. - 161 bezierIntersection :: CubicBezier Double -> CubicBezier Double -> Double -> [(Double, Double)] - 162 bezierIntersection a b t = C.bezierIntersection (downCast a) (downCast b) t - 163 - 164 -- | Find the closest value on the bezier to the given point, within tolerance. - 165 -- Return the first value found. - 166 closest :: CubicBezier Double -> V2 Double -> Double -> Double - 167 closest c p t = C.closest (downCast c) (downCast p) t - 168 - 169 -- | Return the closed path as a list of curves. - 170 closedPathCurves :: Fractional a => ClosedPath a -> [CubicBezier a] - 171 closedPathCurves = upCast . C.closedPathCurves . downCast - 172 - 173 -- | Return the open path as a list of curves. - 174 openPathCurves :: Fractional a => OpenPath a -> [CubicBezier a] - 175 openPathCurves = upCast . C.openPathCurves . downCast - 176 - 177 -- | Make an open path from a list of curves. The last control point of each curve is ignored. - 178 curvesToClosed :: [CubicBezier a] -> ClosedPath a - 179 curvesToClosed = upCast . C.curvesToClosed . downCast + 154 -- | Find the parameter where the bezier curve is vertical. + 155 bezierVert :: CubicBezier Double -> [Double] + 156 bezierVert = C.bezierVert . downCast + 157 + 158 -- | Create a normal path from a metapath. + 159 unmetaOpen :: OpenMetaPath Double -> OpenPath Double + 160 unmetaOpen = upCast . C.unmetaOpen . downCast + 161 + 162 -- | Create a normal path from a metapath. + 163 unmetaClosed :: ClosedMetaPath Double -> ClosedPath Double + 164 unmetaClosed = upCast . C.unmetaClosed . downCast + 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 -- | Interpolate between two vectors. - 182 interpolateVector :: Num a => V2 a -> V2 a -> a -> V2 a - 183 interpolateVector a b p = upCast $ C.interpolateVector (downCast a) (downCast b) p + 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 -- | Distance between two vectors. - 186 vectorDistance :: Floating a => V2 a -> V2 a -> a - 187 vectorDistance a b = C.vectorDistance (downCast a) (downCast b) + 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 -- | Find inflection points on the curve. - 190 findBezierInflection :: CubicBezier Double -> [Double] - 191 findBezierInflection = C.findBezierInflection . downCast + 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 -- | Find the cusps of a bezier. - 194 findBezierCusp :: CubicBezier Double -> [Double] - 195 findBezierCusp = C.findBezierCusp . downCast + 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 196 - 197 ------------------------------------------------------------ - 198 -- Instances - 199 - 200 instance C.GenericBezier QuadBezier where - 201 degree = C.degree . downCast - 202 toVector = C.toVector . downCast - 203 unsafeFromVector = upCast . C.unsafeFromVector + 197 -- | Distance between two vectors. + 198 vectorDistance :: Floating a => V2 a -> V2 a -> a + 199 vectorDistance a b = C.vectorDistance (downCast a) (downCast b) + 200 + 201 -- | Find inflection points on the curve. + 202 findBezierInflection :: CubicBezier Double -> [Double] + 203 findBezierInflection = C.findBezierInflection . downCast 204 - 205 instance C.GenericBezier CubicBezier where - 206 degree = C.degree . downCast - 207 toVector = C.toVector . downCast - 208 unsafeFromVector = upCast . C.unsafeFromVector - 209 - 210 instance C.GenericBezier AnyBezier where - 211 degree = C.degree . downCast - 212 toVector = C.toVector . downCast - 213 unsafeFromVector = upCast . C.unsafeFromVector - 214 - 215 ------------------------------------------------------------ - 216 -- Casting - 217 - 218 class Cast a b | a -> b, b -> a where - 219 downCast :: a -> b - 220 upCast :: b -> a + 205 -- | Find the cusps of a bezier. + 206 findBezierCusp :: CubicBezier Double -> [Double] + 207 findBezierCusp = C.findBezierCusp . 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 + 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 Cast a b => Cast [a] [b] where - 223 downCast = map downCast - 224 upCast = map upCast - 225 - 226 instance (Cast a a', Cast b b') => Cast (a,b) (a',b') where - 227 downCast (a, b) = (downCast a, downCast b) - 228 upCast (a, b) = (upCast a, upCast b) + 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 instance Cast (V2 a) (C.Point a) where - 231 downCast (V2 a b) = C.Point a b - 232 upCast (C.Point a b) = V2 a b + 230 class Cast a b | a -> b, b -> a where + 231 downCast :: a -> b + 232 upCast :: b -> a 233 - 234 instance Cast (CubicBezier a) (C.CubicBezier a) where - 235 downCast (CubicBezier a b c d) = C.CubicBezier - 236 (downCast a) (downCast b) (downCast c) (downCast d) - 237 upCast (C.CubicBezier a b c d) = CubicBezier - 238 (upCast a) (upCast b) (upCast c) (upCast d) - 239 - 240 instance Cast (QuadBezier a) (C.QuadBezier a) where - 241 downCast (QuadBezier a b c) = C.QuadBezier - 242 (downCast a) (downCast b) (downCast c) - 243 upCast (C.QuadBezier a b c)= QuadBezier - 244 (upCast a) (upCast b) (upCast c) + 234 instance Cast a b => Cast [a] [b] where + 235 downCast = map downCast + 236 upCast = map upCast + 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 245 - 246 instance V.Unbox a => Cast (AnyBezier a) (C.AnyBezier a) where - 247 downCast (AnyBezier arr) = C.AnyBezier $ - 248 V.map (\(V2 a b) -> (a,b)) arr - 249 upCast (C.AnyBezier arr) = AnyBezier $ - 250 V.map (\(a, b) -> V2 a b) arr + 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 (MetaNodeType a) (C.MetaNodeType a) where - 253 downCast Open = C.Open - 254 downCast (Curl gamma) = C.Curl gamma - 255 downCast (Direction dir) = C.Direction (downCast dir) - 256 upCast C.Open = Open - 257 upCast (C.Curl gamma) = Curl gamma - 258 upCast (C.Direction dir) = Direction (upCast dir) - 259 - 260 instance Cast (MetaJoin a) (C.MetaJoin a) where - 261 downCast (MetaJoin tyL tL tR tyR) = C.MetaJoin (downCast tyL) tL tR (downCast tyR) - 262 downCast (Controls p1 p2) = C.Controls (downCast p1) (downCast p2) - 263 upCast (C.MetaJoin tyL tL tR tyR) = MetaJoin (upCast tyL) tL tR (upCast tyR) - 264 upCast (C.Controls p1 p2) = Controls (upCast p1) (upCast p2) - 265 - 266 instance Cast (PathJoin a) (C.PathJoin a) where - 267 downCast JoinLine = C.JoinLine - 268 downCast (JoinCurve a b) = C.JoinCurve (downCast a) (downCast b) - 269 upCast C.JoinLine = JoinLine - 270 upCast (C.JoinCurve a b) = JoinCurve (upCast a) (upCast b) + 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) + 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 (OpenMetaPath a) (C.OpenMetaPath a) where - 273 downCast (OpenMetaPath lst end) = C.OpenMetaPath - 274 [ (downCast p, downCast j) - 275 | (p, j) <- lst ] (downCast end) - 276 upCast (C.OpenMetaPath lst end) = OpenMetaPath - 277 [ (upCast p, upCast j) - 278 | (p, j) <- lst ] (upCast end) - 279 - 280 instance Cast (ClosedMetaPath a) (C.ClosedMetaPath a) where - 281 downCast (ClosedMetaPath lst) = C.ClosedMetaPath - 282 [ (downCast p, downCast j) - 283 | (p, j) <- lst ] - 284 upCast (C.ClosedMetaPath lst) = ClosedMetaPath - 285 [ (upCast p, upCast j) - 286 | (p, j) <- lst ] - 287 - 288 instance Cast (OpenPath a) (C.OpenPath a) where - 289 downCast (OpenPath lst end) = C.OpenPath - 290 [ (downCast p, downCast j) - 291 | (p, j) <- lst ] (downCast end) - 292 upCast (C.OpenPath lst end) = OpenPath - 293 [ (upCast p, upCast j) - 294 | (p, j) <- lst ] (upCast end) - 295 - 296 instance Cast (ClosedPath a) (C.ClosedPath a) where - 297 downCast (ClosedPath lst) = C.ClosedPath - 298 [ (downCast p, downCast j) - 299 | (p, j) <- lst ] - 300 upCast (C.ClosedPath lst) = ClosedPath - 301 [ (upCast p, upCast j) - 302 | (p, j) <- lst ] + 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 ] + 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) + 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 ] diff --git a/reanimate-0.4.1.0-inplace/Reanimate.Math.Common.hs.html b/reanimate-0.4.1.0-inplace/Reanimate.Math.Common.hs.html index a414b78..790c90b 100644 --- a/reanimate-0.4.1.0-inplace/Reanimate.Math.Common.hs.html +++ b/reanimate-0.4.1.0-inplace/Reanimate.Math.Common.hs.html @@ -26,190 +26,217 @@ span.spaces { background: white } 7 Maintainer : lemmih@gmail.com 8 Stability : experimental 9 Portability : POSIX - 10 -} - 11 module Reanimate.Math.Common - 12 ( -- * Ring - 13 Ring(..) - 14 , ringSize -- :: Ring a -> Int - 15 , ringAccess -- :: Ring a -> Int -> V2 a - 16 , ringClamp -- :: Ring a -> Int -> Int - 17 , ringUnpack -- :: Ring a -> Vector (V2 a) - 18 , ringPack -- :: Vector (V2 a) -> Ring a - 19 , ringMap -- :: (V2 a -> V2 b) -> Ring a -> Ring b - 20 , ringRayIntersect -- :: Ring Rational -> (Int, Int) -> (Int,Int) -> Maybe (V2 Rational) - 21 -- * Math - 22 , area -- :: Fractional a => V2 a -> V2 a -> V2 a -> a - 23 , area2X -- :: Fractional a => V2 a -> V2 a -> V2 a -> a - 24 , isLeftTurn -- :: (Num a, Ord a) => V2 a -> V2 a -> V2 a -> Bool - 25 , isLeftTurnOrLinear -- :: (Num a, Ord a) => V2 a -> V2 a -> V2 a -> Bool - 26 , isRightTurn -- :: (Num a, Ord a) => V2 a -> V2 a -> V2 a -> Bool - 27 , isRightTurnOrLinear -- :: (Num a, Ord a) => V2 a -> V2 a -> V2 a -> Bool - 28 , direction -- :: Num a => V2 a -> V2 a -> V2 a -> a - 29 , isInside -- :: (Fractional a, Ord a) => V2 a -> V2 a -> V2 a -> V2 a -> Bool - 30 , isInsideStrict -- :: (Fractional a, Ord a) => V2 a -> V2 a -> V2 a -> V2 a -> Bool - 31 , barycentricCoords -- :: Fractional a => V2 a -> V2 a -> V2 a -> V2 a -> (a, a, a) - 32 , rayIntersect -- :: (Fractional a, Ord a) => (V2 a,V2 a) -> (V2 a,V2 a) -> Maybe (V2 a) - 33 , isBetween -- :: (Ord a, Fractional a) => V2 a -> (V2 a, V2 a) -> Bool - 34 , lineIntersect -- :: (Ord a, Fractional a) => (V2 a, V2 a) -> (V2 a, V2 a) -> Maybe (V2 a) - 35 , distSquared -- :: (Fractional a) => V2 a -> V2 a -> a - 36 , approxDist -- :: (Real a, Fractional a) => V2 a -> V2 a -> a - 37 , distance' -- :: (Real a, Fractional a) => V2 a -> V2 a -> Double - 38 , triangleAngles -- :: V2 Double -> V2 Double -> V2 Double -> (Double, Double, Double) - 39 , Epsilon(..) - 40 ) where - 41 - 42 import Data.Vector (Vector) - 43 import qualified Data.Vector as V - 44 import Linear.Matrix (det33) - 45 import Linear.Metric - 46 import Linear.V2 - 47 import Linear.V3 - 48 import Linear.Vector - 49 import Linear.Epsilon - 50 - 51 instance Epsilon Rational where - 52 nearZero r = r==0 + 10 + 11 Low-level primitives related to computational geometry. + 12 + 13 -} + 14 module Reanimate.Math.Common + 15 ( -- * Ring + 16 Ring(..) + 17 , ringSize -- :: Ring a -> Int + 18 , ringAccess -- :: Ring a -> Int -> V2 a + 19 , ringClamp -- :: Ring a -> Int -> Int + 20 , ringUnpack -- :: Ring a -> Vector (V2 a) + 21 , ringPack -- :: Vector (V2 a) -> Ring a + 22 , ringMap -- :: (V2 a -> V2 b) -> Ring a -> Ring b + 23 , ringRayIntersect -- :: Ring Rational -> (Int, Int) -> (Int,Int) -> Maybe (V2 Rational) + 24 -- * Math + 25 , area -- :: Fractional a => V2 a -> V2 a -> V2 a -> a + 26 , area2X -- :: Fractional a => V2 a -> V2 a -> V2 a -> a + 27 , isLeftTurn -- :: (Num a, Ord a) => V2 a -> V2 a -> V2 a -> Bool + 28 , isLeftTurnOrLinear -- :: (Num a, Ord a) => V2 a -> V2 a -> V2 a -> Bool + 29 , isRightTurn -- :: (Num a, Ord a) => V2 a -> V2 a -> V2 a -> Bool + 30 , isRightTurnOrLinear -- :: (Num a, Ord a) => V2 a -> V2 a -> V2 a -> Bool + 31 , direction -- :: Num a => V2 a -> V2 a -> V2 a -> a + 32 , isInside -- :: (Fractional a, Ord a) => V2 a -> V2 a -> V2 a -> V2 a -> Bool + 33 , isInsideStrict -- :: (Fractional a, Ord a) => V2 a -> V2 a -> V2 a -> V2 a -> Bool + 34 , barycentricCoords -- :: Fractional a => V2 a -> V2 a -> V2 a -> V2 a -> (a, a, a) + 35 , rayIntersect -- :: (Fractional a, Ord a) => (V2 a,V2 a) -> (V2 a,V2 a) -> Maybe (V2 a) + 36 , isBetween -- :: (Ord a, Fractional a) => V2 a -> (V2 a, V2 a) -> Bool + 37 , lineIntersect -- :: (Ord a, Fractional a) => (V2 a, V2 a) -> (V2 a, V2 a) -> Maybe (V2 a) + 38 , distSquared -- :: (Fractional a) => V2 a -> V2 a -> a + 39 , approxDist -- :: (Real a, Fractional a) => V2 a -> V2 a -> a + 40 , distance' -- :: (Real a, Fractional a) => V2 a -> V2 a -> Double + 41 , triangleAngles -- :: V2 Double -> V2 Double -> V2 Double -> (Double, Double, Double) + 42 , Epsilon(..) + 43 ) where + 44 + 45 import Data.Vector (Vector) + 46 import qualified Data.Vector as V + 47 import Linear.Matrix (det33) + 48 import Linear.Metric + 49 import Linear.V2 + 50 import Linear.V3 + 51 import Linear.Vector + 52 import Linear.Epsilon 53 - 54 newtype Ring a = Ring (Vector (V2 a)) - 55 - 56 ringSize :: Ring a -> Int - 57 ringSize (Ring v) = length v - 58 - 59 ringAccess :: Ring a -> Int -> V2 a - 60 ringAccess (Ring v) i = v V.! mod i (length v) - 61 - 62 ringClamp :: Ring a -> Int -> Int - 63 ringClamp (Ring v) i = mod i (length v) - 64 - 65 ringUnpack :: Ring a -> Vector (V2 a) - 66 ringUnpack (Ring v) = v + 54 instance Epsilon Rational where + 55 nearZero r = r==0 + 56 + 57 -- | Circular collection of pairs. + 58 newtype Ring a = Ring (Vector (V2 a)) + 59 + 60 -- | Number of elements in the ring. + 61 ringSize :: Ring a -> Int + 62 ringSize (Ring v) = length v + 63 + 64 -- | Safe method for accessing elements in the ring. + 65 ringAccess :: Ring a -> Int -> V2 a + 66 ringAccess (Ring v) i = v V.! mod i (length v) 67 - 68 ringPack :: Vector (V2 a) -> Ring a - 69 ringPack = Ring - 70 - 71 ringMap :: (V2 a -> V2 b) -> Ring a -> Ring b - 72 ringMap fn (Ring v) = Ring (V.map fn v) - 73 - 74 ringRayIntersect :: Ring Rational -> (Int, Int) -> (Int,Int) -> Maybe (V2 Rational) - 75 ringRayIntersect p (a,b) (c,d) = - 76 rayIntersect (ringAccess p a, ringAccess p b) (ringAccess p c, ringAccess p d) - 77 - 78 - 79 area :: Fractional a => V2 a -> V2 a -> V2 a -> a - 80 area a b c = 1/2 * area2X a b c - 81 - 82 area2X :: Fractional a => V2 a -> V2 a -> V2 a -> a - 83 area2X (V2 a1 a2) (V2 b1 b2) (V2 c1 c2) = - 84 det33 (V3 (V3 a1 a2 1) - 85 (V3 b1 b2 1) - 86 (V3 c1 c2 1)) - 87 - 88 compareEpsZero :: (Ord a, Fractional a, Epsilon a) => a -> Ordering - 89 compareEpsZero val - 90 | nearZero val = EQ - 91 | otherwise = compare val 0 + 68 -- | Clamp index to within the usable range for the ring. + 69 ringClamp :: Ring a -> Int -> Int + 70 ringClamp (Ring v) i = mod i (length v) + 71 + 72 -- | Convert ring to a vector. + 73 ringUnpack :: Ring a -> Vector (V2 a) + 74 ringUnpack (Ring v) = v + 75 + 76 -- | Convert vector to a ring. + 77 ringPack :: Vector (V2 a) -> Ring a + 78 ringPack = Ring + 79 + 80 -- | Map each element of a ring. + 81 ringMap :: (V2 a -> V2 b) -> Ring a -> Ring b + 82 ringMap fn (Ring v) = Ring (V.map fn v) + 83 + 84 -- | Compute the intersection of two pairs of nodes in the ring. + 85 ringRayIntersect :: Ring Rational -> (Int, Int) -> (Int,Int) -> Maybe (V2 Rational) + 86 ringRayIntersect p (a,b) (c,d) = + 87 rayIntersect (ringAccess p a, ringAccess p b) (ringAccess p c, ringAccess p d) + 88 + 89 -- | Compute area of triangle. + 90 area :: Fractional a => V2 a -> V2 a -> V2 a -> a + 91 area a b c = 1/2 * area2X a b c 92 - 93 {-# INLINE isLeftTurn #-} - 94 -- Left turn. - 95 isLeftTurn :: (Fractional a, Ord a, Epsilon a) => V2 a -> V2 a -> V2 a -> Bool - 96 isLeftTurn p1 p2 p3 = - 97 case compareEpsZero (direction p1 p2 p3) of - 98 LT -> True - 99 EQ -> False -- colinear - 100 GT -> False - 101 - 102 {-# INLINE isLeftTurnOrLinear #-} - 103 isLeftTurnOrLinear :: (Fractional a, Ord a, Epsilon a) => V2 a -> V2 a -> V2 a -> Bool - 104 isLeftTurnOrLinear p1 p2 p3 = - 105 case compareEpsZero (direction p1 p2 p3) of - 106 LT -> True - 107 EQ -> True -- colinear - 108 GT -> False - 109 - 110 {-# INLINE isRightTurn #-} - 111 isRightTurn :: (Fractional a, Ord a, Epsilon a) => V2 a -> V2 a -> V2 a -> Bool - 112 isRightTurn a b c = not (isLeftTurnOrLinear a b c) + 93 -- | Compute 2x area of triangle. This avoids a division. + 94 area2X :: Fractional a => V2 a -> V2 a -> V2 a -> a + 95 area2X (V2 a1 a2) (V2 b1 b2) (V2 c1 c2) = + 96 det33 (V3 (V3 a1 a2 1) + 97 (V3 b1 b2 1) + 98 (V3 c1 c2 1)) + 99 + 100 compareEpsZero :: (Ord a, Fractional a, Epsilon a) => a -> Ordering + 101 compareEpsZero val + 102 | nearZero val = EQ + 103 | otherwise = compare val 0 + 104 + 105 {-# INLINE isLeftTurn #-} + 106 -- | Return @True@ iff the line from @p1@ to @p2@ makes a left-turn to @p3@. + 107 isLeftTurn :: (Fractional a, Ord a, Epsilon a) => V2 a -> V2 a -> V2 a -> Bool + 108 isLeftTurn p1 p2 p3 = + 109 case compareEpsZero (direction p1 p2 p3) of + 110 LT -> True + 111 EQ -> False -- colinear + 112 GT -> False 113 - 114 {-# INLINE isRightTurnOrLinear #-} - 115 isRightTurnOrLinear :: (Fractional a, Ord a, Epsilon a) => V2 a -> V2 a -> V2 a -> Bool - 116 isRightTurnOrLinear a b c = not (isLeftTurn a b c) - 117 - 118 {-# INLINE direction #-} - 119 direction :: Num a => V2 a -> V2 a -> V2 a -> a - 120 direction p1 p2 p3 = crossZ (p3-p1) (p2-p1) - 121 - 122 {-# INLINE isInside #-} - 123 isInside :: (Fractional a, Ord a) => V2 a -> V2 a -> V2 a -> V2 a -> Bool - 124 isInside a b c d = - 125 s >= 0 && s <= 1 && t >= 0 && t <= 1 && i >= 0 && i <= 1 - 126 where - 127 (s, t, i) = barycentricCoords a b c d - 128 - 129 {-# INLINE isInsideStrict #-} - 130 isInsideStrict :: (Fractional a, Ord a) => V2 a -> V2 a -> V2 a -> V2 a -> Bool - 131 isInsideStrict a b c d = - 132 s > 0 && s < 1 && t > 0 && t < 1 && i > 0 && i < 1 - 133 where - 134 (s, t, i) = barycentricCoords a b c d - 135 - 136 {-# INLINE barycentricCoords #-} - 137 barycentricCoords :: Fractional a => V2 a -> V2 a -> V2 a -> V2 a -> (a, a, a) - 138 barycentricCoords (V2 x1 y1) (V2 x2 y2) (V2 x3 y3) (V2 x y) = - 139 (lam1, lam2, lam3) - 140 where - 141 lam1 = ((y2-y3)*(x-x3) + (x3 - x2)*(y-y3)) / - 142 ((y2-y3)*(x1-x3) + (x3-x2)*(y1-y3)) - 143 lam2 = ((y3-y1)*(x-x3) + (x1-x3)*(y-y3)) / - 144 ((y2-y3)*(x1-x3) + (x3-x2)*(y1-y3)) - 145 lam3 = 1 - lam1 - lam2 + 114 {-# INLINE isLeftTurnOrLinear #-} + 115 -- | Return @True@ iff the line from @p1@ to @p2@ does not make a right-turn to @p3@. + 116 isLeftTurnOrLinear :: (Fractional a, Ord a, Epsilon a) => V2 a -> V2 a -> V2 a -> Bool + 117 isLeftTurnOrLinear p1 p2 p3 = + 118 case compareEpsZero (direction p1 p2 p3) of + 119 LT -> True + 120 EQ -> True -- colinear + 121 GT -> False + 122 + 123 {-# INLINE isRightTurn #-} + 124 -- | Return @True@ iff the line from @p1@ to @p2@ makes a right-turn to @p3@. + 125 isRightTurn :: (Fractional a, Ord a, Epsilon a) => V2 a -> V2 a -> V2 a -> Bool + 126 isRightTurn a b c = not (isLeftTurnOrLinear a b c) + 127 + 128 {-# INLINE isRightTurnOrLinear #-} + 129 -- | Return @True@ iff the line from @p1@ to @p2@ does not make a left-turn to @p3@. + 130 isRightTurnOrLinear :: (Fractional a, Ord a, Epsilon a) => V2 a -> V2 a -> V2 a -> Bool + 131 isRightTurnOrLinear a b c = not (isLeftTurn a b c) + 132 + 133 {-# INLINE direction #-} + 134 -- | Compute the change in direction in a line between the three points. + 135 direction :: Num a => V2 a -> V2 a -> V2 a -> a + 136 direction p1 p2 p3 = crossZ (p3-p1) (p2-p1) + 137 + 138 {-# INLINE isInside #-} + 139 -- | Returns @True@ if the fourth argument is inside the triangle or + 140 -- on the border. + 141 isInside :: (Fractional a, Ord a) => V2 a -> V2 a -> V2 a -> V2 a -> Bool + 142 isInside a b c d = + 143 s >= 0 && s <= 1 && t >= 0 && t <= 1 && i >= 0 && i <= 1 + 144 where + 145 (s, t, i) = barycentricCoords a b c d 146 - 147 - 148 {-# INLINE rayIntersect #-} - 149 rayIntersect :: (Fractional a, Ord a) => (V2 a,V2 a) -> (V2 a,V2 a) -> Maybe (V2 a) - 150 rayIntersect (V2 x1 y1,V2 x2 y2) (V2 x3 y3, V2 x4 y4) - 151 | yBot == 0 = Nothing - 152 | otherwise = Just $ - 153 V2 (xTop/xBot) (yTop/yBot) - 154 where - 155 xTop = (x1*y2 - y1*x2)*(x3-x4) - (x1 - x2)*(x3*y4-y3*x4) - 156 xBot = (x1-x2)*(y3-y4)-(y1-y2)*(x3-x4) - 157 yTop = (x1*y2 - y1*x2)*(y3-y4) - (y1-y2)*(x3*y4-y3*x4) - 158 yBot = (x1-x2)*(y3-y4) - (y1-y2)*(x3-x4) - 159 - 160 {-# INLINE isBetween #-} - 161 isBetween :: (Ord a, Fractional a) => V2 a -> (V2 a, V2 a) -> Bool - 162 isBetween (V2 x y) (V2 x1 y1, V2 x2 y2) = - 163 ((y1 > y) /= (y2 > y) || y == y1 || y == y2) && -- y is between y1 and y2 - 164 ((x1 > x) /= (x2 > x) || x == x1 || x == x2) - 165 - 166 {-# INLINE lineIntersect #-} - 167 lineIntersect :: (Ord a, Fractional a) => (V2 a, V2 a) -> (V2 a, V2 a) -> Maybe (V2 a) - 168 lineIntersect a b = - 169 case rayIntersect a b of - 170 Just u - 171 | isBetween u a && isBetween u b -> Just u - 172 _ -> Nothing - 173 - 174 -- circleIntersect :: (Ord a, Fractional a) => (V2 a, V2 a) -> (V2 a, V2 a) -> [V2 a] - 175 - 176 distSquared :: (Num a) => V2 a -> V2 a -> a - 177 distSquared a b = quadrance (a ^-^ b) - 178 - 179 approxDist :: (Real a, Fractional a) => V2 a -> V2 a -> a - 180 approxDist a b = realToFrac (sqrt (realToFrac (distSquared a b) :: Double)) - 181 - 182 distance' :: (Real a, Fractional a) => V2 a -> V2 a -> Double - 183 distance' a b = sqrt (realToFrac (distSquared a b)) - 184 - 185 -- sum of angles is always pi. - 186 triangleAngles :: V2 Double -> V2 Double -> V2 Double -> (Double, Double, Double) - 187 triangleAngles a b c = - 188 (findAngle (b-a) (c-a) - 189 ,findAngle (c-b) (a-b) - 190 ,findAngle (a-c) (b-c)) - 191 where - 192 findAngle v1 v2 = abs (atan2 (crossZ v1 v2) (dot v1 v2)) - 193 -- findAngle v1 v2 = acos (dot v1 v2 / (norm v1 * norm v2)) + 147 {-# INLINE isInsideStrict #-} + 148 -- | Returns @True@ iff the fourth argument is inside the triangle. + 149 isInsideStrict :: (Fractional a, Ord a) => V2 a -> V2 a -> V2 a -> V2 a -> Bool + 150 isInsideStrict a b c d = + 151 s > 0 && s < 1 && t > 0 && t < 1 && i > 0 && i < 1 + 152 where + 153 (s, t, i) = barycentricCoords a b c d + 154 + 155 {-# INLINE barycentricCoords #-} + 156 -- | Compute relative coordinates inside the triangle. Invariant: @a+b+c=1@ + 157 barycentricCoords :: Fractional a => V2 a -> V2 a -> V2 a -> V2 a -> (a, a, a) + 158 barycentricCoords (V2 x1 y1) (V2 x2 y2) (V2 x3 y3) (V2 x y) = + 159 (lam1, lam2, lam3) + 160 where + 161 lam1 = ((y2-y3)*(x-x3) + (x3 - x2)*(y-y3)) / + 162 ((y2-y3)*(x1-x3) + (x3-x2)*(y1-y3)) + 163 lam2 = ((y3-y1)*(x-x3) + (x1-x3)*(y-y3)) / + 164 ((y2-y3)*(x1-x3) + (x3-x2)*(y1-y3)) + 165 lam3 = 1 - lam1 - lam2 + 166 + 167 + 168 {-# INLINE rayIntersect #-} + 169 -- | Compute intersection of two infinite lines. + 170 rayIntersect :: (Fractional a, Ord a) => (V2 a,V2 a) -> (V2 a,V2 a) -> Maybe (V2 a) + 171 rayIntersect (V2 x1 y1,V2 x2 y2) (V2 x3 y3, V2 x4 y4) + 172 | yBot == 0 = Nothing + 173 | otherwise = Just $ + 174 V2 (xTop/xBot) (yTop/yBot) + 175 where + 176 xTop = (x1*y2 - y1*x2)*(x3-x4) - (x1 - x2)*(x3*y4-y3*x4) + 177 xBot = (x1-x2)*(y3-y4)-(y1-y2)*(x3-x4) + 178 yTop = (x1*y2 - y1*x2)*(y3-y4) - (y1-y2)*(x3*y4-y3*x4) + 179 yBot = (x1-x2)*(y3-y4) - (y1-y2)*(x3-x4) + 180 + 181 {-# INLINE isBetween #-} + 182 -- | Returns @True@ iff a point is on a line segment. + 183 isBetween :: (Ord a, Fractional a) => V2 a -> (V2 a, V2 a) -> Bool + 184 isBetween (V2 x y) (V2 x1 y1, V2 x2 y2) = + 185 ((y1 > y) /= (y2 > y) || y == y1 || y == y2) && -- y is between y1 and y2 + 186 ((x1 > x) /= (x2 > x) || x == x1 || x == x2) + 187 + 188 {-# INLINE lineIntersect #-} + 189 -- | Compute intersection of two line segments. + 190 lineIntersect :: (Ord a, Fractional a) => (V2 a, V2 a) -> (V2 a, V2 a) -> Maybe (V2 a) + 191 lineIntersect a b = + 192 case rayIntersect a b of + 193 Just u + 194 | isBetween u a && isBetween u b -> Just u + 195 _ -> Nothing + 196 + 197 -- circleIntersect :: (Ord a, Fractional a) => (V2 a, V2 a) -> (V2 a, V2 a) -> [V2 a] + 198 + 199 -- | Compute the square of the distance between two points. + 200 distSquared :: (Num a) => V2 a -> V2 a -> a + 201 distSquared a b = quadrance (a ^-^ b) + 202 + 203 -- | Approximate the distance between two points. + 204 approxDist :: (Real a, Fractional a) => V2 a -> V2 a -> a + 205 approxDist a b = realToFrac (sqrt (realToFrac (distSquared a b) :: Double)) + 206 + 207 -- | Approximate the distance between two points. + 208 distance' :: (Real a, Fractional a) => V2 a -> V2 a -> Double + 209 distance' a b = sqrt (realToFrac (distSquared a b)) + 210 + 211 -- sum of angles is always pi. + 212 -- | Approximate the angles of a triangle. + 213 triangleAngles :: V2 Double -> V2 Double -> V2 Double -> (Double, Double, Double) + 214 triangleAngles a b c = + 215 (findAngle (b-a) (c-a) + 216 ,findAngle (c-b) (a-b) + 217 ,findAngle (a-c) (b-c)) + 218 where + 219 findAngle v1 v2 = abs (atan2 (crossZ v1 v2) (dot v1 v2)) + 220 -- findAngle v1 v2 = acos (dot v1 v2 / (norm v1 * norm v2)) diff --git a/reanimate-0.4.1.0-inplace/Reanimate.Morph.Common.hs.html b/reanimate-0.4.1.0-inplace/Reanimate.Morph.Common.hs.html index 961aa82..43c291d 100644 --- a/reanimate-0.4.1.0-inplace/Reanimate.Morph.Common.hs.html +++ b/reanimate-0.4.1.0-inplace/Reanimate.Morph.Common.hs.html @@ -62,147 +62,172 @@ span.spaces { background: white } 43 -- Graphical polygon? FIXME: Come up with a better name. 44 type GPolygon = (DrawAttributes, Polygon) 45 - 46 type PointCorrespondence = Polygon → Polygon → (Polygon, Polygon) - 47 type Trajectory = (Polygon, Polygon) → (Double → Polygon) - 48 type ObjectCorrespondence = [GPolygon] → [GPolygon] → [(GPolygon, GPolygon)] + 46 -- | Method determining how points in the source polygon align with + 47 -- points in the target polygon. + 48 type PointCorrespondence = Polygon → Polygon → (Polygon, Polygon) 49 - 50 data Morph = Morph - 51 { morphTolerance :: Double - 52 , morphColorComponents :: ColorComponents - 53 , morphPointCorrespondence :: PointCorrespondence - 54 , morphTrajectory :: Trajectory - 55 , morphObjectCorrespondence :: ObjectCorrespondence - 56 } - 57 - 58 {-# INLINE morph #-} - 59 morph :: Morph -> SVG -> SVG -> Double -> SVG - 60 morph Morph{..} src dst = \t -> - 61 case t of - 62 -- 0 -> lowerTransformations src - 63 -- 1 -> lowerTransformations dst - 64 _ -> mkGroup - 65 [ render (genPoints t) - 66 & drawAttributes .~ genAttrs t - 67 | (genAttrs, genPoints) <- gens - 68 ] - 69 where - 70 render p = mkLinePathClosed - 71 [ (x,y) | V2 x y <- map (fmap realToFrac) $ V.toList $ polygonPoints p ] - 72 srcShapes = toShapes morphTolerance src - 73 dstShapes = toShapes morphTolerance dst - 74 pairs = morphObjectCorrespondence srcShapes dstShapes - 75 gens = - 76 [ (interpolateAttrs morphColorComponents srcAttr dstAttr, morphTrajectory arranged) - 77 | ((srcAttr, srcPoly'), (dstAttr, dstPoly')) <- pairs - 78 , let arranged = morphPointCorrespondence srcPoly' dstPoly' - 79 ] - 80 - 81 normalizePolygons :: (Real a, Fractional a, Epsilon a) => APolygon a -> APolygon a -> (APolygon a, APolygon a) - 82 normalizePolygons src dst = - 83 (pAddPoints (max 0 $ dstN-srcN) src - 84 ,pAddPoints (max 0 $ srcN-dstN) dst) + 50 -- | Method for interpolating between two aligned polygons. + 51 type Trajectory = (Polygon, Polygon) → (Double → Polygon) + 52 + 53 -- | Method for pairing sets of polygons. + 54 type ObjectCorrespondence = [GPolygon] → [GPolygon] → [(GPolygon, GPolygon)] + 55 + 56 -- | Morphing strategy + 57 data Morph = Morph + 58 { morphTolerance :: Double + 59 -- ^ Morphing curves is not always possible and + 60 -- sometimes shapes are reduced to polygons or meta-curves. + 61 -- This parameter determined the accuracy of this transformation. + 62 , morphColorComponents :: ColorComponents + 63 -- ^ Color components used for color interpolation. LAB is usually + 64 -- the best option here. + 65 , morphPointCorrespondence :: PointCorrespondence + 66 -- ^ Desired point-correspondence algorithm. + 67 , morphTrajectory :: Trajectory + 68 -- ^ Desired interpolation algorithm. + 69 , morphObjectCorrespondence :: ObjectCorrespondence + 70 -- ^ Desired object-correspondence algorithm. + 71 } + 72 + 73 {-# INLINE morph #-} + 74 -- | Apply morphing strategy to interpolate between two SVG images. + 75 morph :: Morph -> SVG -> SVG -> Double -> SVG + 76 morph Morph{..} src dst = \t -> + 77 case t of + 78 -- 0 -> lowerTransformations src + 79 -- 1 -> lowerTransformations dst + 80 _ -> mkGroup + 81 [ render (genPoints t) + 82 & drawAttributes .~ genAttrs t + 83 | (genAttrs, genPoints) <- gens + 84 ] 85 where - 86 srcN = pSize src - 87 dstN = pSize dst - 88 - 89 interpolateAttrs :: ColorComponents -> DrawAttributes -> DrawAttributes -> Double -> DrawAttributes - 90 interpolateAttrs colorComps src dst t = - 91 src & fillColor .~ (interpColor <$> src^.fillColor <*> dst^.fillColor) - 92 & strokeColor .~ (interpColor <$> src^.strokeColor <*> dst^.strokeColor) - 93 & fillOpacity .~ (interpOpacity <$> src^.fillOpacity <*> dst^.fillOpacity) - 94 & groupOpacity .~ (interpOpacity <$> src^.groupOpacity <*> dst^.groupOpacity) - 95 & strokeOpacity .~ (interpOpacity <$> src^.strokeOpacity <*> dst^.strokeOpacity) - 96 where - 97 interpColor (ColorRef a) (ColorRef b) = - 98 ColorRef $ interpolateRGBA8 colorComps a b t - 99 -- interpolateColor (ColorRef a) FillNone = ColorRef a - 100 interpColor a _ = a - 101 interpOpacity a b = realToFrac (fromToS (realToFrac a) (realToFrac b) t) - 102 - 103 genesisObjectCorrespondence :: ObjectCorrespondence - 104 genesisObjectCorrespondence left right = - 105 case (left, right) of - 106 ([] , []) -> [] - 107 ([], (y1,y2):ys) -> - 108 ((y1,y2), (y1, emptyFrom y2 y2)) : genesisObjectCorrespondence [] ys - 109 ((x1,x2):xs, []) -> - 110 ((x1,x2), (x1, emptyFrom x2 x2)) : genesisObjectCorrespondence xs [] - 111 (x:xs, y:ys) -> - 112 (x,y) : genesisObjectCorrespondence xs ys - 113 where - 114 emptyFrom a b = mkPolygon $ V.map (const $ pCentroid a) (polygonPoints b) - 115 - 116 dupObjectCorrespondence :: ObjectCorrespondence - 117 dupObjectCorrespondence left right = - 118 case (left, right) of - 119 (_, []) -> [] - 120 ([], _) -> [] - 121 ([x], [y]) -> - 122 [(x,y)] - 123 ([(x1,x2)], yShapes) -> - 124 let x2s = replicate (length yShapes) x2 - 125 in dupObjectCorrespondence (map (x1,) x2s) yShapes - 126 (xShapes, [(y1,y2)]) -> - 127 let y2s = replicate (length xShapes) y2 - 128 in dupObjectCorrespondence xShapes (map (y1,) y2s) + 86 render p = mkLinePathClosed + 87 [ (x,y) | V2 x y <- map (fmap realToFrac) $ V.toList $ polygonPoints p ] + 88 srcShapes = toShapes morphTolerance src + 89 dstShapes = toShapes morphTolerance dst + 90 pairs = morphObjectCorrespondence srcShapes dstShapes + 91 gens = + 92 [ (interpolateAttrs morphColorComponents srcAttr dstAttr, morphTrajectory arranged) + 93 | ((srcAttr, srcPoly'), (dstAttr, dstPoly')) <- pairs + 94 , let arranged = morphPointCorrespondence srcPoly' dstPoly' + 95 ] + 96 + 97 -- | Add points to each polygon such that they end up with same size. + 98 normalizePolygons :: (Real a, Fractional a, Epsilon a) => APolygon a -> APolygon a -> (APolygon a, APolygon a) + 99 normalizePolygons src dst = + 100 (pAddPoints (max 0 $ dstN-srcN) src + 101 ,pAddPoints (max 0 $ srcN-dstN) dst) + 102 where + 103 srcN = pSize src + 104 dstN = pSize dst + 105 + 106 interpolateAttrs :: ColorComponents -> DrawAttributes -> DrawAttributes -> Double -> DrawAttributes + 107 interpolateAttrs colorComps src dst t = + 108 src & fillColor .~ (interpColor <$> src^.fillColor <*> dst^.fillColor) + 109 & strokeColor .~ (interpColor <$> src^.strokeColor <*> dst^.strokeColor) + 110 & fillOpacity .~ (interpOpacity <$> src^.fillOpacity <*> dst^.fillOpacity) + 111 & groupOpacity .~ (interpOpacity <$> src^.groupOpacity <*> dst^.groupOpacity) + 112 & strokeOpacity .~ (interpOpacity <$> src^.strokeOpacity <*> dst^.strokeOpacity) + 113 where + 114 interpColor (ColorRef a) (ColorRef b) = + 115 ColorRef $ interpolateRGBA8 colorComps a b t + 116 -- interpolateColor (ColorRef a) FillNone = ColorRef a + 117 interpColor a _ = a + 118 interpOpacity a b = realToFrac (fromToS (realToFrac a) (realToFrac b) t) + 119 + 120 -- | Object-correspondence algorithm that spawn objects as necessary. + 121 genesisObjectCorrespondence :: ObjectCorrespondence + 122 genesisObjectCorrespondence left right = + 123 case (left, right) of + 124 ([] , []) -> [] + 125 ([], (y1,y2):ys) -> + 126 ((y1,y2), (y1, emptyFrom y2 y2)) : genesisObjectCorrespondence [] ys + 127 ((x1,x2):xs, []) -> + 128 ((x1,x2), (x1, emptyFrom x2 x2)) : genesisObjectCorrespondence xs [] 129 (x:xs, y:ys) -> - 130 (x, y) : dupObjectCorrespondence xs ys - 131 - 132 splitObjectCorrespondence :: ObjectCorrespondence - 133 -- splitObjectCorrespondence = dupObjectCorrespondence - 134 splitObjectCorrespondence left right = - 135 case (left, right) of - 136 (_, []) -> [] - 137 ([], _) -> [] - 138 ([x], [y]) -> - 139 [(x,y)] - 140 ([(x1,x2)], yShapes) -> - 141 let x2s = splitPolygon (length yShapes) x2 - 142 in splitObjectCorrespondence (map (x1,) x2s) yShapes - 143 (xShapes, [(y1,y2)]) -> - 144 let y2s = splitPolygon (length xShapes) y2 - 145 in splitObjectCorrespondence xShapes (map (y1,) y2s) - 146 (x:xs, y:ys) -> - 147 (x,y) : splitObjectCorrespondence xs ys - 148 - 149 splitPolygon :: Int -> Polygon -> [Polygon] - 150 splitPolygon 1 p = [p] - 151 splitPolygon n p = - 152 let (a,b) = pCutEqual p - 153 in splitPolygon (n`div`2) a ++ splitPolygon ((n+1)`div`2) b - 154 - 155 -- joinPairs :: Correspondence -> [(DrawAttributes, PolyShape)] -> [(DrawAttributes, PolyShape)] - 156 -- -> [(DrawAttributes, DrawAttributes, [(RPoint, RPoint)])] - 157 -- joinPairs _ _ [] = [] - 158 -- joinPairs _ [] _ = [] - 159 -- joinPairs corr [(x1,x2)] [(y1,y2)] = - 160 -- [(x1,y1, corr x2 y2)] - 161 -- joinPairs corr [(x1,x2)] yShapes = - 162 -- let x2s = splitPolyShape 0.001 (length yShapes) x2 - 163 -- in joinPairs corr (map (x1,) x2s) yShapes - 164 -- joinPairs corr xShapes [(y1,y2)] = - 165 -- let y2s = reverse $ splitPolyShape 0.001 (length xShapes) y2 - 166 -- in joinPairs corr xShapes (map (y1,) y2s) - 167 -- joinPairs corr ((x1,x2):xs) ((y1,y2):ys) = - 168 -- (x1,y1, corr x2 y2) : joinPairs corr xs ys - 169 -- joinPairs _ _ _ = [] - 170 - 171 -- FIXME: sort by size, smallest to largest - 172 toShapes :: Double -> SVG -> [(DrawAttributes, Polygon)] - 173 toShapes tol src = - 174 [ (attrs, plToPolygon tol shape) - 175 | (_, attrs, glyph) <- svgGlyphs $ lowerTransformations $ pathify src - 176 , shape <- map mergePolyShapeHoles $ plGroupShapes $ svgToPolyShapes glyph - 177 ] - 178 - 179 unsafeSVGToPolygon :: Double -> SVG -> Polygon - 180 unsafeSVGToPolygon tol src = snd $ head $ toShapes tol src - 181 - 182 annotatePolygons :: (Polygon -> SVG) -> SVG -> SVG - 183 annotatePolygons fn svg = mkGroup - 184 [ fn poly & drawAttributes .~ attr - 185 | (attr, poly) <- toShapes 0.001 svg - 186 ] + 130 (x,y) : genesisObjectCorrespondence xs ys + 131 where + 132 emptyFrom a b = mkPolygon $ V.map (const $ pCentroid a) (polygonPoints b) + 133 + 134 -- | Object-correspondence algorithm that duplicate objects as necessary. + 135 dupObjectCorrespondence :: ObjectCorrespondence + 136 dupObjectCorrespondence left right = + 137 case (left, right) of + 138 (_, []) -> [] + 139 ([], _) -> [] + 140 ([x], [y]) -> + 141 [(x,y)] + 142 ([(x1,x2)], yShapes) -> + 143 let x2s = replicate (length yShapes) x2 + 144 in dupObjectCorrespondence (map (x1,) x2s) yShapes + 145 (xShapes, [(y1,y2)]) -> + 146 let y2s = replicate (length xShapes) y2 + 147 in dupObjectCorrespondence xShapes (map (y1,) y2s) + 148 (x:xs, y:ys) -> + 149 (x, y) : dupObjectCorrespondence xs ys + 150 + 151 -- | Object-correspondence algorithm that splits objects in smaller pieces + 152 -- as necessary. + 153 splitObjectCorrespondence :: ObjectCorrespondence + 154 -- splitObjectCorrespondence = dupObjectCorrespondence + 155 splitObjectCorrespondence left right = + 156 case (left, right) of + 157 (_, []) -> [] + 158 ([], _) -> [] + 159 ([x], [y]) -> + 160 [(x,y)] + 161 ([(x1,x2)], yShapes) -> + 162 let x2s = splitPolygon (length yShapes) x2 + 163 in splitObjectCorrespondence (map (x1,) x2s) yShapes + 164 (xShapes, [(y1,y2)]) -> + 165 let y2s = splitPolygon (length xShapes) y2 + 166 in splitObjectCorrespondence xShapes (map (y1,) y2s) + 167 (x:xs, y:ys) -> + 168 (x,y) : splitObjectCorrespondence xs ys + 169 + 170 splitPolygon :: Int -> Polygon -> [Polygon] + 171 splitPolygon 1 p = [p] + 172 splitPolygon n p = + 173 let (a,b) = pCutEqual p + 174 in splitPolygon (n`div`2) a ++ splitPolygon ((n+1)`div`2) b + 175 + 176 -- joinPairs :: Correspondence -> [(DrawAttributes, PolyShape)] -> [(DrawAttributes, PolyShape)] + 177 -- -> [(DrawAttributes, DrawAttributes, [(RPoint, RPoint)])] + 178 -- joinPairs _ _ [] = [] + 179 -- joinPairs _ [] _ = [] + 180 -- joinPairs corr [(x1,x2)] [(y1,y2)] = + 181 -- [(x1,y1, corr x2 y2)] + 182 -- joinPairs corr [(x1,x2)] yShapes = + 183 -- let x2s = splitPolyShape 0.001 (length yShapes) x2 + 184 -- in joinPairs corr (map (x1,) x2s) yShapes + 185 -- joinPairs corr xShapes [(y1,y2)] = + 186 -- let y2s = reverse $ splitPolyShape 0.001 (length xShapes) y2 + 187 -- in joinPairs corr xShapes (map (y1,) y2s) + 188 -- joinPairs corr ((x1,x2):xs) ((y1,y2):ys) = + 189 -- (x1,y1, corr x2 y2) : joinPairs corr xs ys + 190 -- joinPairs _ _ _ = [] + 191 + 192 -- FIXME: sort by size, smallest to largest + 193 -- | Extract shapes and their graphical attributes from an SVG node. + 194 toShapes :: Double -> SVG -> [(DrawAttributes, Polygon)] + 195 toShapes tol src = + 196 [ (attrs, plToPolygon tol shape) + 197 | (_, attrs, glyph) <- svgGlyphs $ lowerTransformations $ pathify src + 198 , shape <- map mergePolyShapeHoles $ plGroupShapes $ svgToPolyShapes glyph + 199 ] + 200 + 201 -- | Extract the first polygon in an SVG node. Will fail if there + 202 -- are no acceptable shapes. + 203 unsafeSVGToPolygon :: Double -> SVG -> Polygon + 204 unsafeSVGToPolygon tol src = snd $ head $ toShapes tol src + 205 + 206 -- | Map over each polygon in an SVG node. + 207 annotatePolygons :: (Polygon -> SVG) -> SVG -> SVG + 208 annotatePolygons fn svg = mkGroup + 209 [ fn poly & drawAttributes .~ attr + 210 | (attr, poly) <- toShapes 0.001 svg + 211 ] diff --git a/reanimate-0.4.1.0-inplace/Reanimate.Scene.hs.html b/reanimate-0.4.1.0-inplace/Reanimate.Scene.hs.html index f2117cc..21cc3e3 100644 --- a/reanimate-0.4.1.0-inplace/Reanimate.Scene.hs.html +++ b/reanimate-0.4.1.0-inplace/Reanimate.Scene.hs.html @@ -147,1038 +147,1040 @@ span.spaces { background: white } 128 129 -- * ST internals 130 , liftST - 131 , asAnimation -- :: (forall s. Scene s a) -> Scene s Animation - 132 , transitionO - 133 , evalScene - 134 ) - 135 where - 136 - 137 import Control.Lens - 138 import Control.Monad (void) - 139 import Control.Monad.Fix - 140 import Control.Monad.ST - 141 import Control.Monad.State (execState, State) - 142 import Data.List - 143 import Data.STRef - 144 import Graphics.SvgTree (Tree (None)) - 145 import Reanimate.Animation - 146 import Reanimate.Ease (Signal, curveS, fromToS) - 147 import Reanimate.Effect - 148 import Reanimate.Svg.Constructors - 149 import Reanimate.Svg.BoundingBox - 150 import Reanimate.Transition - 151 import Reanimate.Morph.Common (morph) - 152 import Reanimate.Morph.Linear (linear) - 153 - 154 -- | The ZIndex property specifies the stack order of sprites and animations. Elements - 155 -- with a higher ZIndex will be drawn on top of elements with a lower index. - 156 type ZIndex = Int + 131 , transitionO + 132 , evalScene + 133 ) + 134 where + 135 + 136 import Control.Lens + 137 import Control.Monad (void) + 138 import Control.Monad.Fix + 139 import Control.Monad.ST + 140 import Control.Monad.State (execState, State) + 141 import Data.List + 142 import Data.STRef + 143 import Graphics.SvgTree (Tree (None)) + 144 import Reanimate.Animation + 145 import Reanimate.Ease (Signal, curveS, fromToS) + 146 import Reanimate.Effect + 147 import Reanimate.Svg.Constructors + 148 import Reanimate.Svg.BoundingBox + 149 import Reanimate.Transition + 150 import Reanimate.Morph.Common (morph) + 151 import Reanimate.Morph.Linear (linear) + 152 + 153 -- | The ZIndex property specifies the stack order of sprites and animations. Elements + 154 -- with a higher ZIndex will be drawn on top of elements with a lower index. + 155 type ZIndex = Int + 156 157 - 158 - 159 -- (seq duration, par duration) - 160 -- [(Time, Animation, ZIndex)] - 161 -- Map Time [(Animation, ZIndex)] - 162 type Gen s = ST s (Duration -> Time -> (SVG, ZIndex)) - 163 -- | A 'Scene' represents a sequence of animations and variables - 164 -- that change over time. - 165 newtype Scene s a = M { unM :: Time -> ST s (a, Duration, Duration, [Gen s]) } - 166 - 167 instance Functor (Scene s) where - 168 fmap f action = M $ \t -> do - 169 (a, d1, d2, gens) <- unM action t - 170 return (f a, d1, d2, gens) - 171 - 172 instance Applicative (Scene s) where - 173 pure a = M $ \_ -> return (a, 0, 0, []) - 174 f <*> g = M $ \t -> do - 175 (f', s1, p1, gen1) <- unM f t - 176 (g', s2, p2, gen2) <- unM g (t + s1) - 177 return (f' g', s1 + s2, max p1 (s1 + p2), gen1 ++ gen2) - 178 - 179 instance Monad (Scene s) where - 180 return = pure - 181 f >>= g = M $ \t -> do - 182 (a, s1, p1, gen1) <- unM f t - 183 (b, s2, p2, gen2) <- unM (g a) (t + s1) - 184 return (b, s1 + s2, max p1 (s1 + p2), gen1 ++ gen2) - 185 - 186 instance MonadFix (Scene s) where - 187 mfix fn = M $ \t -> mfix (\v -> let (a, _s, _p, _gens) = v in unM (fn a) t) - 188 + 158 -- (seq duration, par duration) + 159 -- [(Time, Animation, ZIndex)] + 160 -- Map Time [(Animation, ZIndex)] + 161 type Gen s = ST s (Duration -> Time -> (SVG, ZIndex)) + 162 -- | A 'Scene' represents a sequence of animations and variables + 163 -- that change over time. + 164 newtype Scene s a = M { unM :: Time -> ST s (a, Duration, Duration, [Gen s]) } + 165 + 166 instance Functor (Scene s) where + 167 fmap f action = M $ \t -> do + 168 (a, d1, d2, gens) <- unM action t + 169 return (f a, d1, d2, gens) + 170 + 171 instance Applicative (Scene s) where + 172 pure a = M $ \_ -> return (a, 0, 0, []) + 173 f <*> g = M $ \t -> do + 174 (f', s1, p1, gen1) <- unM f t + 175 (g', s2, p2, gen2) <- unM g (t + s1) + 176 return (f' g', s1 + s2, max p1 (s1 + p2), gen1 ++ gen2) + 177 + 178 instance Monad (Scene s) where + 179 return = pure + 180 f >>= g = M $ \t -> do + 181 (a, s1, p1, gen1) <- unM f t + 182 (b, s2, p2, gen2) <- unM (g a) (t + s1) + 183 return (b, s1 + s2, max p1 (s1 + p2), gen1 ++ gen2) + 184 + 185 instance MonadFix (Scene s) where + 186 mfix fn = M $ \t -> mfix (\v -> let (a, _s, _p, _gens) = v in unM (fn a) t) + 187 + 188 -- | Lift an ST action into the Scene monad. 189 liftST :: ST s a -> Scene s a 190 liftST action = M $ \_ -> action >>= \a -> return (a, 0, 0, []) 191 - 192 evalScene :: (forall s . Scene s a) -> a - 193 evalScene action = runST $ do - 194 (val, _, _ , _) <- unM action 0 - 195 return val - 196 - 197 -- | Render a 'Scene' to an 'Animation'. - 198 scene :: (forall s . Scene s a) -> Animation - 199 scene = sceneAnimation - 200 - 201 -- | Render a 'Scene' to an 'Animation'. - 202 sceneAnimation :: (forall s . Scene s a) -> Animation - 203 sceneAnimation action = runST - 204 (do - 205 (_, s, p, gens) <- unM action 0 - 206 let dur = max s p - 207 genFns <- sequence gens - 208 return $ mkAnimation - 209 dur - 210 (\t -> mkGroup $ map fst $ sortOn - 211 snd - 212 [ spriteRender dur (t * dur) | spriteRender <- genFns ] - 213 ) - 214 ) - 215 - 216 -- | Execute actions in a scene without advancing the clock. Note that scenes do not end before - 217 -- all forked actions have completed. - 218 -- - 219 -- Example: - 220 -- - 221 -- > do fork $ play drawBox - 222 -- > play drawCircle - 223 -- - 224 -- <<docs/gifs/doc_fork.gif>> - 225 fork :: Scene s a -> Scene s a - 226 fork (M action) = M $ \t -> do - 227 (a, s, p, gens) <- action t - 228 return (a, 0, max s p, gens) - 229 - 230 -- | Play an animation once and then remove it. This advances the clock by the duration of the - 231 -- animation. - 232 -- - 233 -- Example: - 234 -- - 235 -- > do play drawBox - 236 -- > play drawCircle - 237 -- - 238 -- <<docs/gifs/doc_play.gif>> - 239 play :: Animation -> Scene s () - 240 play ani = newSpriteA ani >>= destroySprite - 241 - 242 -- | Query the current clock timestamp. - 243 -- - 244 -- Example: - 245 -- - 246 -- > do now <- play drawCircle *> queryNow - 247 -- > play $ staticFrame 1 $ scale 2 $ withStrokeWidth 0.05 $ - 248 -- > mkText $ "Now=" <> T.pack (show now) - 249 -- - 250 -- <<docs/gifs/doc_queryNow.gif>> - 251 queryNow :: Scene s Time - 252 queryNow = M $ \t -> return (t, 0, 0, []) - 253 - 254 -- | Advance the clock by a given number of seconds. - 255 -- - 256 -- Example: - 257 -- - 258 -- > do fork $ play drawBox - 259 -- > wait 1 - 260 -- > play drawCircle - 261 -- - 262 -- <<docs/gifs/doc_wait.gif>> - 263 wait :: Duration -> Scene s () - 264 wait d = M $ \_ -> return ((), d, 0, []) - 265 - 266 -- | Wait until the clock is equal to the given timestamp. - 267 waitUntil :: Time -> Scene s () - 268 waitUntil tNew = do - 269 now <- queryNow - 270 wait (max 0 (tNew - now)) - 271 - 272 -- | Wait until all forked and sequential animations have finished. - 273 -- - 274 -- Example: - 275 -- - 276 -- > do waitOn $ fork $ play drawBox - 277 -- > play drawCircle - 278 -- - 279 -- <<docs/gifs/doc_waitOn.gif>> - 280 waitOn :: Scene s a -> Scene s a - 281 waitOn (M action) = M $ \t -> do - 282 (a, s, p, gens) <- action t - 283 return (a, max s p, 0, gens) - 284 - 285 -- | Change the ZIndex of a scene. - 286 adjustZ :: (ZIndex -> ZIndex) -> Scene s a -> Scene s a - 287 adjustZ fn (M action) = M $ \t -> do - 288 (a, s, p, gens) <- action t - 289 return (a, s, p, map genFn gens) - 290 where - 291 genFn gen = do - 292 frameGen <- gen - 293 return $ \d t -> let (svg, z) = frameGen d t in (svg, fn z) - 294 - 295 -- | Query the duration of a scene. - 296 withSceneDuration :: Scene s () -> Scene s Duration - 297 withSceneDuration s = do - 298 t1 <- queryNow - 299 s - 300 t2 <- queryNow - 301 return (t2 - t1) - 302 - 303 addGen :: Gen s -> Scene s () - 304 addGen gen = M $ \_ -> return ((), 0, 0, [gen]) - 305 - 306 -- | Time dependent variable. - 307 newtype Var s a = Var (STRef s (Time -> a)) - 308 - 309 -- | Create a new variable with a default value. - 310 -- Variables always have a defined value even if they are read at a timestamp that is - 311 -- earlier than when the variable was created. For example: - 312 -- - 313 -- > do v <- fork (wait 10 >> newVar 0) -- Create a variable at timestamp '10'. - 314 -- > readVar v -- Read the variable at timestamp '0'. - 315 -- > -- The value of the variable will be '0'. - 316 newVar :: a -> Scene s (Var s a) - 317 newVar def = Var <$> liftST (newSTRef (const def)) - 318 - 319 -- | Read the value of a variable at the current timestamp. - 320 readVar :: Var s a -> Scene s a - 321 readVar (Var ref) = liftST (readSTRef ref) <*> queryNow - 322 - 323 -- | Write the value of a variable at the current timestamp. - 324 -- - 325 -- Example: - 326 -- - 327 -- > do v <- newVar 0 - 328 -- > newSprite $ mkCircle <$> unVar v - 329 -- > writeVar v 1; wait 1 - 330 -- > writeVar v 2; wait 1 - 331 -- > writeVar v 3; wait 1 - 332 -- - 333 -- <<docs/gifs/doc_writeVar.gif>> - 334 writeVar :: Var s a -> a -> Scene s () - 335 writeVar var val = modifyVar var (const val) - 336 - 337 -- | Modify the value of a variable at the current timestamp and all future timestamps. - 338 modifyVar :: Var s a -> (a -> a) -> Scene s () - 339 modifyVar (Var ref) fn = do - 340 now <- queryNow - 341 liftST $ modifySTRef ref $ \prev t -> if t < now then prev t else fn (prev t) - 342 - 343 -- | Modify a variable between @now@ and @now+duration@. - 344 -- Note: The modification function is invoked for past timestamps (with a time value of 0) and - 345 -- for timestamps after @now+duration@ (with a time value of 1). See 'tweenVarUnclamped'. - 346 tweenVar :: Var s a -> Duration -> (a -> Time -> a) -> Scene s () - 347 tweenVar (Var ref) dur fn = do - 348 now <- queryNow - 349 liftST $ modifySTRef ref $ \prev t -> - 350 if t < now - 351 then prev t - 352 else fn (prev t) (max 0 (min dur $ t - now) / dur) - 353 wait dur - 354 - 355 -- | Modify a variable between @now@ and @now+duration@. - 356 -- Note: The modification function is invoked for past timestamps (with a negative time value) and - 357 -- for timestamps after @now+duration@ (with a time value greater than 1). - 358 tweenVarUnclamped :: Var s a -> Duration -> (a -> Time -> a) -> Scene s () - 359 tweenVarUnclamped (Var ref) dur fn = do - 360 now <- queryNow - 361 liftST $ modifySTRef ref $ \prev t -> fn (prev t) ((t - now) / dur) - 362 wait dur - 363 - 364 -- | Create and render a variable. The rendering will be born at the current timestamp - 365 -- and will persist until the end of the scene. - 366 -- - 367 -- Example: - 368 -- - 369 -- > do var <- simpleVar mkCircle 0 - 370 -- > tweenVar var 2 $ \val -> fromToS val (screenHeight/2) - 371 -- - 372 -- <<docs/gifs/doc_simpleVar.gif>> - 373 simpleVar :: (a -> SVG) -> a -> Scene s (Var s a) - 374 simpleVar render def = do - 375 v <- newVar def - 376 _ <- newSprite $ render <$> unVar v - 377 return v - 378 - 379 -- | Helper function for filtering variables. - 380 findVar :: (a -> Bool) -> [Var s a] -> Scene s (Var s a) - 381 findVar _cond [] = error "Variable not found." - 382 findVar cond (v : vs) = do - 383 val <- readVar v - 384 if cond val then return v else findVar cond vs - 385 - 386 -- | Sprites are animations with a given time of birth as well as a time of death. - 387 -- They can be controlled using variables, tweening, and effects. - 388 data Sprite s = Sprite Time (STRef s (Duration, ST s (Duration -> Time -> SVG -> (SVG, ZIndex)))) - 389 - 390 -- | Sprite frame generator. Generates frames over time in a stateful environment. - 391 newtype Frame s a = Frame { unFrame :: ST s (Time -> Duration -> Time -> a) } - 392 - 393 instance Functor (Frame s) where - 394 fmap fn (Frame gen) = Frame $ do - 395 m <- gen - 396 return (\real_t d t -> fn $ m real_t d t) - 397 - 398 instance Applicative (Frame s) where - 399 pure v = Frame $ return (\_ _ _ -> v) - 400 Frame f <*> Frame g = Frame $ do - 401 m1 <- f - 402 m2 <- g - 403 return $ \real_t d t -> m1 real_t d t (m2 real_t d t) - 404 - 405 -- | Dereference a variable as a Sprite frame. - 406 -- - 407 -- Example: - 408 -- - 409 -- > do v <- newVar 0 - 410 -- > newSprite $ mkCircle <$> unVar v - 411 -- > tweenVar v 1 $ \val -> fromToS val 3 - 412 -- > tweenVar v 1 $ \val -> fromToS val 0 - 413 -- - 414 -- <<docs/gifs/doc_unVar.gif>> - 415 unVar :: Var s a -> Frame s a - 416 unVar (Var ref) = Frame $ do - 417 fn <- readSTRef ref - 418 return $ \real_t _d _t -> fn real_t - 419 + 192 -- | Evaluate the value of a scene. + 193 evalScene :: (forall s . Scene s a) -> a + 194 evalScene action = runST $ do + 195 (val, _, _ , _) <- unM action 0 + 196 return val + 197 + 198 -- | Render a 'Scene' to an 'Animation'. + 199 scene :: (forall s . Scene s a) -> Animation + 200 scene = sceneAnimation + 201 + 202 -- | Render a 'Scene' to an 'Animation'. + 203 sceneAnimation :: (forall s . Scene s a) -> Animation + 204 sceneAnimation action = runST + 205 (do + 206 (_, s, p, gens) <- unM action 0 + 207 let dur = max s p + 208 genFns <- sequence gens + 209 return $ mkAnimation + 210 dur + 211 (\t -> mkGroup $ map fst $ sortOn + 212 snd + 213 [ spriteRender dur (t * dur) | spriteRender <- genFns ] + 214 ) + 215 ) + 216 + 217 -- | Execute actions in a scene without advancing the clock. Note that scenes do not end before + 218 -- all forked actions have completed. + 219 -- + 220 -- Example: + 221 -- + 222 -- > do fork $ play drawBox + 223 -- > play drawCircle + 224 -- + 225 -- <<docs/gifs/doc_fork.gif>> + 226 fork :: Scene s a -> Scene s a + 227 fork (M action) = M $ \t -> do + 228 (a, s, p, gens) <- action t + 229 return (a, 0, max s p, gens) + 230 + 231 -- | Play an animation once and then remove it. This advances the clock by the duration of the + 232 -- animation. + 233 -- + 234 -- Example: + 235 -- + 236 -- > do play drawBox + 237 -- > play drawCircle + 238 -- + 239 -- <<docs/gifs/doc_play.gif>> + 240 play :: Animation -> Scene s () + 241 play ani = newSpriteA ani >>= destroySprite + 242 + 243 -- | Query the current clock timestamp. + 244 -- + 245 -- Example: + 246 -- + 247 -- > do now <- play drawCircle *> queryNow + 248 -- > play $ staticFrame 1 $ scale 2 $ withStrokeWidth 0.05 $ + 249 -- > mkText $ "Now=" <> T.pack (show now) + 250 -- + 251 -- <<docs/gifs/doc_queryNow.gif>> + 252 queryNow :: Scene s Time + 253 queryNow = M $ \t -> return (t, 0, 0, []) + 254 + 255 -- | Advance the clock by a given number of seconds. + 256 -- + 257 -- Example: + 258 -- + 259 -- > do fork $ play drawBox + 260 -- > wait 1 + 261 -- > play drawCircle + 262 -- + 263 -- <<docs/gifs/doc_wait.gif>> + 264 wait :: Duration -> Scene s () + 265 wait d = M $ \_ -> return ((), d, 0, []) + 266 + 267 -- | Wait until the clock is equal to the given timestamp. + 268 waitUntil :: Time -> Scene s () + 269 waitUntil tNew = do + 270 now <- queryNow + 271 wait (max 0 (tNew - now)) + 272 + 273 -- | Wait until all forked and sequential animations have finished. + 274 -- + 275 -- Example: + 276 -- + 277 -- > do waitOn $ fork $ play drawBox + 278 -- > play drawCircle + 279 -- + 280 -- <<docs/gifs/doc_waitOn.gif>> + 281 waitOn :: Scene s a -> Scene s a + 282 waitOn (M action) = M $ \t -> do + 283 (a, s, p, gens) <- action t + 284 return (a, max s p, 0, gens) + 285 + 286 -- | Change the ZIndex of a scene. + 287 adjustZ :: (ZIndex -> ZIndex) -> Scene s a -> Scene s a + 288 adjustZ fn (M action) = M $ \t -> do + 289 (a, s, p, gens) <- action t + 290 return (a, s, p, map genFn gens) + 291 where + 292 genFn gen = do + 293 frameGen <- gen + 294 return $ \d t -> let (svg, z) = frameGen d t in (svg, fn z) + 295 + 296 -- | Query the duration of a scene. + 297 withSceneDuration :: Scene s () -> Scene s Duration + 298 withSceneDuration s = do + 299 t1 <- queryNow + 300 s + 301 t2 <- queryNow + 302 return (t2 - t1) + 303 + 304 addGen :: Gen s -> Scene s () + 305 addGen gen = M $ \_ -> return ((), 0, 0, [gen]) + 306 + 307 -- | Time dependent variable. + 308 newtype Var s a = Var (STRef s (Time -> a)) + 309 + 310 -- | Create a new variable with a default value. + 311 -- Variables always have a defined value even if they are read at a timestamp that is + 312 -- earlier than when the variable was created. For example: + 313 -- + 314 -- > do v <- fork (wait 10 >> newVar 0) -- Create a variable at timestamp '10'. + 315 -- > readVar v -- Read the variable at timestamp '0'. + 316 -- > -- The value of the variable will be '0'. + 317 newVar :: a -> Scene s (Var s a) + 318 newVar def = Var <$> liftST (newSTRef (const def)) + 319 + 320 -- | Read the value of a variable at the current timestamp. + 321 readVar :: Var s a -> Scene s a + 322 readVar (Var ref) = liftST (readSTRef ref) <*> queryNow + 323 + 324 -- | Write the value of a variable at the current timestamp. + 325 -- + 326 -- Example: + 327 -- + 328 -- > do v <- newVar 0 + 329 -- > newSprite $ mkCircle <$> unVar v + 330 -- > writeVar v 1; wait 1 + 331 -- > writeVar v 2; wait 1 + 332 -- > writeVar v 3; wait 1 + 333 -- + 334 -- <<docs/gifs/doc_writeVar.gif>> + 335 writeVar :: Var s a -> a -> Scene s () + 336 writeVar var val = modifyVar var (const val) + 337 + 338 -- | Modify the value of a variable at the current timestamp and all future timestamps. + 339 modifyVar :: Var s a -> (a -> a) -> Scene s () + 340 modifyVar (Var ref) fn = do + 341 now <- queryNow + 342 liftST $ modifySTRef ref $ \prev t -> if t < now then prev t else fn (prev t) + 343 + 344 -- | Modify a variable between @now@ and @now+duration@. + 345 -- Note: The modification function is invoked for past timestamps (with a time value of 0) and + 346 -- for timestamps after @now+duration@ (with a time value of 1). See 'tweenVarUnclamped'. + 347 tweenVar :: Var s a -> Duration -> (a -> Time -> a) -> Scene s () + 348 tweenVar (Var ref) dur fn = do + 349 now <- queryNow + 350 liftST $ modifySTRef ref $ \prev t -> + 351 if t < now + 352 then prev t + 353 else fn (prev t) (max 0 (min dur $ t - now) / dur) + 354 wait dur + 355 + 356 -- | Modify a variable between @now@ and @now+duration@. + 357 -- Note: The modification function is invoked for past timestamps (with a negative time value) and + 358 -- for timestamps after @now+duration@ (with a time value greater than 1). + 359 tweenVarUnclamped :: Var s a -> Duration -> (a -> Time -> a) -> Scene s () + 360 tweenVarUnclamped (Var ref) dur fn = do + 361 now <- queryNow + 362 liftST $ modifySTRef ref $ \prev t -> fn (prev t) ((t - now) / dur) + 363 wait dur + 364 + 365 -- | Create and render a variable. The rendering will be born at the current timestamp + 366 -- and will persist until the end of the scene. + 367 -- + 368 -- Example: + 369 -- + 370 -- > do var <- simpleVar mkCircle 0 + 371 -- > tweenVar var 2 $ \val -> fromToS val (screenHeight/2) + 372 -- + 373 -- <<docs/gifs/doc_simpleVar.gif>> + 374 simpleVar :: (a -> SVG) -> a -> Scene s (Var s a) + 375 simpleVar render def = do + 376 v <- newVar def + 377 _ <- newSprite $ render <$> unVar v + 378 return v + 379 + 380 -- | Helper function for filtering variables. + 381 findVar :: (a -> Bool) -> [Var s a] -> Scene s (Var s a) + 382 findVar _cond [] = error "Variable not found." + 383 findVar cond (v : vs) = do + 384 val <- readVar v + 385 if cond val then return v else findVar cond vs + 386 + 387 -- | Sprites are animations with a given time of birth as well as a time of death. + 388 -- They can be controlled using variables, tweening, and effects. + 389 data Sprite s = Sprite Time (STRef s (Duration, ST s (Duration -> Time -> SVG -> (SVG, ZIndex)))) + 390 + 391 -- | Sprite frame generator. Generates frames over time in a stateful environment. + 392 newtype Frame s a = Frame { unFrame :: ST s (Time -> Duration -> Time -> a) } + 393 + 394 instance Functor (Frame s) where + 395 fmap fn (Frame gen) = Frame $ do + 396 m <- gen + 397 return (\real_t d t -> fn $ m real_t d t) + 398 + 399 instance Applicative (Frame s) where + 400 pure v = Frame $ return (\_ _ _ -> v) + 401 Frame f <*> Frame g = Frame $ do + 402 m1 <- f + 403 m2 <- g + 404 return $ \real_t d t -> m1 real_t d t (m2 real_t d t) + 405 + 406 -- | Dereference a variable as a Sprite frame. + 407 -- + 408 -- Example: + 409 -- + 410 -- > do v <- newVar 0 + 411 -- > newSprite $ mkCircle <$> unVar v + 412 -- > tweenVar v 1 $ \val -> fromToS val 3 + 413 -- > tweenVar v 1 $ \val -> fromToS val 0 + 414 -- + 415 -- <<docs/gifs/doc_unVar.gif>> + 416 unVar :: Var s a -> Frame s a + 417 unVar (Var ref) = Frame $ do + 418 fn <- readSTRef ref + 419 return $ \real_t _d _t -> fn real_t 420 - 421 -- | Dereference seconds since sprite birth. - 422 spriteT :: Frame s Time - 423 spriteT = Frame $ return (\_real_t _d t -> t) - 424 - 425 -- | Dereference duration of the current sprite. - 426 spriteDuration :: Frame s Duration - 427 spriteDuration = Frame $ return (\_real_t d _t -> d) - 428 - 429 -- | Create new sprite defined by a frame generator. Unless otherwise specified using - 430 -- 'destroySprite', the sprite will die at the end of the scene. - 431 -- - 432 -- Example: - 433 -- - 434 -- > do newSprite $ mkCircle <$> spriteT -- Circle sprite where radius=time. - 435 -- > wait 2 - 436 -- - 437 -- <<docs/gifs/doc_newSprite.gif>> - 438 newSprite :: Frame s SVG -> Scene s (Sprite s) - 439 newSprite render = do - 440 now <- queryNow - 441 ref <- liftST $ newSTRef (-1, return $ \_d _t svg -> (svg, 0)) - 442 addGen $ do - 443 fn <- unFrame render - 444 (spriteDur, spriteEffectGen) <- readSTRef ref - 445 spriteEffect <- spriteEffectGen - 446 return $ \d absT -> - 447 let relD = (if spriteDur < 0 then d else spriteDur) - now - 448 relT = absT - now - 449 -- Sprite is live [now;duration[ - 450 -- If we're at the end of a scene, sprites - 451 -- are live: [now;duration] - 452 -- This behavior is difficult to get right. See the 'bug_*' examples for - 453 -- automated tests. - 454 inTimeSlice = relT >= 0 && relT < relD - 455 isLastFrame = d==absT && relT == relD - 456 in if inTimeSlice || isLastFrame - 457 then spriteEffect relD relT (fn absT relD relT) - 458 else (None, 0) - 459 return $ Sprite now ref - 460 - 461 -- | Create new sprite defined by a frame generator. The sprite will die at - 462 -- the end of the scene. - 463 newSprite_ :: Frame s SVG -> Scene s () - 464 newSprite_ = void . newSprite - 465 - 466 -- | Create a new sprite from an animation. This advances the clock by the - 467 -- duration of the animation. Unless otherwise specified using - 468 -- 'destroySprite', the sprite will die at the end of the scene. - 469 -- - 470 -- Note: If the scene doesn't end immediately after the duration of the - 471 -- animation, the animation will be stretched to match the lifetime of the - 472 -- sprite. See 'newSpriteA'' and 'play'. - 473 -- - 474 -- Example: - 475 -- - 476 -- > do fork $ newSpriteA drawCircle - 477 -- > play drawBox - 478 -- > play $ reverseA drawBox - 479 -- - 480 -- <<docs/gifs/doc_newSpriteA.gif>> - 481 newSpriteA :: Animation -> Scene s (Sprite s) - 482 newSpriteA = newSpriteA' SyncStretch - 483 - 484 -- | Create a new sprite from an animation and specify the synchronization policy. This advances - 485 -- the clock by the duration of the animation. - 486 -- - 487 -- Example: - 488 -- - 489 -- > do fork $ newSpriteA' SyncFreeze drawCircle - 490 -- > play drawBox - 491 -- > play $ reverseA drawBox - 492 -- - 493 -- <<docs/gifs/doc_newSpriteA'.gif>> - 494 newSpriteA' :: Sync -> Animation -> Scene s (Sprite s) - 495 newSpriteA' sync animation = - 496 newSprite (getAnimationFrame sync animation <$> spriteT <*> spriteDuration) - 497 <* wait (duration animation) - 498 - 499 -- | Create a sprite from a static SVG image. - 500 -- - 501 -- Example: - 502 -- - 503 -- > do newSpriteSVG $ mkBackground "lightblue" - 504 -- > play drawCircle - 505 -- - 506 -- <<docs/gifs/doc_newSpriteSVG.gif>> - 507 newSpriteSVG :: SVG -> Scene s (Sprite s) - 508 newSpriteSVG = newSprite . pure - 509 - 510 -- | Create a permanent sprite from a static SVG image. Same as `newSpriteSVG` - 511 -- but the sprite isn't returned and thus cannot be destroyed. - 512 newSpriteSVG_ :: SVG -> Scene s () - 513 newSpriteSVG_ = void . newSpriteSVG - 514 - 515 -- | Change the rendering of a sprite using data from a variable. If data from several variables - 516 -- is needed, use a frame generator instead. - 517 -- - 518 -- Example: - 519 -- - 520 -- > do s <- fork $ newSpriteA drawBox - 521 -- > v <- newVar 0 - 522 -- > applyVar v s rotate - 523 -- > tweenVar v 2 $ \val -> fromToS val 90 - 524 -- - 525 -- <<docs/gifs/doc_applyVar.gif>> - 526 applyVar :: Var s a -> Sprite s -> (a -> SVG -> SVG) -> Scene s () - 527 applyVar var sprite fn = spriteModify sprite $ do - 528 varFn <- unVar var - 529 return $ \(svg, zindex) -> (fn varFn svg, zindex) - 530 - 531 -- | Destroy a sprite, preventing it from being rendered in the future of the scene. - 532 -- If 'destroySprite' is invoked multiple times, the earliest time-of-death is used. - 533 -- - 534 -- Example: - 535 -- - 536 -- > do s <- newSpriteSVG $ withFillOpacity 1 $ mkCircle 1 - 537 -- > fork $ wait 1 >> destroySprite s - 538 -- > play drawBox - 539 -- - 540 -- <<docs/gifs/doc_destroySprite.gif>> - 541 destroySprite :: Sprite s -> Scene s () - 542 destroySprite (Sprite _ ref) = do - 543 now <- queryNow - 544 liftST $ modifySTRef ref $ \(ttl, render) -> - 545 (if ttl < 0 then now else min ttl now, render) - 546 - 547 -- | Low-level frame modifier. - 548 spriteModify :: Sprite s -> Frame s ((SVG, ZIndex) -> (SVG, ZIndex)) -> Scene s () - 549 spriteModify (Sprite born ref) modFn = liftST $ modifySTRef ref $ \(ttl, renderGen) -> - 550 ( ttl - 551 , do - 552 render <- renderGen - 553 modRender <- unFrame modFn - 554 return $ \relD relT -> - 555 let absT = relT + born in modRender absT relD relT . render relD relT - 556 ) - 557 - 558 -- | Map the SVG output of a sprite. - 559 -- - 560 -- Example: - 561 -- - 562 -- > do s <- fork $ newSpriteA drawCircle - 563 -- > wait 1 - 564 -- > spriteMap s flipYAxis - 565 -- - 566 -- <<docs/gifs/doc_spriteMap.gif>> - 567 spriteMap :: Sprite s -> (SVG -> SVG) -> Scene s () - 568 spriteMap sprite@(Sprite born _) fn = do - 569 now <- queryNow - 570 let tDelta = now - born - 571 spriteModify sprite $ do - 572 t <- spriteT - 573 return $ \(svg, zindex) -> (if (t - tDelta) < 0 then svg else fn svg, zindex) - 574 - 575 -- | Modify the output of a sprite between @now@ and @now+duration@. - 576 -- - 577 -- Example: - 578 -- - 579 -- > do s <- fork $ newSpriteA drawCircle - 580 -- > spriteTween s 1 $ \val -> translate (screenWidth*0.3*val) 0 - 581 -- - 582 -- <<docs/gifs/doc_spriteTween.gif>> - 583 spriteTween :: Sprite s -> Duration -> (Double -> SVG -> SVG) -> Scene s () - 584 spriteTween sprite@(Sprite born _) dur fn = do - 585 now <- queryNow - 586 let tDelta = now - born - 587 spriteModify sprite $ do - 588 t <- spriteT - 589 return $ \(svg, zindex) -> (fn (clamp 0 1 $ (t - tDelta) / dur) svg, zindex) - 590 wait dur - 591 where - 592 clamp a b v | v < a = a - 593 | v > b = b - 594 | otherwise = v - 595 - 596 -- | Create a new variable and apply it to a sprite. - 597 -- - 598 -- Example: - 599 -- - 600 -- > do s <- fork $ newSpriteA drawBox - 601 -- > v <- spriteVar s 0 rotate - 602 -- > tweenVar v 2 $ \val -> fromToS val 90 - 603 -- - 604 -- <<docs/gifs/doc_spriteVar.gif>> - 605 spriteVar :: Sprite s -> a -> (a -> SVG -> SVG) -> Scene s (Var s a) - 606 spriteVar sprite def fn = do - 607 v <- newVar def - 608 applyVar v sprite fn - 609 return v - 610 - 611 -- | Apply an effect to a sprite. - 612 -- - 613 -- Example: - 614 -- - 615 -- > do s <- fork $ newSpriteA drawCircle - 616 -- > spriteE s $ overBeginning 1 fadeInE - 617 -- > spriteE s $ overEnding 0.5 fadeOutE - 618 -- - 619 -- <<docs/gifs/doc_spriteE.gif>> - 620 spriteE :: Sprite s -> Effect -> Scene s () - 621 spriteE (Sprite born ref) effect = do - 622 now <- queryNow - 623 liftST $ modifySTRef ref $ \(ttl, renderGen) -> - 624 ( ttl - 625 , do - 626 render <- renderGen - 627 return $ \d t svg -> - 628 let (svg', z) = render d t svg - 629 in (delayE (max 0 $ now - born) effect d t svg', z) - 630 ) - 631 - 632 -- | Set new ZIndex of a sprite. - 633 -- - 634 -- Example: - 635 -- - 636 -- > do s1 <- newSpriteSVG $ withFillOpacity 1 $ withFillColor "blue" $ mkCircle 3 - 637 -- > newSpriteSVG $ withFillOpacity 1 $ withFillColor "red" $ mkRect 8 3 - 638 -- > wait 1 - 639 -- > spriteZ s1 1 - 640 -- > wait 1 - 641 -- - 642 -- <<docs/gifs/doc_spriteZ.gif>> - 643 spriteZ :: Sprite s -> ZIndex -> Scene s () - 644 spriteZ (Sprite born ref) zindex = do - 645 now <- queryNow - 646 liftST $ modifySTRef ref $ \(ttl, renderGen) -> - 647 ( ttl - 648 , do - 649 render <- renderGen - 650 return $ \d t svg -> - 651 let (svg', z) = render d t svg in (svg', if t < now - born then z else zindex) - 652 ) - 653 - 654 -- | Destroy all local sprites at the end of a scene. - 655 -- - 656 -- Example: - 657 -- - 658 -- > do -- the rect lives through the entire 3s animation - 659 -- > newSpriteSVG_ $ translate (-3) 0 $ mkRect 4 4 - 660 -- > wait 1 - 661 -- > spriteScope $ do - 662 -- > -- the circle only lives for 1 second. - 663 -- > local <- newSpriteSVG $ translate 3 0 $ mkCircle 2 - 664 -- > spriteE local $ overBeginning 0.3 fadeInE - 665 -- > spriteE local $ overEnding 0.3 fadeOutE - 666 -- > wait 1 - 667 -- > wait 1 - 668 -- - 669 -- <<docs/gifs/doc_spriteScope.gif>> - 670 spriteScope :: Scene s a -> Scene s a - 671 spriteScope (M action) = M $ \t -> do - 672 (a, s, p, gens) <- action t - 673 return (a, s, p, map (genFn (t+max s p)) gens) - 674 where - 675 genFn maxT gen = do - 676 frameGen <- gen - 677 return $ \_ t -> - 678 if t < maxT - 679 then frameGen maxT t - 680 else (None, 0) - 681 - 682 asAnimation :: (forall s'. Scene s' a) -> Scene s Animation - 683 asAnimation s = do - 684 now <- queryNow - 685 return $ dropA now (sceneAnimation (wait now >> s)) - 686 - 687 transitionO :: Transition -> Double -> (forall s'. Scene s' a) -> (forall s'. Scene s' b) -> Scene s () - 688 transitionO t o a b = do - 689 aA <- asAnimation a - 690 bA <- fork $ do - 691 wait (duration aA - o) - 692 asAnimation b - 693 play $ overlapT o t aA bA - 694 + 421 + 422 -- | Dereference seconds since sprite birth. + 423 spriteT :: Frame s Time + 424 spriteT = Frame $ return (\_real_t _d t -> t) + 425 + 426 -- | Dereference duration of the current sprite. + 427 spriteDuration :: Frame s Duration + 428 spriteDuration = Frame $ return (\_real_t d _t -> d) + 429 + 430 -- | Create new sprite defined by a frame generator. Unless otherwise specified using + 431 -- 'destroySprite', the sprite will die at the end of the scene. + 432 -- + 433 -- Example: + 434 -- + 435 -- > do newSprite $ mkCircle <$> spriteT -- Circle sprite where radius=time. + 436 -- > wait 2 + 437 -- + 438 -- <<docs/gifs/doc_newSprite.gif>> + 439 newSprite :: Frame s SVG -> Scene s (Sprite s) + 440 newSprite render = do + 441 now <- queryNow + 442 ref <- liftST $ newSTRef (-1, return $ \_d _t svg -> (svg, 0)) + 443 addGen $ do + 444 fn <- unFrame render + 445 (spriteDur, spriteEffectGen) <- readSTRef ref + 446 spriteEffect <- spriteEffectGen + 447 return $ \d absT -> + 448 let relD = (if spriteDur < 0 then d else spriteDur) - now + 449 relT = absT - now + 450 -- Sprite is live [now;duration[ + 451 -- If we're at the end of a scene, sprites + 452 -- are live: [now;duration] + 453 -- This behavior is difficult to get right. See the 'bug_*' examples for + 454 -- automated tests. + 455 inTimeSlice = relT >= 0 && relT < relD + 456 isLastFrame = d==absT && relT == relD + 457 in if inTimeSlice || isLastFrame + 458 then spriteEffect relD relT (fn absT relD relT) + 459 else (None, 0) + 460 return $ Sprite now ref + 461 + 462 -- | Create new sprite defined by a frame generator. The sprite will die at + 463 -- the end of the scene. + 464 newSprite_ :: Frame s SVG -> Scene s () + 465 newSprite_ = void . newSprite + 466 + 467 -- | Create a new sprite from an animation. This advances the clock by the + 468 -- duration of the animation. Unless otherwise specified using + 469 -- 'destroySprite', the sprite will die at the end of the scene. + 470 -- + 471 -- Note: If the scene doesn't end immediately after the duration of the + 472 -- animation, the animation will be stretched to match the lifetime of the + 473 -- sprite. See 'newSpriteA'' and 'play'. + 474 -- + 475 -- Example: + 476 -- + 477 -- > do fork $ newSpriteA drawCircle + 478 -- > play drawBox + 479 -- > play $ reverseA drawBox + 480 -- + 481 -- <<docs/gifs/doc_newSpriteA.gif>> + 482 newSpriteA :: Animation -> Scene s (Sprite s) + 483 newSpriteA = newSpriteA' SyncStretch + 484 + 485 -- | Create a new sprite from an animation and specify the synchronization policy. This advances + 486 -- the clock by the duration of the animation. + 487 -- + 488 -- Example: + 489 -- + 490 -- > do fork $ newSpriteA' SyncFreeze drawCircle + 491 -- > play drawBox + 492 -- > play $ reverseA drawBox + 493 -- + 494 -- <<docs/gifs/doc_newSpriteA'.gif>> + 495 newSpriteA' :: Sync -> Animation -> Scene s (Sprite s) + 496 newSpriteA' sync animation = + 497 newSprite (getAnimationFrame sync animation <$> spriteT <*> spriteDuration) + 498 <* wait (duration animation) + 499 + 500 -- | Create a sprite from a static SVG image. + 501 -- + 502 -- Example: + 503 -- + 504 -- > do newSpriteSVG $ mkBackground "lightblue" + 505 -- > play drawCircle + 506 -- + 507 -- <<docs/gifs/doc_newSpriteSVG.gif>> + 508 newSpriteSVG :: SVG -> Scene s (Sprite s) + 509 newSpriteSVG = newSprite . pure + 510 + 511 -- | Create a permanent sprite from a static SVG image. Same as `newSpriteSVG` + 512 -- but the sprite isn't returned and thus cannot be destroyed. + 513 newSpriteSVG_ :: SVG -> Scene s () + 514 newSpriteSVG_ = void . newSpriteSVG + 515 + 516 -- | Change the rendering of a sprite using data from a variable. If data from several variables + 517 -- is needed, use a frame generator instead. + 518 -- + 519 -- Example: + 520 -- + 521 -- > do s <- fork $ newSpriteA drawBox + 522 -- > v <- newVar 0 + 523 -- > applyVar v s rotate + 524 -- > tweenVar v 2 $ \val -> fromToS val 90 + 525 -- + 526 -- <<docs/gifs/doc_applyVar.gif>> + 527 applyVar :: Var s a -> Sprite s -> (a -> SVG -> SVG) -> Scene s () + 528 applyVar var sprite fn = spriteModify sprite $ do + 529 varFn <- unVar var + 530 return $ \(svg, zindex) -> (fn varFn svg, zindex) + 531 + 532 -- | Destroy a sprite, preventing it from being rendered in the future of the scene. + 533 -- If 'destroySprite' is invoked multiple times, the earliest time-of-death is used. + 534 -- + 535 -- Example: + 536 -- + 537 -- > do s <- newSpriteSVG $ withFillOpacity 1 $ mkCircle 1 + 538 -- > fork $ wait 1 >> destroySprite s + 539 -- > play drawBox + 540 -- + 541 -- <<docs/gifs/doc_destroySprite.gif>> + 542 destroySprite :: Sprite s -> Scene s () + 543 destroySprite (Sprite _ ref) = do + 544 now <- queryNow + 545 liftST $ modifySTRef ref $ \(ttl, render) -> + 546 (if ttl < 0 then now else min ttl now, render) + 547 + 548 -- | Low-level frame modifier. + 549 spriteModify :: Sprite s -> Frame s ((SVG, ZIndex) -> (SVG, ZIndex)) -> Scene s () + 550 spriteModify (Sprite born ref) modFn = liftST $ modifySTRef ref $ \(ttl, renderGen) -> + 551 ( ttl + 552 , do + 553 render <- renderGen + 554 modRender <- unFrame modFn + 555 return $ \relD relT -> + 556 let absT = relT + born in modRender absT relD relT . render relD relT + 557 ) + 558 + 559 -- | Map the SVG output of a sprite. + 560 -- + 561 -- Example: + 562 -- + 563 -- > do s <- fork $ newSpriteA drawCircle + 564 -- > wait 1 + 565 -- > spriteMap s flipYAxis + 566 -- + 567 -- <<docs/gifs/doc_spriteMap.gif>> + 568 spriteMap :: Sprite s -> (SVG -> SVG) -> Scene s () + 569 spriteMap sprite@(Sprite born _) fn = do + 570 now <- queryNow + 571 let tDelta = now - born + 572 spriteModify sprite $ do + 573 t <- spriteT + 574 return $ \(svg, zindex) -> (if (t - tDelta) < 0 then svg else fn svg, zindex) + 575 + 576 -- | Modify the output of a sprite between @now@ and @now+duration@. + 577 -- + 578 -- Example: + 579 -- + 580 -- > do s <- fork $ newSpriteA drawCircle + 581 -- > spriteTween s 1 $ \val -> translate (screenWidth*0.3*val) 0 + 582 -- + 583 -- <<docs/gifs/doc_spriteTween.gif>> + 584 spriteTween :: Sprite s -> Duration -> (Double -> SVG -> SVG) -> Scene s () + 585 spriteTween sprite@(Sprite born _) dur fn = do + 586 now <- queryNow + 587 let tDelta = now - born + 588 spriteModify sprite $ do + 589 t <- spriteT + 590 return $ \(svg, zindex) -> (fn (clamp 0 1 $ (t - tDelta) / dur) svg, zindex) + 591 wait dur + 592 where + 593 clamp a b v | v < a = a + 594 | v > b = b + 595 | otherwise = v + 596 + 597 -- | Create a new variable and apply it to a sprite. + 598 -- + 599 -- Example: + 600 -- + 601 -- > do s <- fork $ newSpriteA drawBox + 602 -- > v <- spriteVar s 0 rotate + 603 -- > tweenVar v 2 $ \val -> fromToS val 90 + 604 -- + 605 -- <<docs/gifs/doc_spriteVar.gif>> + 606 spriteVar :: Sprite s -> a -> (a -> SVG -> SVG) -> Scene s (Var s a) + 607 spriteVar sprite def fn = do + 608 v <- newVar def + 609 applyVar v sprite fn + 610 return v + 611 + 612 -- | Apply an effect to a sprite. + 613 -- + 614 -- Example: + 615 -- + 616 -- > do s <- fork $ newSpriteA drawCircle + 617 -- > spriteE s $ overBeginning 1 fadeInE + 618 -- > spriteE s $ overEnding 0.5 fadeOutE + 619 -- + 620 -- <<docs/gifs/doc_spriteE.gif>> + 621 spriteE :: Sprite s -> Effect -> Scene s () + 622 spriteE (Sprite born ref) effect = do + 623 now <- queryNow + 624 liftST $ modifySTRef ref $ \(ttl, renderGen) -> + 625 ( ttl + 626 , do + 627 render <- renderGen + 628 return $ \d t svg -> + 629 let (svg', z) = render d t svg + 630 in (delayE (max 0 $ now - born) effect d t svg', z) + 631 ) + 632 + 633 -- | Set new ZIndex of a sprite. + 634 -- + 635 -- Example: + 636 -- + 637 -- > do s1 <- newSpriteSVG $ withFillOpacity 1 $ withFillColor "blue" $ mkCircle 3 + 638 -- > newSpriteSVG $ withFillOpacity 1 $ withFillColor "red" $ mkRect 8 3 + 639 -- > wait 1 + 640 -- > spriteZ s1 1 + 641 -- > wait 1 + 642 -- + 643 -- <<docs/gifs/doc_spriteZ.gif>> + 644 spriteZ :: Sprite s -> ZIndex -> Scene s () + 645 spriteZ (Sprite born ref) zindex = do + 646 now <- queryNow + 647 liftST $ modifySTRef ref $ \(ttl, renderGen) -> + 648 ( ttl + 649 , do + 650 render <- renderGen + 651 return $ \d t svg -> + 652 let (svg', z) = render d t svg in (svg', if t < now - born then z else zindex) + 653 ) + 654 + 655 -- | Destroy all local sprites at the end of a scene. + 656 -- + 657 -- Example: + 658 -- + 659 -- > do -- the rect lives through the entire 3s animation + 660 -- > newSpriteSVG_ $ translate (-3) 0 $ mkRect 4 4 + 661 -- > wait 1 + 662 -- > spriteScope $ do + 663 -- > -- the circle only lives for 1 second. + 664 -- > local <- newSpriteSVG $ translate 3 0 $ mkCircle 2 + 665 -- > spriteE local $ overBeginning 0.3 fadeInE + 666 -- > spriteE local $ overEnding 0.3 fadeOutE + 667 -- > wait 1 + 668 -- > wait 1 + 669 -- + 670 -- <<docs/gifs/doc_spriteScope.gif>> + 671 spriteScope :: Scene s a -> Scene s a + 672 spriteScope (M action) = M $ \t -> do + 673 (a, s, p, gens) <- action t + 674 return (a, s, p, map (genFn (t+max s p)) gens) + 675 where + 676 genFn maxT gen = do + 677 frameGen <- gen + 678 return $ \_ t -> + 679 if t < maxT + 680 then frameGen maxT t + 681 else (None, 0) + 682 + 683 asAnimation :: (forall s'. Scene s' a) -> Scene s Animation + 684 asAnimation s = do + 685 now <- queryNow + 686 return $ dropA now (sceneAnimation (wait now >> s)) + 687 + 688 transitionO :: Transition -> Double -> (forall s'. Scene s' a) -> (forall s'. Scene s' b) -> Scene s () + 689 transitionO t o a b = do + 690 aA <- asAnimation a + 691 bA <- fork $ do + 692 wait (duration aA - o) + 693 asAnimation b + 694 play $ overlapT o t aA bA 695 696 697 - 698 ------------------------------------------------------- - 699 -- Objects - 700 - 701 class Renderable a where - 702 toSVG :: a -> SVG - 703 - 704 instance Renderable Tree where - 705 toSVG = id - 706 - 707 -- | Objects are SVG nodes (represented as Haskell values) with - 708 -- identity, location, and several other properties that can - 709 -- change over time. - 710 data Object s a = Object - 711 { objectSprite :: Sprite s - 712 , objectData :: Var s (ObjectData a) - 713 } - 714 - 715 -- | Container for object properties. - 716 data ObjectData a = ObjectData - 717 { _oTranslate :: (Double, Double) - 718 , _oValueRef :: a - 719 , _oSVG :: SVG - 720 , _oContext :: SVG -> SVG - 721 , _oMargin :: (Double, Double, Double, Double) - 722 -- ^ Top, right, bottom, left - 723 , _oBB :: (Double,Double,Double,Double) - 724 , _oOpacity :: Double - 725 , _oShown :: Bool - 726 , _oZIndex :: Int - 727 , _oEasing :: Signal - 728 , _oScale :: Double - 729 , _oScaleOrigin :: (Double, Double) - 730 } - 731 - 732 -- Basic lenses - 733 - 734 -- FIXME: Maybe 'position' is a better name. - 735 -- | Object position. Default: \<0,0\> - 736 oTranslate :: Lens' (ObjectData a) (Double, Double) - 737 oTranslate = lens _oTranslate $ \obj val -> obj { _oTranslate = val } - 738 - 739 -- | Rendered SVG node of an object. Does not include context - 740 -- or object properties. Read-only. - 741 oSVG :: Getter (ObjectData a) SVG - 742 oSVG = to _oSVG - 743 - 744 -- | Custom render context. Is applied to the object for every - 745 -- frame that it is shown. - 746 oContext :: Lens' (ObjectData a) (SVG -> SVG) - 747 oContext = lens _oContext $ \obj val -> obj { _oContext = val } - 748 - 749 -- | Object margins (top, right, bottom, left) in local units. - 750 oMargin :: Lens' (ObjectData a) (Double, Double, Double, Double) - 751 oMargin = lens _oMargin $ \obj val -> obj { _oMargin = val } - 752 - 753 -- | Object bounding-box (minimal X-coordinate, minimal Y-coordinate, - 754 -- width, height). Uses `Reanimate.Svg.BoundingBox.boundingBox` - 755 -- and has the same limitations. - 756 oBB :: Getter (ObjectData a) (Double, Double, Double, Double) - 757 oBB = to _oBB - 758 - 759 -- | Object opacity. Default: 1 - 760 oOpacity :: Lens' (ObjectData a) Double - 761 oOpacity = lens _oOpacity $ \obj val -> obj { _oOpacity = val } - 762 - 763 -- | Toggle for whether or not the object should be rendered. - 764 -- Default: False - 765 oShown :: Lens' (ObjectData a) Bool - 766 oShown = lens _oShown $ \obj val -> obj { _oShown = val } - 767 - 768 -- | Object's z-index. - 769 oZIndex :: Lens' (ObjectData a) Int - 770 oZIndex = lens _oZIndex $ \obj val -> obj { _oZIndex = val } - 771 - 772 -- | Easing function used when modifying object properties. - 773 -- Default: @'Reanimate.Ease.curveS' 2@ - 774 oEasing :: Lens' (ObjectData a) Signal - 775 oEasing = lens _oEasing $ \obj val -> obj { _oEasing = val } - 776 - 777 -- | Object's scale. Default: 1 - 778 oScale :: Lens' (ObjectData a) Double - 779 oScale = lens _oScale $ \obj val -> obj { _oScale = val } - 780 - 781 -- | Origin point for scaling. Default: \<0,0\> - 782 oScaleOrigin :: Lens' (ObjectData a) (Double, Double) - 783 oScaleOrigin = lens _oScaleOrigin $ \obj val -> obj { _oScaleOrigin = val } - 784 - 785 -- Smart lenses - 786 - 787 -- | Lens for the source value contained in an object. - 788 oValue :: Renderable a => Lens' (ObjectData a) a - 789 oValue = lens _oValueRef $ \obj newVal -> - 790 let svg = toSVG newVal - 791 in obj - 792 { _oValueRef = newVal - 793 , _oSVG = svg - 794 , _oBB = boundingBox svg } - 795 - 796 -- | Derived location of the top-most point of an object + margin. - 797 oTopY :: Lens' (ObjectData a) Double - 798 oTopY = lens getter setter - 799 where - 800 getter obj = - 801 let top = obj ^. oMarginTop - 802 miny = obj ^. oBBMinY - 803 h = obj ^. oBBHeight - 804 dy = obj ^. oTranslate . _2 - 805 in dy+miny+h+top - 806 setter obj val = - 807 obj & (oTranslate . _2) +~ val-getter obj - 808 - 809 -- | Derived location of the bottom-most point of an object + margin. - 810 oBottomY :: Lens' (ObjectData a) Double - 811 oBottomY = lens getter setter - 812 where - 813 getter obj = - 814 let bot = obj ^. oMarginBottom - 815 miny = obj ^. oBBMinY - 816 dy = obj ^. oTranslate . _2 - 817 in dy+miny-bot - 818 setter obj val = - 819 obj & (oTranslate . _2) +~ val-getter obj - 820 - 821 -- | Derived location of the left-most point of an object + margin. - 822 oLeftX :: Lens' (ObjectData a) Double - 823 oLeftX = lens getter setter - 824 where - 825 getter obj = - 826 let left = obj ^. oMarginLeft - 827 minx = obj ^. oBBMinX - 828 dx = obj ^. oTranslate . _1 - 829 in dx+minx-left - 830 setter obj val = - 831 obj & (oTranslate . _1) +~ val-getter obj - 832 - 833 -- | Derived location of the right-most point of an object + margin. - 834 oRightX :: Lens' (ObjectData a) Double - 835 oRightX = lens getter setter - 836 where - 837 getter obj = - 838 let right = obj ^. oMarginRight - 839 minx = obj ^. oBBMinX - 840 w = obj ^. oBBWidth - 841 dx = obj ^. oTranslate . _1 - 842 in dx+minx+w+right - 843 setter obj val = - 844 obj & (oTranslate . _1) +~ val-getter obj - 845 - 846 -- | Derived location of an object's center point. - 847 oCenterXY :: Lens' (ObjectData a) (Double, Double) - 848 oCenterXY = lens getter setter - 849 where - 850 getter obj = - 851 let minx = obj ^. oBBMinX - 852 miny = obj ^. oBBMinY - 853 w = obj ^. oBBWidth - 854 h = obj ^. oBBHeight - 855 (dx,dy) = obj ^. oTranslate - 856 in (dx+minx+w/2, dy+miny+h/2) - 857 setter obj (dx, dy) = - 858 let (x,y) = getter obj in - 859 obj & (oTranslate . _1) +~ dx-x - 860 & (oTranslate . _2) +~ dy-y - 861 - 862 -- | Object's top margin. - 863 oMarginTop :: Lens' (ObjectData a) Double - 864 oMarginTop = oMargin . _1 - 865 - 866 -- | Object's right margin. - 867 oMarginRight :: Lens' (ObjectData a) Double - 868 oMarginRight = oMargin . _2 - 869 - 870 -- | Object's bottom margin. - 871 oMarginBottom :: Lens' (ObjectData a) Double - 872 oMarginBottom = oMargin . _3 - 873 - 874 -- | Object's left margin. - 875 oMarginLeft :: Lens' (ObjectData a) Double - 876 oMarginLeft = oMargin . _4 - 877 - 878 -- | Object's minimal X-coordinate.. - 879 oBBMinX :: Getter (ObjectData a) Double - 880 oBBMinX = oBB . _1 - 881 - 882 -- | Object's minimal Y-coordinate.. - 883 oBBMinY :: Getter (ObjectData a) Double - 884 oBBMinY = oBB . _2 - 885 - 886 -- | Object's width without margin. - 887 oBBWidth :: Getter (ObjectData a) Double - 888 oBBWidth = oBB . _3 - 889 - 890 -- | Object's height without margin. - 891 oBBHeight :: Getter (ObjectData a) Double - 892 oBBHeight = oBB . _4 - 893 - 894 ------------------------------------------------------------------------------- - 895 -- Object modifiers - 896 - 897 -- | Modify object properties. - 898 oModify :: Object s a -> (ObjectData a -> ObjectData a) -> Scene s () - 899 oModify o fn = modifyVar (objectData o) fn - 900 - 901 -- | Modify object properties using a stateful API. - 902 oModifyS :: Object s a -> (State (ObjectData a) b) -> Scene s () - 903 oModifyS o fn = oModify o (execState fn) - 904 - 905 -- | Query object property. - 906 oRead :: Object s a -> Getting b (ObjectData a) b -> Scene s b - 907 oRead o l = view l <$> readVar (objectData o) - 908 - 909 -- | Modify object properties over a set duration. - 910 oTween :: Object s a -> Duration -> (Double -> ObjectData a -> ObjectData a) -> Scene s () - 911 oTween o d fn = do - 912 -- Read 'easing' var here instead of taking it from 'v'. - 913 -- This allows different easing functions even at the same timestamp. - 914 ease <- oRead o oEasing - 915 tweenVar (objectData o) d (\v t -> fn (ease t) v) - 916 - 917 -- | Modify object properties over a set duration using a stateful API. - 918 oTweenS :: Object s a -> Duration -> (Double -> State (ObjectData a) b) -> Scene s () - 919 oTweenS o d fn = oTween o d (\t -> execState (fn t)) - 920 - 921 -- | Modify object value over a set duration. This is a convenience function - 922 -- for modifying `oValue`. - 923 oTweenV :: Renderable a => Object s a -> Duration -> (Double -> a -> a) -> Scene s () - 924 oTweenV o d fn = oTween o d (\t -> oValue %~ fn t) - 925 - 926 -- | Modify object value over a set duration using a stateful API. This is a - 927 -- convenience function for modifying `oValue`. - 928 oTweenVS :: Renderable a => Object s a -> Duration -> (Double -> State a b) -> Scene s () - 929 oTweenVS o d fn = oTween o d (\t -> oValue %~ execState (fn t)) - 930 - 931 -- | Create new object. - 932 oNew :: Renderable a => a -> Scene s (Object s a) - 933 oNew = newObject - 934 - 935 newObject :: Renderable a => a -> Scene s (Object s a) - 936 newObject val = do - 937 ref <- newVar ObjectData - 938 { _oTranslate = (0,0) - 939 , _oValueRef = val - 940 , _oSVG = svg - 941 , _oContext = id - 942 , _oMargin = (0.5,0.5,0.5,0.5) - 943 , _oBB = boundingBox svg - 944 , _oOpacity = 1 - 945 , _oShown = False - 946 , _oZIndex = 1 - 947 , _oEasing = curveS 2 - 948 , _oScale = 1 - 949 , _oScaleOrigin = (0,0) - 950 } - 951 sprite <- newSprite $ do - 952 ~ObjectData{..} <- unVar ref - 953 pure $ - 954 if _oShown - 955 then - 956 uncurry translate _oTranslate $ - 957 uncurry translate (_oScaleOrigin & both %~ negate) $ - 958 scale _oScale $ - 959 uncurry translate _oScaleOrigin $ - 960 withGroupOpacity _oOpacity $ - 961 _oContext _oSVG - 962 else None - 963 spriteModify sprite $ do - 964 ~ObjectData{_oZIndex=z} <- unVar ref - 965 pure $ \(img,_) -> (img,z) - 966 return Object - 967 { objectSprite = sprite - 968 , objectData = ref } - 969 where - 970 svg = toSVG val - 971 - 972 ------------------------------------------------------------------------------- - 973 -- Graphical transformations - 974 - 975 -- | Instantly show object. - 976 oShow :: Object s a -> Scene s () - 977 oShow o = oModify o $ oShown .~ True - 978 - 979 -- | Instantly hide object. - 980 oHide :: Object s a -> Scene s () - 981 oHide o = oModify o $ oShown .~ False - 982 - 983 -- | Fade in object over a set duration. - 984 oFadeIn :: Object s a -> Duration -> Scene s () - 985 oFadeIn o d = do - 986 oModify o $ - 987 oShown .~ True - 988 oTweenS o d $ \t -> - 989 oOpacity *= t - 990 - 991 -- | Fade out object over a set duration. - 992 oFadeOut :: Object s a -> Duration -> Scene s () - 993 oFadeOut o d = do - 994 oModify o $ - 995 oShown .~ True - 996 oTweenS o d $ \t -> - 997 oOpacity *= 1-t - 998 - 999 -- | Scale in object over a set duration. - 1000 oGrow :: Object s a -> Duration -> Scene s () - 1001 oGrow o d = do - 1002 oModify o $ - 1003 oShown .~ True - 1004 oTweenS o d $ \t -> - 1005 oScale *= t - 1006 - 1007 -- | Scale out object over a set duration. - 1008 oShrink :: Object s a -> Duration -> Scene s () - 1009 oShrink o d = - 1010 oTweenS o d $ \t -> - 1011 oScale *= 1-t - 1012 - 1013 -- FIXME: Also transform attributes: 'opacity', 'scale', 'scaleOrigin'. - 1014 -- | Morph source object into target object over a set duration. - 1015 oTransform :: Object s a -> Object s b -> Duration -> Scene s () - 1016 oTransform src dst d = do - 1017 srcSvg <- oRead src oSVG - 1018 srcCtx <- oRead src oContext - 1019 srcEase <- oRead src oEasing - 1020 srcLoc <- oRead src oTranslate - 1021 oModify src $ oShown .~ False - 1022 - 1023 dstSvg <- oRead dst oSVG - 1024 dstCtx <- oRead dst oContext - 1025 dstLoc <- oRead dst oTranslate - 1026 - 1027 m <- newObject $ Morph 0 (srcCtx srcSvg) (dstCtx dstSvg) - 1028 oModifyS m $ do - 1029 oShown .= True - 1030 oEasing .= srcEase - 1031 oTranslate .= srcLoc - 1032 fork $ oTween m d $ \t -> oTranslate %~ moveTo t dstLoc - 1033 oTweenV m d $ \t -> morphDelta .~ t - 1034 oModify m $ oShown .~ False - 1035 oModify dst $ oShown .~ True - 1036 where - 1037 moveTo t (dstX, dstY) (srcX, srcY) = - 1038 (fromToS srcX dstX t, fromToS srcY dstY t) - 1039 - 1040 - 1041 ------------------------------------------------------------------------------- - 1042 -- Built-in objects - 1043 - 1044 newtype Circle = Circle {_circleRadius :: Double} + 698 + 699 ------------------------------------------------------- + 700 -- Objects + 701 + 702 class Renderable a where + 703 toSVG :: a -> SVG + 704 + 705 instance Renderable Tree where + 706 toSVG = id + 707 + 708 -- | Objects are SVG nodes (represented as Haskell values) with + 709 -- identity, location, and several other properties that can + 710 -- change over time. + 711 data Object s a = Object + 712 { objectSprite :: Sprite s + 713 , objectData :: Var s (ObjectData a) + 714 } + 715 + 716 -- | Container for object properties. + 717 data ObjectData a = ObjectData + 718 { _oTranslate :: (Double, Double) + 719 , _oValueRef :: a + 720 , _oSVG :: SVG + 721 , _oContext :: SVG -> SVG + 722 , _oMargin :: (Double, Double, Double, Double) + 723 -- ^ Top, right, bottom, left + 724 , _oBB :: (Double,Double,Double,Double) + 725 , _oOpacity :: Double + 726 , _oShown :: Bool + 727 , _oZIndex :: Int + 728 , _oEasing :: Signal + 729 , _oScale :: Double + 730 , _oScaleOrigin :: (Double, Double) + 731 } + 732 + 733 -- Basic lenses + 734 + 735 -- FIXME: Maybe 'position' is a better name. + 736 -- | Object position. Default: \<0,0\> + 737 oTranslate :: Lens' (ObjectData a) (Double, Double) + 738 oTranslate = lens _oTranslate $ \obj val -> obj { _oTranslate = val } + 739 + 740 -- | Rendered SVG node of an object. Does not include context + 741 -- or object properties. Read-only. + 742 oSVG :: Getter (ObjectData a) SVG + 743 oSVG = to _oSVG + 744 + 745 -- | Custom render context. Is applied to the object for every + 746 -- frame that it is shown. + 747 oContext :: Lens' (ObjectData a) (SVG -> SVG) + 748 oContext = lens _oContext $ \obj val -> obj { _oContext = val } + 749 + 750 -- | Object margins (top, right, bottom, left) in local units. + 751 oMargin :: Lens' (ObjectData a) (Double, Double, Double, Double) + 752 oMargin = lens _oMargin $ \obj val -> obj { _oMargin = val } + 753 + 754 -- | Object bounding-box (minimal X-coordinate, minimal Y-coordinate, + 755 -- width, height). Uses `Reanimate.Svg.BoundingBox.boundingBox` + 756 -- and has the same limitations. + 757 oBB :: Getter (ObjectData a) (Double, Double, Double, Double) + 758 oBB = to _oBB + 759 + 760 -- | Object opacity. Default: 1 + 761 oOpacity :: Lens' (ObjectData a) Double + 762 oOpacity = lens _oOpacity $ \obj val -> obj { _oOpacity = val } + 763 + 764 -- | Toggle for whether or not the object should be rendered. + 765 -- Default: False + 766 oShown :: Lens' (ObjectData a) Bool + 767 oShown = lens _oShown $ \obj val -> obj { _oShown = val } + 768 + 769 -- | Object's z-index. + 770 oZIndex :: Lens' (ObjectData a) Int + 771 oZIndex = lens _oZIndex $ \obj val -> obj { _oZIndex = val } + 772 + 773 -- | Easing function used when modifying object properties. + 774 -- Default: @'Reanimate.Ease.curveS' 2@ + 775 oEasing :: Lens' (ObjectData a) Signal + 776 oEasing = lens _oEasing $ \obj val -> obj { _oEasing = val } + 777 + 778 -- | Object's scale. Default: 1 + 779 oScale :: Lens' (ObjectData a) Double + 780 oScale = lens _oScale $ \obj val -> obj { _oScale = val } + 781 + 782 -- | Origin point for scaling. Default: \<0,0\> + 783 oScaleOrigin :: Lens' (ObjectData a) (Double, Double) + 784 oScaleOrigin = lens _oScaleOrigin $ \obj val -> obj { _oScaleOrigin = val } + 785 + 786 -- Smart lenses + 787 + 788 -- | Lens for the source value contained in an object. + 789 oValue :: Renderable a => Lens' (ObjectData a) a + 790 oValue = lens _oValueRef $ \obj newVal -> + 791 let svg = toSVG newVal + 792 in obj + 793 { _oValueRef = newVal + 794 , _oSVG = svg + 795 , _oBB = boundingBox svg } + 796 + 797 -- | Derived location of the top-most point of an object + margin. + 798 oTopY :: Lens' (ObjectData a) Double + 799 oTopY = lens getter setter + 800 where + 801 getter obj = + 802 let top = obj ^. oMarginTop + 803 miny = obj ^. oBBMinY + 804 h = obj ^. oBBHeight + 805 dy = obj ^. oTranslate . _2 + 806 in dy+miny+h+top + 807 setter obj val = + 808 obj & (oTranslate . _2) +~ val-getter obj + 809 + 810 -- | Derived location of the bottom-most point of an object + margin. + 811 oBottomY :: Lens' (ObjectData a) Double + 812 oBottomY = lens getter setter + 813 where + 814 getter obj = + 815 let bot = obj ^. oMarginBottom + 816 miny = obj ^. oBBMinY + 817 dy = obj ^. oTranslate . _2 + 818 in dy+miny-bot + 819 setter obj val = + 820 obj & (oTranslate . _2) +~ val-getter obj + 821 + 822 -- | Derived location of the left-most point of an object + margin. + 823 oLeftX :: Lens' (ObjectData a) Double + 824 oLeftX = lens getter setter + 825 where + 826 getter obj = + 827 let left = obj ^. oMarginLeft + 828 minx = obj ^. oBBMinX + 829 dx = obj ^. oTranslate . _1 + 830 in dx+minx-left + 831 setter obj val = + 832 obj & (oTranslate . _1) +~ val-getter obj + 833 + 834 -- | Derived location of the right-most point of an object + margin. + 835 oRightX :: Lens' (ObjectData a) Double + 836 oRightX = lens getter setter + 837 where + 838 getter obj = + 839 let right = obj ^. oMarginRight + 840 minx = obj ^. oBBMinX + 841 w = obj ^. oBBWidth + 842 dx = obj ^. oTranslate . _1 + 843 in dx+minx+w+right + 844 setter obj val = + 845 obj & (oTranslate . _1) +~ val-getter obj + 846 + 847 -- | Derived location of an object's center point. + 848 oCenterXY :: Lens' (ObjectData a) (Double, Double) + 849 oCenterXY = lens getter setter + 850 where + 851 getter obj = + 852 let minx = obj ^. oBBMinX + 853 miny = obj ^. oBBMinY + 854 w = obj ^. oBBWidth + 855 h = obj ^. oBBHeight + 856 (dx,dy) = obj ^. oTranslate + 857 in (dx+minx+w/2, dy+miny+h/2) + 858 setter obj (dx, dy) = + 859 let (x,y) = getter obj in + 860 obj & (oTranslate . _1) +~ dx-x + 861 & (oTranslate . _2) +~ dy-y + 862 + 863 -- | Object's top margin. + 864 oMarginTop :: Lens' (ObjectData a) Double + 865 oMarginTop = oMargin . _1 + 866 + 867 -- | Object's right margin. + 868 oMarginRight :: Lens' (ObjectData a) Double + 869 oMarginRight = oMargin . _2 + 870 + 871 -- | Object's bottom margin. + 872 oMarginBottom :: Lens' (ObjectData a) Double + 873 oMarginBottom = oMargin . _3 + 874 + 875 -- | Object's left margin. + 876 oMarginLeft :: Lens' (ObjectData a) Double + 877 oMarginLeft = oMargin . _4 + 878 + 879 -- | Object's minimal X-coordinate.. + 880 oBBMinX :: Getter (ObjectData a) Double + 881 oBBMinX = oBB . _1 + 882 + 883 -- | Object's minimal Y-coordinate.. + 884 oBBMinY :: Getter (ObjectData a) Double + 885 oBBMinY = oBB . _2 + 886 + 887 -- | Object's width without margin. + 888 oBBWidth :: Getter (ObjectData a) Double + 889 oBBWidth = oBB . _3 + 890 + 891 -- | Object's height without margin. + 892 oBBHeight :: Getter (ObjectData a) Double + 893 oBBHeight = oBB . _4 + 894 + 895 ------------------------------------------------------------------------------- + 896 -- Object modifiers + 897 + 898 -- | Modify object properties. + 899 oModify :: Object s a -> (ObjectData a -> ObjectData a) -> Scene s () + 900 oModify o fn = modifyVar (objectData o) fn + 901 + 902 -- | Modify object properties using a stateful API. + 903 oModifyS :: Object s a -> (State (ObjectData a) b) -> Scene s () + 904 oModifyS o fn = oModify o (execState fn) + 905 + 906 -- | Query object property. + 907 oRead :: Object s a -> Getting b (ObjectData a) b -> Scene s b + 908 oRead o l = view l <$> readVar (objectData o) + 909 + 910 -- | Modify object properties over a set duration. + 911 oTween :: Object s a -> Duration -> (Double -> ObjectData a -> ObjectData a) -> Scene s () + 912 oTween o d fn = do + 913 -- Read 'easing' var here instead of taking it from 'v'. + 914 -- This allows different easing functions even at the same timestamp. + 915 ease <- oRead o oEasing + 916 tweenVar (objectData o) d (\v t -> fn (ease t) v) + 917 + 918 -- | Modify object properties over a set duration using a stateful API. + 919 oTweenS :: Object s a -> Duration -> (Double -> State (ObjectData a) b) -> Scene s () + 920 oTweenS o d fn = oTween o d (\t -> execState (fn t)) + 921 + 922 -- | Modify object value over a set duration. This is a convenience function + 923 -- for modifying `oValue`. + 924 oTweenV :: Renderable a => Object s a -> Duration -> (Double -> a -> a) -> Scene s () + 925 oTweenV o d fn = oTween o d (\t -> oValue %~ fn t) + 926 + 927 -- | Modify object value over a set duration using a stateful API. This is a + 928 -- convenience function for modifying `oValue`. + 929 oTweenVS :: Renderable a => Object s a -> Duration -> (Double -> State a b) -> Scene s () + 930 oTweenVS o d fn = oTween o d (\t -> oValue %~ execState (fn t)) + 931 + 932 -- | Create new object. + 933 oNew :: Renderable a => a -> Scene s (Object s a) + 934 oNew = newObject + 935 + 936 -- | Create new object. + 937 newObject :: Renderable a => a -> Scene s (Object s a) + 938 newObject val = do + 939 ref <- newVar ObjectData + 940 { _oTranslate = (0,0) + 941 , _oValueRef = val + 942 , _oSVG = svg + 943 , _oContext = id + 944 , _oMargin = (0.5,0.5,0.5,0.5) + 945 , _oBB = boundingBox svg + 946 , _oOpacity = 1 + 947 , _oShown = False + 948 , _oZIndex = 1 + 949 , _oEasing = curveS 2 + 950 , _oScale = 1 + 951 , _oScaleOrigin = (0,0) + 952 } + 953 sprite <- newSprite $ do + 954 ~ObjectData{..} <- unVar ref + 955 pure $ + 956 if _oShown + 957 then + 958 uncurry translate _oTranslate $ + 959 uncurry translate (_oScaleOrigin & both %~ negate) $ + 960 scale _oScale $ + 961 uncurry translate _oScaleOrigin $ + 962 withGroupOpacity _oOpacity $ + 963 _oContext _oSVG + 964 else None + 965 spriteModify sprite $ do + 966 ~ObjectData{_oZIndex=z} <- unVar ref + 967 pure $ \(img,_) -> (img,z) + 968 return Object + 969 { objectSprite = sprite + 970 , objectData = ref } + 971 where + 972 svg = toSVG val + 973 + 974 ------------------------------------------------------------------------------- + 975 -- Graphical transformations + 976 + 977 -- | Instantly show object. + 978 oShow :: Object s a -> Scene s () + 979 oShow o = oModify o $ oShown .~ True + 980 + 981 -- | Instantly hide object. + 982 oHide :: Object s a -> Scene s () + 983 oHide o = oModify o $ oShown .~ False + 984 + 985 -- | Fade in object over a set duration. + 986 oFadeIn :: Object s a -> Duration -> Scene s () + 987 oFadeIn o d = do + 988 oModify o $ + 989 oShown .~ True + 990 oTweenS o d $ \t -> + 991 oOpacity *= t + 992 + 993 -- | Fade out object over a set duration. + 994 oFadeOut :: Object s a -> Duration -> Scene s () + 995 oFadeOut o d = do + 996 oModify o $ + 997 oShown .~ True + 998 oTweenS o d $ \t -> + 999 oOpacity *= 1-t + 1000 + 1001 -- | Scale in object over a set duration. + 1002 oGrow :: Object s a -> Duration -> Scene s () + 1003 oGrow o d = do + 1004 oModify o $ + 1005 oShown .~ True + 1006 oTweenS o d $ \t -> + 1007 oScale *= t + 1008 + 1009 -- | Scale out object over a set duration. + 1010 oShrink :: Object s a -> Duration -> Scene s () + 1011 oShrink o d = + 1012 oTweenS o d $ \t -> + 1013 oScale *= 1-t + 1014 + 1015 -- FIXME: Also transform attributes: 'opacity', 'scale', 'scaleOrigin'. + 1016 -- | Morph source object into target object over a set duration. + 1017 oTransform :: Object s a -> Object s b -> Duration -> Scene s () + 1018 oTransform src dst d = do + 1019 srcSvg <- oRead src oSVG + 1020 srcCtx <- oRead src oContext + 1021 srcEase <- oRead src oEasing + 1022 srcLoc <- oRead src oTranslate + 1023 oModify src $ oShown .~ False + 1024 + 1025 dstSvg <- oRead dst oSVG + 1026 dstCtx <- oRead dst oContext + 1027 dstLoc <- oRead dst oTranslate + 1028 + 1029 m <- newObject $ Morph 0 (srcCtx srcSvg) (dstCtx dstSvg) + 1030 oModifyS m $ do + 1031 oShown .= True + 1032 oEasing .= srcEase + 1033 oTranslate .= srcLoc + 1034 fork $ oTween m d $ \t -> oTranslate %~ moveTo t dstLoc + 1035 oTweenV m d $ \t -> morphDelta .~ t + 1036 oModify m $ oShown .~ False + 1037 oModify dst $ oShown .~ True + 1038 where + 1039 moveTo t (dstX, dstY) (srcX, srcY) = + 1040 (fromToS srcX dstX t, fromToS srcY dstY t) + 1041 + 1042 + 1043 ------------------------------------------------------------------------------- + 1044 -- Built-in objects 1045 - 1046 circleRadius :: Iso' Circle Double - 1047 circleRadius = iso _circleRadius Circle - 1048 - 1049 instance Renderable Circle where - 1050 toSVG (Circle r) = mkCircle r - 1051 - 1052 data Rectangle = Rectangle { _rectWidth :: Double, _rectHeight :: Double } + 1046 newtype Circle = Circle {_circleRadius :: Double} + 1047 + 1048 circleRadius :: Iso' Circle Double + 1049 circleRadius = iso _circleRadius Circle + 1050 + 1051 instance Renderable Circle where + 1052 toSVG (Circle r) = mkCircle r 1053 - 1054 rectWidth :: Lens' Rectangle Double - 1055 rectWidth = lens _rectWidth $ \obj val -> obj{_rectWidth=val} - 1056 - 1057 rectHeight :: Lens' Rectangle Double - 1058 rectHeight = lens _rectHeight $ \obj val -> obj{_rectHeight=val} - 1059 - 1060 instance Renderable Rectangle where - 1061 toSVG (Rectangle w h) = mkRect w h - 1062 - 1063 data Morph = Morph { _morphDelta :: Double, _morphSrc :: SVG, _morphDst :: SVG } + 1054 data Rectangle = Rectangle { _rectWidth :: Double, _rectHeight :: Double } + 1055 + 1056 rectWidth :: Lens' Rectangle Double + 1057 rectWidth = lens _rectWidth $ \obj val -> obj{_rectWidth=val} + 1058 + 1059 rectHeight :: Lens' Rectangle Double + 1060 rectHeight = lens _rectHeight $ \obj val -> obj{_rectHeight=val} + 1061 + 1062 instance Renderable Rectangle where + 1063 toSVG (Rectangle w h) = mkRect w h 1064 - 1065 morphDelta :: Lens' Morph Double - 1066 morphDelta = lens _morphDelta $ \obj val -> obj{_morphDelta = val} - 1067 - 1068 morphSrc :: Lens' Morph SVG - 1069 morphSrc = lens _morphSrc $ \obj val -> obj{_morphSrc = val} - 1070 - 1071 morphDst :: Lens' Morph SVG - 1072 morphDst = lens _morphDst $ \obj val -> obj{_morphDst = val} - 1073 - 1074 instance Renderable Morph where - 1075 toSVG (Morph t src dst) = morph linear src dst t - 1076 - 1077 data Camera = Camera - 1078 instance Renderable Camera where - 1079 toSVG Camera = None - 1080 - 1081 -- | Connect an object to a camera such that - 1082 -- camera settings (position, zoom, and rotation) is - 1083 -- applied to the object. - 1084 -- - 1085 -- Example + 1065 data Morph = Morph { _morphDelta :: Double, _morphSrc :: SVG, _morphDst :: SVG } + 1066 + 1067 morphDelta :: Lens' Morph Double + 1068 morphDelta = lens _morphDelta $ \obj val -> obj{_morphDelta = val} + 1069 + 1070 morphSrc :: Lens' Morph SVG + 1071 morphSrc = lens _morphSrc $ \obj val -> obj{_morphSrc = val} + 1072 + 1073 morphDst :: Lens' Morph SVG + 1074 morphDst = lens _morphDst $ \obj val -> obj{_morphDst = val} + 1075 + 1076 instance Renderable Morph where + 1077 toSVG (Morph t src dst) = morph linear src dst t + 1078 + 1079 data Camera = Camera + 1080 instance Renderable Camera where + 1081 toSVG Camera = None + 1082 + 1083 -- | Connect an object to a camera such that + 1084 -- camera settings (position, zoom, and rotation) is + 1085 -- applied to the object. 1086 -- - 1087 -- > do cam <- newObject Camera - 1088 -- > circ <- newObject $ Circle 2 - 1089 -- > oModifyS circ $ - 1090 -- > oContext .= withFillOpacity 1 . withFillColor "blue" - 1091 -- > oShow circ - 1092 -- > cameraAttach cam circ - 1093 -- > cameraZoom cam 1 2 - 1094 -- > cameraZoom cam 1 1 - 1095 -- - 1096 -- <<docs/gifs/doc_cameraAttach.gif>> - 1097 cameraAttach :: Object s Camera -> Object s a -> Scene s () - 1098 cameraAttach cam obj = - 1099 spriteModify (objectSprite obj) $ do - 1100 camData <- unVar (objectData cam) - 1101 return $ \(svg,zindex) -> - 1102 let (x,y) = camData^.oTranslate - 1103 ctx = - 1104 translate (-x) (-y) . - 1105 uncurry translate (camData^.oScaleOrigin) . - 1106 scale (camData^.oScale) . - 1107 uncurry translate (camData^.oScaleOrigin & both %~ negate) - 1108 in (ctx svg, zindex) - 1109 - 1110 -- | - 1111 -- - 1112 -- Example + 1087 -- Example + 1088 -- + 1089 -- > do cam <- newObject Camera + 1090 -- > circ <- newObject $ Circle 2 + 1091 -- > oModifyS circ $ + 1092 -- > oContext .= withFillOpacity 1 . withFillColor "blue" + 1093 -- > oShow circ + 1094 -- > cameraAttach cam circ + 1095 -- > cameraZoom cam 1 2 + 1096 -- > cameraZoom cam 1 1 + 1097 -- + 1098 -- <<docs/gifs/doc_cameraAttach.gif>> + 1099 cameraAttach :: Object s Camera -> Object s a -> Scene s () + 1100 cameraAttach cam obj = + 1101 spriteModify (objectSprite obj) $ do + 1102 camData <- unVar (objectData cam) + 1103 return $ \(svg,zindex) -> + 1104 let (x,y) = camData^.oTranslate + 1105 ctx = + 1106 translate (-x) (-y) . + 1107 uncurry translate (camData^.oScaleOrigin) . + 1108 scale (camData^.oScale) . + 1109 uncurry translate (camData^.oScaleOrigin & both %~ negate) + 1110 in (ctx svg, zindex) + 1111 + 1112 -- | 1113 -- - 1114 -- > do cam <- newObject Camera - 1115 -- > circ <- newObject $ Circle 2; oShow circ - 1116 -- > oModify circ $ oTranslate .~ (-3,0) - 1117 -- > box <- newObject $ Rectangle 4 4; oShow box - 1118 -- > oModify box $ oTranslate .~ (3,0) - 1119 -- > cameraAttach cam circ - 1120 -- > cameraAttach cam box - 1121 -- > cameraFocus cam (-3,0) - 1122 -- > cameraZoom cam 2 2 -- Zoom in - 1123 -- > cameraZoom cam 2 1 -- Zoom out - 1124 -- > cameraFocus cam (3,0) - 1125 -- > cameraZoom cam 2 2 -- Zoom in - 1126 -- > cameraZoom cam 2 1 -- Zoom out - 1127 -- - 1128 -- <<docs/gifs/doc_cameraFocus.gif>> - 1129 cameraFocus :: Object s Camera -> (Double, Double) -> Scene s () - 1130 cameraFocus cam (x,y) = do - 1131 (ox, oy) <- oRead cam oScaleOrigin - 1132 (tx, ty) <- oRead cam oTranslate - 1133 s <- oRead cam oScale - 1134 let newLocation = (x-((x-ox)*s+ox-tx), y-((y-oy)*s+oy-ty)) - 1135 oModifyS cam $ do - 1136 oTranslate .= newLocation - 1137 oScaleOrigin .= (x,y) - 1138 - 1139 -- | Instantaneously set camera zoom level. - 1140 cameraSetZoom :: Object s Camera -> Double -> Scene s () - 1141 cameraSetZoom cam s = - 1142 oModifyS cam $ - 1143 oScale .= s - 1144 - 1145 -- | Change camera zoom level over a set duration. - 1146 cameraZoom :: Object s Camera -> Duration -> Double -> Scene s () - 1147 cameraZoom cam d s = - 1148 oTweenS cam d $ \t -> - 1149 oScale %= \v -> fromToS v s t - 1150 - 1151 -- | Instantaneously set camera location. - 1152 cameraSetPan :: Object s Camera -> (Double, Double) -> Scene s () - 1153 cameraSetPan cam location = - 1154 oModifyS cam $ do - 1155 oTranslate .= location - 1156 - 1157 -- | Change camera location over a set duration. - 1158 cameraPan :: Object s Camera -> Duration -> (Double, Double) -> Scene s () - 1159 cameraPan cam d (x,y) = - 1160 oTweenS cam d $ \t -> do - 1161 oTranslate._1 %= \v -> fromToS v x t - 1162 oTranslate._2 %= \v -> fromToS v y t + 1114 -- Example + 1115 -- + 1116 -- > do cam <- newObject Camera + 1117 -- > circ <- newObject $ Circle 2; oShow circ + 1118 -- > oModify circ $ oTranslate .~ (-3,0) + 1119 -- > box <- newObject $ Rectangle 4 4; oShow box + 1120 -- > oModify box $ oTranslate .~ (3,0) + 1121 -- > cameraAttach cam circ + 1122 -- > cameraAttach cam box + 1123 -- > cameraFocus cam (-3,0) + 1124 -- > cameraZoom cam 2 2 -- Zoom in + 1125 -- > cameraZoom cam 2 1 -- Zoom out + 1126 -- > cameraFocus cam (3,0) + 1127 -- > cameraZoom cam 2 2 -- Zoom in + 1128 -- > cameraZoom cam 2 1 -- Zoom out + 1129 -- + 1130 -- <<docs/gifs/doc_cameraFocus.gif>> + 1131 cameraFocus :: Object s Camera -> (Double, Double) -> Scene s () + 1132 cameraFocus cam (x,y) = do + 1133 (ox, oy) <- oRead cam oScaleOrigin + 1134 (tx, ty) <- oRead cam oTranslate + 1135 s <- oRead cam oScale + 1136 let newLocation = (x-((x-ox)*s+ox-tx), y-((y-oy)*s+oy-ty)) + 1137 oModifyS cam $ do + 1138 oTranslate .= newLocation + 1139 oScaleOrigin .= (x,y) + 1140 + 1141 -- | Instantaneously set camera zoom level. + 1142 cameraSetZoom :: Object s Camera -> Double -> Scene s () + 1143 cameraSetZoom cam s = + 1144 oModifyS cam $ + 1145 oScale .= s + 1146 + 1147 -- | Change camera zoom level over a set duration. + 1148 cameraZoom :: Object s Camera -> Duration -> Double -> Scene s () + 1149 cameraZoom cam d s = + 1150 oTweenS cam d $ \t -> + 1151 oScale %= \v -> fromToS v s t + 1152 + 1153 -- | Instantaneously set camera location. + 1154 cameraSetPan :: Object s Camera -> (Double, Double) -> Scene s () + 1155 cameraSetPan cam location = + 1156 oModifyS cam $ do + 1157 oTranslate .= location + 1158 + 1159 -- | Change camera location over a set duration. + 1160 cameraPan :: Object s Camera -> Duration -> (Double, Double) -> Scene s () + 1161 cameraPan cam d (x,y) = + 1162 oTweenS cam d $ \t -> do + 1163 oTranslate._1 %= \v -> fromToS v x t + 1164 oTranslate._2 %= \v -> fromToS v y t