never executed always true always false
1 -- |
2 -- Copyright : Written by David Himmelstrup
3 -- License : Unlicense
4 -- Maintainer : lemmih@gmail.com
5 -- Stability : experimental
6 -- Portability : POSIX
7 module Reanimate.Svg.LineCommand
8 ( CmdM,
9 LineCommand (..),
10 lineLength,
11 toLineCommands,
12 lineToPath,
13 lineToPoints,
14 partialSvg,
15 )
16 where
17
18 import Control.Lens ((%~), (&), (.~))
19 import Control.Monad.Fix
20 import Control.Monad.State
21 import Data.Functor
22 import Data.Maybe
23 import qualified Data.Vector.Unboxed as V
24 import qualified Geom2D.CubicBezier.Linear as Bezier
25 import Graphics.SvgTree
26 import Linear.Metric
27 import Linear.V2 hiding (angle)
28 import Linear.Vector
29
30 -- | Line command monad used for keeping track of the current location.
31 type CmdM a = State RPoint a
32
33 -- | Simplified version of a PathCommand where all points are absolute.
34 data LineCommand
35 = LineMove RPoint
36 | -- | LineDraw RPoint
37 LineBezier [RPoint]
38 | LineEnd RPoint
39 deriving (Show)
40
41 -- | Convert from line commands to path commands.
42 lineToPath :: [LineCommand] -> [PathCommand]
43 lineToPath = map worker
44 where
45 worker (LineMove p) = MoveTo OriginAbsolute [p]
46 -- worker (LineDraw p) = LineTo OriginAbsolute [p]
47 worker (LineBezier [a, b, c]) = CurveTo OriginAbsolute [(a, b, c)]
48 worker (LineBezier [a, b]) = QuadraticBezier OriginAbsolute [(a, b)]
49 worker (LineBezier [a]) = LineTo OriginAbsolute [a]
50 worker LineBezier {} = error "Reanimate.Svg.lineToPath: invalid bezier curve"
51 worker LineEnd {} = EndPath
52
53 -- | Using @n@ control points, approximate the path of the curves.
54 lineToPoints :: Int -> [LineCommand] -> [RPoint]
55 lineToPoints nPoints cmds =
56 mapMaybe lineEnd lineSegments
57 where
58 lineSegments = [partialLine (fromIntegral n / fromIntegral nPoints) cmds | n <- [0 .. nPoints -1]]
59 lineEnd [] = Nothing
60 lineEnd [LineBezier pts] = Just (last pts)
61 lineEnd (_ : xs) = lineEnd xs
62
63 partialLine :: Double -> [LineCommand] -> [LineCommand]
64 partialLine alpha cmds = evalState (worker 0 cmds) zero
65 where
66 worker _d [] = pure []
67 worker d (cmd : xs) = do
68 from <- get
69 len <- lineLength cmd
70 let frac = (targetLen - d) / len
71 if len == 0 || frac >= 1
72 then (cmd :) <$> worker (d + len) xs
73 else pure [adjustLineLength frac from cmd]
74 totalLen = evalState (sum <$> mapM lineLength cmds) zero
75 targetLen = totalLen * alpha
76
77 adjustLineLength :: Double -> RPoint -> LineCommand -> LineCommand
78 adjustLineLength alpha from cmd =
79 case cmd of
80 LineBezier points -> LineBezier $ drop 1 $ partialBezierPoints (from : points) 0 alpha
81 LineMove p -> LineMove p
82 -- LineDraw t -> LineDraw (lerp alpha t from)
83 LineEnd p -> LineBezier [lerp alpha p from]
84
85 -- | Estimated length of all segments in a line.
86 lineLength :: LineCommand -> CmdM Double
87 lineLength cmd =
88 case cmd of
89 LineMove to -> 0 <$ put to
90 -- Straight line:
91 LineBezier [dst] -> gets (distance dst) <* put dst
92 -- Some kind of curve:
93 LineBezier lst -> do
94 from <- get
95 let bezier = rpointsToBezier (from : lst)
96 tol = 0.0001
97 put (last lst)
98 pure $ Bezier.arcLength bezier 1 tol
99 LineEnd to -> gets (distance to) <* put to
100
101 rpointsToBezier :: [RPoint] -> Bezier.CubicBezier Double
102 rpointsToBezier lst =
103 case lst of
104 [a, b] -> Bezier.CubicBezier a a b b
105 [a, b, c] -> Bezier.quadToCubic (Bezier.QuadBezier a b c)
106 [a, b, c, d] -> Bezier.CubicBezier a b c d
107 _ -> error $ "rpointsToBezier: Invalid list of points: " ++ show lst
108
109 -- | Convert from path commands to line commands.
110 toLineCommands :: [PathCommand] -> [LineCommand]
111 toLineCommands ps = evalState (worker zero Nothing ps) zero
112 where
113 worker _startPos _mbPrevControlPt [] = pure []
114 worker startPos mbPrevControlPt (cmd : cmds) = do
115 lcmds <- toLineCommand startPos mbPrevControlPt cmd
116 let startPos' =
117 case lcmds of
118 [LineMove pos] -> pos
119 _ -> startPos
120 (lcmds ++) <$> worker startPos' (cmdToControlPoint $ last lcmds) cmds
121
122 cmdToControlPoint :: LineCommand -> Maybe RPoint
123 cmdToControlPoint (LineBezier points) = Just (last (init points))
124 cmdToControlPoint _ = Nothing
125
126 mkStraightLine :: RPoint -> LineCommand
127 mkStraightLine p = LineBezier [p]
128
129 toLineCommand :: RPoint -> Maybe RPoint -> PathCommand -> CmdM [LineCommand]
130 toLineCommand startPos mbPrevControlPt cmd =
131 case cmd of
132 MoveTo OriginAbsolute [] -> pure []
133 MoveTo OriginAbsolute lst -> put (last lst) *> gets (pure . LineMove)
134 MoveTo OriginRelative lst -> modify (+ sum lst) *> gets (pure . LineMove)
135 LineTo OriginAbsolute lst -> forM lst (\to -> put to $> mkStraightLine to)
136 LineTo OriginRelative lst -> forM lst (\to -> modify (+ to) *> gets mkStraightLine)
137 HorizontalTo OriginAbsolute lst ->
138 forM lst $ \x -> modify (_x .~ x) *> gets mkStraightLine
139 HorizontalTo OriginRelative lst ->
140 forM lst $ \x -> modify (_x %~ (+ x)) *> gets mkStraightLine
141 VerticalTo OriginAbsolute lst ->
142 forM lst $ \y -> modify (_y .~ y) *> gets mkStraightLine
143 VerticalTo OriginRelative lst ->
144 forM lst $ \y -> modify (_y %~ (+ y)) *> gets mkStraightLine
145 CurveTo OriginAbsolute quads ->
146 forM quads $ \(a, b, c) -> put c $> LineBezier [a, b, c]
147 CurveTo OriginRelative quads ->
148 forM quads $ \(a, b, c) -> do
149 from <- get <* modify (+ c)
150 pure $ LineBezier $ map (+ from) [a, b, c]
151 SmoothCurveTo o lst -> mfix $ \result -> do
152 let ctrl = mbPrevControlPt : map cmdToControlPoint result
153 forM (zip lst ctrl) $ \((c2, to), mbControl) -> do
154 from <- get <* adjustPosition o to
155 let c1 = maybe (makeAbsolute o from c2) (mirrorPoint from) mbControl
156 pure $ LineBezier [c1, makeAbsolute o from c2, makeAbsolute o from to]
157 QuadraticBezier OriginAbsolute pairs ->
158 forM pairs $ \(a, b) -> put b $> LineBezier [a, b]
159 QuadraticBezier OriginRelative pairs ->
160 forM pairs $ \(a, b) -> do
161 from <- get <* modify (+ b)
162 pure $ LineBezier $ map (+ from) [a, b]
163 SmoothQuadraticBezierCurveTo o lst -> mfix $ \result -> do
164 let ctrl = mbPrevControlPt : map cmdToControlPoint result
165 forM (zip lst ctrl) $ \(to, mbControl) -> do
166 from <- get <* adjustPosition o to
167 let c1 = maybe from (mirrorPoint from) mbControl
168 pure $ LineBezier [c1, makeAbsolute o from to]
169 EllipticalArc o points ->
170 concat
171 <$> forM
172 points
173 ( \(rotX, rotY, angle, largeArc, sweepFlag, to) -> do
174 from <- get <* adjustPosition o to
175 return $ convertSvgArc from rotX rotY angle largeArc sweepFlag (makeAbsolute o from to)
176 )
177 EndPath -> put startPos $> [LineEnd startPos]
178 where
179 mirrorPoint c p = c * 2 - p
180 adjustPosition OriginRelative p = modify (+ p)
181 adjustPosition OriginAbsolute p = put p
182 makeAbsolute OriginAbsolute _from p = p
183 makeAbsolute OriginRelative from p = from + p
184
185 calculateVectorAngle :: Double -> Double -> Double -> Double -> Double
186 calculateVectorAngle ux uy vx vy
187 | tb >= ta =
188 tb - ta
189 | otherwise =
190 pi * 2 - (ta - tb)
191 where
192 ta = atan2 uy ux
193 tb = atan2 vy vx
194
195 -- ported from: https://github.com/vvvv/SVG/blob/master/Source/Paths/SvgArcSegment.cs
196 {- HLINT ignore convertSvgArc -}
197 convertSvgArc :: RPoint -> Coord -> Coord -> Coord -> Bool -> Bool -> RPoint -> [LineCommand]
198 convertSvgArc (V2 x0 y0) radiusX radiusY angle largeArcFlag sweepFlag (V2 x y)
199 | x0 == x && y0 == y =
200 []
201 | radiusX == 0.0 && radiusY == 0.0 =
202 [LineBezier [V2 x y]]
203 | otherwise =
204 calcSegments x0 y0 theta1' segments'
205 where
206 sinPhi = sin (angle * pi / 180)
207 cosPhi = cos (angle * pi / 180)
208
209 x1dash = cosPhi * (x0 - x) / 2.0 + sinPhi * (y0 - y) / 2.0
210 y1dash = - sinPhi * (x0 - x) / 2.0 + cosPhi * (y0 - y) / 2.0
211
212 numerator = radiusX * radiusX * radiusY * radiusY - radiusX * radiusX * y1dash * y1dash - radiusY * radiusY * x1dash * x1dash
213
214 s = sqrt (1.0 - numerator / (radiusX * radiusX * radiusY * radiusY))
215 rx = if (numerator < 0.0) then (radiusX * s) else radiusX
216 ry = if (numerator < 0.0) then (radiusY * s) else radiusY
217 root =
218 if (numerator < 0.0)
219 then (0.0)
220 else
221 ( (if ((largeArcFlag && sweepFlag) || (not largeArcFlag && not sweepFlag)) then (-1.0) else 1.0)
222 * sqrt (numerator / (radiusX * radiusX * y1dash * y1dash + radiusY * radiusY * x1dash * x1dash))
223 )
224
225 cxdash = root * rx * y1dash / ry
226 cydash = - root * ry * x1dash / rx
227
228 cx = cosPhi * cxdash - sinPhi * cydash + (x0 + x) / 2.0
229 cy = sinPhi * cxdash + cosPhi * cydash + (y0 + y) / 2.0
230
231 theta1' = calculateVectorAngle 1.0 0.0 ((x1dash - cxdash) / rx) ((y1dash - cydash) / ry)
232 dtheta' = calculateVectorAngle ((x1dash - cxdash) / rx) ((y1dash - cydash) / ry) ((- x1dash - cxdash) / rx) ((- y1dash - cydash) / ry)
233 dtheta =
234 if (not sweepFlag && dtheta' > 0)
235 then (dtheta' - 2 * pi)
236 else (if (sweepFlag && dtheta' < 0) then dtheta' + 2 * pi else dtheta')
237
238 segments' = ceiling (abs (dtheta / (pi / 2.0)))
239 delta = dtheta / fromInteger segments'
240 t = 8.0 / 3.0 * sin (delta / 4.0) * sin (delta / 4.0) / sin (delta / 2.0)
241
242 calcSegments startX startY theta1 segments
243 | segments == 0 =
244 []
245 | otherwise =
246 LineBezier
247 [ V2 (startX + dx1) (startY + dy1),
248 V2 (endpointX + dxe) (endpointY + dye),
249 V2 endpointX endpointY
250 ] :
251 calcSegments endpointX endpointY theta2 (segments - 1)
252 where
253 cosTheta1 = cos theta1
254 sinTheta1 = sin theta1
255 theta2 = theta1 + delta
256 cosTheta2 = cos theta2
257 sinTheta2 = sin theta2
258
259 endpointX = cosPhi * rx * cosTheta2 - sinPhi * ry * sinTheta2 + cx
260 endpointY = sinPhi * rx * cosTheta2 + cosPhi * ry * sinTheta2 + cy
261
262 dx1 = t * (- cosPhi * rx * sinTheta1 - sinPhi * ry * cosTheta1)
263 dy1 = t * (- sinPhi * rx * sinTheta1 + cosPhi * ry * cosTheta1)
264
265 dxe = t * (cosPhi * rx * sinTheta2 + sinPhi * ry * cosTheta2)
266 dye = t * (sinPhi * rx * sinTheta2 - cosPhi * ry * cosTheta2)
267
268 partialBezierPoints :: [RPoint] -> Double -> Double -> [RPoint]
269 partialBezierPoints ps a b =
270 let c1 = Bezier.AnyBezier (V.fromList ps)
271 Bezier.AnyBezier os = Bezier.bezierSubsegment c1 a b
272 in V.toList os
273
274 -- | Create an image showing portion of a path.
275 -- Note that this only affects paths (see 'Reanimate.Svg.Constructors.mkPath').
276 -- You can also use this with other SVG shapes if you convert them to path first (see 'Reanimate.Svg.pathify').
277 --
278 -- Typical usage:
279 --
280 -- > animate $ \t -> partialSvg t myPath
281 partialSvg ::
282 -- | number between 0 and 1 inclusively, determining what portion of the path to show
283 Double ->
284 -- | Image representing a path, of which we only want to display a portion determined by the first argument
285 Tree ->
286 Tree
287 partialSvg alpha | alpha >= 1 = id
288 partialSvg alpha = mapTree worker
289 where
290 worker (PathTree path) =
291 PathTree $ path & pathDefinition %~ lineToPath . partialLine alpha . toLineCommands
292 worker t = t