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