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