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