never executed always true always false
1 module Reanimate.PolyShape
2 ( PolyShape(..)
3 , PolyShapeWithHoles(..)
4 , svgToPolyShapes -- :: Tree -> [PolyShape]
5 , svgToPolygons -- :: Double -> Svg -> [Polygon]
6
7 , renderPolyShape -- :: PolyShape -> Tree
8 , renderPolyShapes -- :: [PolyShape] -> Tree
9 , renderPolyShapePoints -- :: PolyShape -> Tree
10
11 , plPathCommands -- :: PolyShape -> [PathCommand]
12 , plLineCommands -- :: PolyShape -> [LineCommand]
13
14 , plLength -- :: PolyShape -> Double
15 , plArea
16 , plCurves -- :: PolyShape -> [CubicBezier Double]
17 , isInsideOf -- :: PolyShape -> PolyShape -> Bool
18
19 , plFromPolygon -- :: [RPoint] -> PolyShape
20 , plToPolygon -- :: Double -> PolyShape -> Polygon
21 , plPolygonify -- :: Double -> PolyShape -> [Point Double]
22 , plDecompose -- :: [PolyShape] -> [[RPoint]]
23 , unionPolyShapes -- :: [PolyShape] -> [PolyShape]
24 , unionPolyShapes' -- :: Double -> [PolyShape] -> [PolyShape]
25 , plDecompose' -- :: Double -> [PolyShape] -> [[RPoint]]
26 , decomposePolygon -- :: [Point Double] -> [[RPoint]]
27 , plGroupShapes -- :: [PolyShape] -> [PolyShapeWithHoles]
28 , mergePolyShapeHoles -- :: PolyShapeWithHoles -> PolyShape
29 , polyShapeTolerance
30 , plPartial, plPartialGroup, plPartial'
31 , splitPolyShape -- :: Double -> Int -> PolyShape -> [PolyShape]
32 , plGroupTouching
33 ) where
34
35 import Control.Lens ((&), (.~))
36 import Data.List (minimumBy, nub, partition,
37 sortOn)
38 import Data.Ord
39 import qualified Data.Vector as V
40 import Geometry.Earcut
41 import Graphics.SvgTree (PathCommand (..), RPoint,
42 Tree (..), defaultSvg,
43 pathDefinition)
44 import Linear.V2
45 import Reanimate.Animation
46 import Reanimate.Constants
47 import Reanimate.Internal.CubicBezier (ClosedPath (..),
48 CubicBezier (..),
49 FillRule (..), PathJoin (..),
50 QuadBezier (..), arcLength,
51 arcLengthParam,
52 bezierIntersection,
53 bezierSubsegment,
54 closedPathCurves, closest,
55 colinear, curvesToClosed,
56 evalBezier, interpolateVector,
57 quadToCubic, reorient,
58 splitBezier, union,
59 vectorDistance)
60 import Reanimate.Math.EarClip
61 import Reanimate.Math.Polygon (Polygon, mkPolygon, pArea,
62 pIsCCW, pRing, pdualPolygons,
63 polygonPoints)
64 import Reanimate.Math.SSSP
65 import Reanimate.Svg
66
67 -- | Shape drawn by continuous line. May have overlap, may be convex.
68 newtype PolyShape = PolyShape { unPolyShape :: ClosedPath Double }
69 deriving (Show)
70
71 data PolyShapeWithHoles = PolyShapeWithHoles
72 { polyShapeParent :: PolyShape
73 , polyShapeHoles :: [PolyShape]
74 }
75
76
77 renderPolyShapes :: [PolyShape] -> Tree
78 renderPolyShapes pls =
79 PathTree $ defaultSvg & pathDefinition .~ concatMap plPathCommands pls
80
81 renderPolyShape :: PolyShape -> Tree
82 renderPolyShape pl =
83 PathTree $ defaultSvg & pathDefinition .~ plPathCommands pl
84
85 renderPolyShapePoints :: PolyShape -> Tree
86 renderPolyShapePoints = mkGroup . map renderPoint . plCurves
87 where
88 renderPoint (CubicBezier (V2 x y) _ _ _) =
89 translate x y $ mkCircle 0.02
90
91 plLength :: PolyShape -> Double
92 plLength = sum . map cubicLength . plCurves
93 where
94 cubicLength c = arcLength c 1 polyShapeTolerance
95
96 plArea :: PolyShape -> Double
97 plArea pl = realToFrac $ pArea $ plToPolygon polyShapeTolerance pl
98
99 -- 1/10th of a pixel if rendered at 2560x1440
100 polyShapeTolerance :: Double
101 polyShapeTolerance = screenWidth/25600
102
103 plFromPolygon :: [RPoint] -> PolyShape
104 plFromPolygon = PolyShape . ClosedPath . map worker
105 where
106 worker val = (val, JoinLine)
107
108 plToPolygon :: Double -> PolyShape -> Polygon
109 plToPolygon tol pl =
110 let p = V.init . V.fromList . map (fmap realToFrac) .
111 plPolygonify tol $ pl
112 in if pIsCCW (mkPolygon p) then mkPolygon p else mkPolygon (V.reverse p)
113
114
115 plPartial :: Double -> PolyShape -> PolyShape
116 plPartial delta pl | delta >= 1 = pl
117 plPartial delta pl = PolyShape $ curvesToClosed (lineOut ++ [joinB] ++ lineIn)
118 where
119 lineOutEnd = cubicC3 (last lineOut)
120 lineInBegin = cubicC0 (head lineIn)
121 joinB = CubicBezier lineOutEnd lineOutEnd lineOutEnd lineInBegin
122 lineOut = takeLen (len*delta/2) $ plCurves pl
123 lineIn =
124 reverse $ map reorient $
125 takeLen (len*delta/2) $ reverse $ map reorient $ plCurves pl
126 len = plLength pl
127 takeLen _ [] = []
128 takeLen l (c:cs) =
129 let cLen = arcLength c 1 polyShapeTolerance in
130 if l < cLen
131 then [bezierSubsegment c 0 (arcLengthParam c l polyShapeTolerance)]
132 else c : takeLen (l-cLen) cs
133
134 -- earClip :: Polygon -> Triangulation
135 -- dual :: Triangulation -> Dual
136 -- toPDual :: Polygon -> Dual -> PDual
137 -- pdualReduce :: Polygon -> PDual -> Int -> PDual
138 -- pdualPolygons :: Polygon -> PDual -> [Polygon]
139 splitPolyShape :: Double -> Int -> PolyShape -> [PolyShape]
140 splitPolyShape tol n poly =
141 let polygon = toPolygon (plPolygonify tol poly)
142 trig = earClip $ pRing polygon
143 d = dual 0 trig
144 pd = toPDual (pRing polygon) d
145 reduced = pdualReduce (pRing polygon) pd n
146 polygons = pdualPolygons polygon reduced
147 in map toPolyShape polygons
148 where
149 toPolygon :: [RPoint] -> Polygon
150 toPolygon = mkPolygon . V.fromList . nub . map (fmap realToFrac)
151 toPolyShape :: Polygon -> PolyShape
152 toPolyShape = plFromPolygon . map (fmap realToFrac) . V.toList . polygonPoints
153
154 plPartialGroup :: Double -> [PolyShape] -> [PolyShape]
155 plPartialGroup _delta [] = []
156 plPartialGroup delta pls =
157 [ plPartial (delta*(maxLen/plLength pl)) pl | pl <- pls ]
158 where
159 maxLen = maximum $ map plLength pls
160
161 plPartial' :: Double -> ([RPoint], PolyShape) -> PolyShape
162 plPartial' delta (seen', PolyShape (ClosedPath lst)) =
163 case lst of
164 [] -> PolyShape (ClosedPath [])
165 (startP, startJoin) : rest -> PolyShape $ ClosedPath $
166 (startP, startJoin) : worker startP rest
167 where
168 seen = filter (`elem` plPoints) seen'
169 closestSeen pt = minimumBy (comparing (vectorDistance pt)) seen
170 worker _ [] = []
171 worker _ ((newP, newJoin) : rest)
172 | newP `elem` seen = (newP, newJoin) : worker newP rest
173 | otherwise =
174 let newAt = interpolateVector (closestSeen newP) newP delta
175 in (newAt, newJoin) : worker newAt rest
176 plPoints =
177 [ p | (p,_) <- lst ]
178
179 plGroupTouching :: [PolyShape] -> [[([RPoint],PolyShape)]]
180 plGroupTouching [] = []
181 plGroupTouching pls = worker [polyShapeOrigin (head pls)] pls
182 where
183 worker _ [] = []
184 worker seen shapes =
185 let (touching, notTouching) = partition (isTouching seen) shapes
186 in if null touching
187 then plGroupTouching notTouching
188 else map ((,) seen . changeOrigin seen) touching :
189 worker (seen ++ concatMap plPoints touching) notTouching
190 isTouching pts = any (`elem` pts) . plPoints
191 changeOrigin seen (PolyShape (ClosedPath segments)) = PolyShape $ ClosedPath $ helper [] segments
192 where
193 helper acc [] = reverse acc
194 helper acc lst@((startP,startJ):rest)
195 | startP `elem` seen = lst ++ reverse acc
196 | otherwise = helper ((startP, startJ):acc) rest
197 plPoints :: PolyShape -> [RPoint]
198 plPoints (PolyShape (ClosedPath lst)) =
199 [ p | (p,_) <- lst ]
200
201 -- | Deconstruct a polyshape into non-intersecting, convex polygons.
202 plDecompose :: [PolyShape] -> [[RPoint]]
203 plDecompose = plDecompose' 0.001
204
205 -- | Deconstruct a polyshape into non-intersecting, convex polygons.
206 plDecompose' :: Double -> [PolyShape] -> [[RPoint]]
207 plDecompose' tol =
208 concatMap (decomposePolygon . plPolygonify tol . mergePolyShapeHoles) .
209 plGroupShapes .
210 unionPolyShapes
211
212 decomposePolygon :: [RPoint] -> [[RPoint]]
213 decomposePolygon poly =
214 map toPoly $ V.toList $ earcut [ (a,b) | V2 a b <- poly ]
215 where
216 toPoly (a,b,c) = [poly!!a, poly!!b, poly!!c]
217
218 plPolygonify :: Double -> PolyShape -> [RPoint]
219 plPolygonify tol shape =
220 startPoint (head curves) : concatMap worker curves
221 where
222 curves = plCurves shape
223 worker c | endPoint c == startPoint c =
224 [] -- error $ "Bad bezier: " ++ show c
225 worker c =
226 if colinear c tol -- && arcLength c 1 tol < 1
227 then [endPoint c]
228 else
229 let (lhs,rhs) = splitBezier c 0.5
230 in worker lhs ++ worker rhs
231 endPoint (CubicBezier _ _ _ d) = d
232 startPoint (CubicBezier a _ _ _) = a
233
234
235 plPathCommands :: PolyShape -> [PathCommand]
236 plPathCommands = lineToPath . plLineCommands
237
238 plLineCommands :: PolyShape -> [LineCommand]
239 plLineCommands pl =
240 case curves of
241 [] -> []
242 (CubicBezier start _ _ _:_) ->
243 LineMove start :
244 zipWith worker (drop 1 dstList ++ [start]) joinList ++
245 [LineEnd start]
246 where
247 ClosedPath closedPath = unPolyShape pl
248 (dstList, joinList) = unzip closedPath
249 curves = plCurves pl
250 worker dst JoinLine =
251 LineBezier [dst]
252 worker dst (JoinCurve a b) =
253 LineBezier [a,b,dst]
254
255 svgToPolyShapes :: Tree -> [PolyShape]
256 svgToPolyShapes = cmdsToPolyShapes . toLineCommands . extractPath
257
258 svgToPolygons :: Double -> SVG -> [Polygon]
259 svgToPolygons tol = map (toPolygon . plPolygonify tol) . svgToPolyShapes
260 where
261 toPolygon :: [RPoint] -> Polygon
262 toPolygon = mkPolygon .
263 V.fromList . nub . map (fmap realToFrac)
264
265 cmdsToPolyShapes :: [LineCommand] -> [PolyShape]
266 cmdsToPolyShapes [] = []
267 cmdsToPolyShapes cmds =
268 case cmds of
269 (LineMove dst:cont) -> map PolyShape $ worker dst [] cont
270 _ -> bad
271 where
272 bad = error $ "Reanimate.PolyShape: Invalid commands: " ++ show cmds
273 finalize [] rest = rest
274 finalize acc rest = ClosedPath (reverse acc) : rest
275 worker _from acc [] = finalize acc []
276 worker _from acc (LineMove newStart : xs) =
277 finalize acc $
278 worker newStart [] xs
279 worker from acc (LineEnd orig:LineMove dst:xs) | from /= orig =
280 finalize ((from, JoinLine):acc) $
281 worker dst [] xs
282 worker _from acc (LineEnd{}:LineMove dst:xs) =
283 finalize acc $
284 worker dst [] xs
285 worker from acc [LineEnd orig] | from /= orig =
286 finalize ((from, JoinLine):acc) []
287 worker _from acc [LineEnd{}] =
288 finalize acc []
289 worker from acc (LineBezier [x]:xs) =
290 worker x ((from, JoinLine) : acc) xs
291 worker from acc (LineBezier [a,b]:xs) =
292 let quad = QuadBezier from a b
293 CubicBezier _ a' b' c' = quadToCubic quad
294 in worker from acc (LineBezier [a',b',c']:xs)
295 worker from acc (LineBezier [a,b,c]:xs) =
296 worker c ((from, JoinCurve a b) : acc) xs
297 worker _ _ _ = bad
298
299 unionPolyShapes :: [PolyShape] -> [PolyShape]
300 unionPolyShapes shapes =
301 map PolyShape $
302 union (map unPolyShape shapes) NonZero (polyShapeTolerance/10000)
303
304 unionPolyShapes' :: Double -> [PolyShape] -> [PolyShape]
305 unionPolyShapes' tol shapes =
306 map PolyShape $
307 union (map unPolyShape shapes) NonZero tol
308
309 -- True iff lhs is inside of rhs.
310 -- lhs and rhs may not overlap.
311 -- Implementation: Trace a vertical line through the origin of A and check
312 -- of this line intersects and odd number of times on both sides of A.
313 isInsideOf :: PolyShape -> PolyShape -> Bool
314 lhs `isInsideOf` rhs =
315 odd (length upHits) && odd (length downHits)
316 where
317 (upHits, downHits) = polyIntersections origin rhs
318 origin = polyShapeOrigin lhs
319
320 polyIntersections :: RPoint -> PolyShape -> ([RPoint],[RPoint])
321 polyIntersections origin rhs =
322 (nub $ concatMap (intersections rayUp) curves
323 ,nub $ concatMap (intersections rayDown) curves)
324 where
325 curves = plCurves rhs
326
327 intersections line bs =
328 map (evalBezier bs . fst) (bezierIntersection bs line polyShapeTolerance)
329 limit = 1000
330 rayUp = CubicBezier origin origin origin (V2 limit limit)
331 rayDown = CubicBezier origin origin origin (V2 (-limit) (-limit))
332
333 polyShapeOrigin :: PolyShape -> V2 Double
334 polyShapeOrigin (PolyShape closedPath) =
335 case closedPath of
336 ClosedPath [] -> V2 0 0
337 ClosedPath ((start,_):_) -> start
338
339 plGroupShapes :: [PolyShape] -> [PolyShapeWithHoles]
340 plGroupShapes = worker
341 where
342 worker (s:rest)
343 | null (parents s rest) =
344 let isOnlyChild x = parents x (s:rest) == [s]
345 (holes, nonHoles) = partition isOnlyChild rest
346 prime = PolyShapeWithHoles
347 { polyShapeParent = s
348 , polyShapeHoles = holes }
349 in prime : worker nonHoles
350 | otherwise = worker (rest ++ [s])
351 worker [] = []
352
353 parents :: PolyShape -> [PolyShape] -> [PolyShape]
354 parents self = filter (self `isInsideOf`) . filter (/=self)
355
356 instance Eq PolyShape where
357 a == b = plCurves a == plCurves b
358
359 mergePolyShapeHoles :: PolyShapeWithHoles -> PolyShape
360 mergePolyShapeHoles (PolyShapeWithHoles parent []) = parent
361 mergePolyShapeHoles (PolyShapeWithHoles parent (child:children)) =
362 mergePolyShapeHoles $
363 PolyShapeWithHoles (mergePolyShapeHole parent child) children
364
365 -- Merge
366 mergePolyShapeHole :: PolyShape -> PolyShape -> PolyShape
367 mergePolyShapeHole parent child =
368 snd $ head $
369 sortOn fst
370 [ cutSingleHole newParent child
371 | newParent <- polyShapePermutations parent ]
372
373 {-
374 parent:
375 (a,b)
376 (b,c)
377 (c,a)
378
379 child:
380 (x,y)
381 (y,z)
382 (z,x)
383
384 P = split (a,b)
385 new:
386 (P,b) p2b
387 (b,c) pTail
388 (c,a) pTail
389 (a,P) a2p
390
391 (P,x) p2x
392
393 (x,y) childCurves
394 (y,z) childCurves
395 (z,x) childCurves
396
397 (x,P) x2p
398
399 -}
400 cutSingleHole :: PolyShape -> PolyShape -> (Double, PolyShape)
401 cutSingleHole parent child =
402 (score, PolyShape $ curvesToClosed $
403 p2b:pTail ++ [a2p] ++
404 [p2x] ++ childCurves ++
405 [x2p]
406 )
407 where
408 -- vect = (childOrigin - p) * 0 -- 0.0001
409 vectL = 0 -- rotate90L $* vect
410 vectR = 0 -- rotate90R $* vect
411 score = vectorDistance childOrigin p
412 childOrigin = polyShapeOrigin child
413 childOrigin' = childOrigin - vectL
414 (pHead:pTail) = plCurves parent
415 childCurves = plCurves child
416
417 pParam = closest pHead childOrigin polyShapeTolerance
418
419 (a2p, p2b') = splitBezier pHead pParam
420 p2b = case p2b' of
421 CubicBezier a b c d -> CubicBezier (a - vectL) b c d
422
423 p = evalBezier pHead pParam
424 -- straight line to child origin
425 p2x = lineBetween (p - vectR) childOrigin
426 -- straight line from child origin
427 x2p = lineBetween childOrigin' p
428
429 lineBetween a = CubicBezier a a a
430
431 plCurves :: PolyShape -> [CubicBezier Double]
432 plCurves = closedPathCurves . unPolyShape
433
434 polyShapePermutations :: PolyShape -> [PolyShape]
435 polyShapePermutations =
436 map (PolyShape . curvesToClosed) . cycleList . plCurves
437 where
438 cycleList lst =
439 let n = length lst in
440 [ take n $ drop i $ cycle lst
441 | i <- [0.. n-1] ]