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