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 -- plPartial' :: Double -> ([RPoint], PolyShape) -> PolyShape
142 -- plPartial' delta (seen', PolyShape (ClosedPath lst)) =
143 -- case lst of
144 -- [] -> PolyShape (ClosedPath [])
145 -- (startP, startJoin) : rest -> PolyShape $ ClosedPath $
146 -- (startP, startJoin) : worker startP rest
147 -- where
148 -- seen = filter (`elem` plPoints) seen'
149 -- closestSeen pt = minimumBy (comparing (vectorDistance pt)) seen
150 -- worker _ [] = []
151 -- worker _ ((newP, newJoin) : rest)
152 -- | newP `elem` seen = (newP, newJoin) : worker newP rest
153 -- | otherwise =
154 -- let newAt = interpolateVector (closestSeen newP) newP delta
155 -- in (newAt, newJoin) : worker newAt rest
156 -- plPoints =
157 -- [ p | (p,_) <- lst ]
158
159 -- | Find intersection points.
160 plGroupTouching :: [PolyShape] -> [[([RPoint],PolyShape)]]
161 plGroupTouching [] = []
162 plGroupTouching pls = worker [polyShapeOrigin (head pls)] pls
163 where
164 worker _ [] = []
165 worker seen shapes =
166 let (touching, notTouching) = partition (isTouching seen) shapes
167 in if null touching
168 then plGroupTouching notTouching
169 else map ((,) seen . changeOrigin seen) touching :
170 worker (seen ++ concatMap plPoints touching) notTouching
171 isTouching pts = any (`elem` pts) . plPoints
172 changeOrigin seen (PolyShape (ClosedPath segments)) = PolyShape $ ClosedPath $ helper [] segments
173 where
174 helper acc [] = reverse acc
175 helper acc lst@((startP,startJ):rest)
176 | startP `elem` seen = lst ++ reverse acc
177 | otherwise = helper ((startP, startJ):acc) rest
178 plPoints :: PolyShape -> [RPoint]
179 plPoints (PolyShape (ClosedPath lst)) =
180 [ p | (p,_) <- lst ]
181
182 -- | Deconstruct a polyshape into non-intersecting, convex polygons.
183 plDecompose :: [PolyShape] -> [[RPoint]]
184 plDecompose = plDecompose' 0.001
185
186 -- | Deconstruct a polyshape into non-intersecting, convex polygons.
187 plDecompose' :: Double -> [PolyShape] -> [[RPoint]]
188 plDecompose' tol =
189 concatMap (decomposePolygon . plPolygonify tol . mergePolyShapeHoles) .
190 plGroupShapes .
191 unionPolyShapes
192
193 -- | Split polygon into smaller, convex polygons.
194 decomposePolygon :: [RPoint] -> [[RPoint]]
195 decomposePolygon poly =
196 [ [ V2 x y
197 | v <- V.toList (Geo.boundaryVertices f pg)
198 , let Geo.Point2 x y = pg^.Geo.vertexDataOf v . Geo.location ]
199 | (f, Inside) <- V.toList (Geo.internalFaces pg) ]
200
201 where
202 pg = triangulate' Proxy p
203 p = Geo.fromPoints $
204 [ Geo.Point2 x y :+ ()
205 | V2 x y <- poly ]
206
207 plPolygonify :: Double -> PolyShape -> [RPoint]
208 plPolygonify tol shape =
209 startPoint (head curves) : concatMap worker curves
210 where
211 curves = plCurves shape
212 worker c | endPoint c == startPoint c =
213 [] -- error $ "Bad bezier: " ++ show c
214 worker c =
215 if colinear c tol -- && arcLength c 1 tol < 1
216 then [endPoint c]
217 else
218 let (lhs,rhs) = splitBezier c 0.5
219 in worker lhs ++ worker rhs
220 endPoint (CubicBezier _ _ _ d) = d
221 startPoint (CubicBezier a _ _ _) = a
222
223 -- | Convert a polyshape to a list of SVG path commands.
224 plPathCommands :: PolyShape -> [PathCommand]
225 plPathCommands = lineToPath . plLineCommands
226
227 -- | Convert a polyshape to a list of line commands.
228 plLineCommands :: PolyShape -> [LineCommand]
229 plLineCommands pl =
230 case curves of
231 [] -> []
232 (CubicBezier start _ _ _:_) ->
233 LineMove start :
234 zipWith worker (drop 1 dstList ++ [start]) joinList ++
235 [LineEnd start]
236 where
237 ClosedPath closedPath = unPolyShape pl
238 (dstList, joinList) = unzip closedPath
239 curves = plCurves pl
240 worker dst JoinLine =
241 LineBezier [dst]
242 worker dst (JoinCurve a b) =
243 LineBezier [a,b,dst]
244
245 -- | Extract all shapes from SVG nodes. Drawing attributes such
246 -- as stroke and fill color are discarded.
247 svgToPolyShapes :: Tree -> [PolyShape]
248 svgToPolyShapes = cmdsToPolyShapes . toLineCommands . extractPath
249
250 -- | Extract all polygons from SVG nodes. Curves are approximated to
251 -- within the given tolerance.
252 svgToPolygons :: Double -> SVG -> [Polygon]
253 svgToPolygons tol = map (toPolygon . plPolygonify tol) . svgToPolyShapes
254 where
255 toPolygon :: [RPoint] -> Polygon
256 toPolygon = mkPolygon .
257 V.fromList . nub . map (fmap realToFrac)
258
259 cmdsToPolyShapes :: [LineCommand] -> [PolyShape]
260 cmdsToPolyShapes [] = []
261 cmdsToPolyShapes cmds =
262 case cmds of
263 (LineMove dst:cont) -> map PolyShape $ worker dst [] cont
264 _ -> bad
265 where
266 bad = error $ "Reanimate.PolyShape: Invalid commands: " ++ show cmds
267 finalize [] rest = rest
268 finalize acc rest = ClosedPath (reverse acc) : rest
269 worker _from acc [] = finalize acc []
270 worker _from acc (LineMove newStart : xs) =
271 finalize acc $
272 worker newStart [] xs
273 worker from acc (LineEnd orig:LineMove dst:xs) | from /= orig =
274 finalize ((from, JoinLine):acc) $
275 worker dst [] xs
276 worker _from acc (LineEnd{}:LineMove dst:xs) =
277 finalize acc $
278 worker dst [] xs
279 worker from acc [LineEnd orig] | from /= orig =
280 finalize ((from, JoinLine):acc) []
281 worker _from acc [LineEnd{}] =
282 finalize acc []
283 worker from acc (LineBezier [x]:xs) =
284 worker x ((from, JoinLine) : acc) xs
285 worker from acc (LineBezier [a,b]:xs) =
286 let quad = QuadBezier from a b
287 CubicBezier _ a' b' c' = quadToCubic quad
288 in worker from acc (LineBezier [a',b',c']:xs)
289 worker from acc (LineBezier [a,b,c]:xs) =
290 worker c ((from, JoinCurve a b) : acc) xs
291 worker _ _ _ = bad
292
293 -- | Merge overlapping shapes.
294 unionPolyShapes :: [PolyShape] -> [PolyShape]
295 unionPolyShapes shapes =
296 map PolyShape $
297 union (map unPolyShape shapes) FillNonZero (polyShapeTolerance/10000)
298
299 -- | Merge overlapping shapes to within given tolerance.
300 unionPolyShapes' :: Double -> [PolyShape] -> [PolyShape]
301 unionPolyShapes' tol shapes =
302 map PolyShape $
303 union (map unPolyShape shapes) FillNonZero tol
304
305 -- | True iff lhs is inside of rhs.
306 -- lhs and rhs may not overlap.
307 -- Implementation: Trace a vertical line through the origin of A and check
308 -- of this line intersects and odd number of times on both sides of A.
309 isInsideOf :: PolyShape -> PolyShape -> Bool
310 lhs `isInsideOf` rhs =
311 odd (length upHits) && odd (length downHits)
312 where
313 (upHits, downHits) = polyIntersections origin rhs
314 origin = polyShapeOrigin lhs
315
316 polyIntersections :: RPoint -> PolyShape -> ([RPoint],[RPoint])
317 polyIntersections origin rhs =
318 (nub $ concatMap (intersections rayUp) curves
319 ,nub $ concatMap (intersections rayDown) curves)
320 where
321 curves = plCurves rhs
322
323 intersections line bs =
324 map (evalBezier bs . fst) (bezierIntersection bs line polyShapeTolerance)
325 limit = 1000
326 rayUp = CubicBezier origin origin origin (V2 limit limit)
327 rayDown = CubicBezier origin origin origin (V2 (-limit) (-limit))
328
329 polyShapeOrigin :: PolyShape -> V2 Double
330 polyShapeOrigin (PolyShape closedPath) =
331 case closedPath of
332 ClosedPath [] -> V2 0 0
333 ClosedPath ((start,_):_) -> start
334
335 -- | Find holes and group them with their parent.
336 plGroupShapes :: [PolyShape] -> [PolyShapeWithHoles]
337 plGroupShapes = worker
338 where
339 worker (s:rest)
340 | null (parents s rest) =
341 let isOnlyChild x = parents x (s:rest) == [s]
342 (holes, nonHoles) = partition isOnlyChild rest
343 prime = PolyShapeWithHoles
344 { polyShapeParent = s
345 , polyShapeHoles = holes }
346 in prime : worker nonHoles
347 | otherwise = worker (rest ++ [s])
348 worker [] = []
349
350 parents :: PolyShape -> [PolyShape] -> [PolyShape]
351 parents self = filter (self `isInsideOf`) . filter (/=self)
352
353 instance Eq PolyShape where
354 a == b = plCurves a == plCurves b
355
356 -- | Cut out holes.
357 mergePolyShapeHoles :: PolyShapeWithHoles -> PolyShape
358 mergePolyShapeHoles (PolyShapeWithHoles parent []) = parent
359 mergePolyShapeHoles (PolyShapeWithHoles parent (child:children)) =
360 mergePolyShapeHoles $
361 PolyShapeWithHoles (mergePolyShapeHole parent child) children
362
363 -- Merge
364 mergePolyShapeHole :: PolyShape -> PolyShape -> PolyShape
365 mergePolyShapeHole parent child =
366 snd $ head $
367 sortOn fst
368 [ cutSingleHole newParent child
369 | newParent <- polyShapePermutations parent ]
370
371 {-
372 parent:
373 (a,b)
374 (b,c)
375 (c,a)
376
377 child:
378 (x,y)
379 (y,z)
380 (z,x)
381
382 P = split (a,b)
383 new:
384 (P,b) p2b
385 (b,c) pTail
386 (c,a) pTail
387 (a,P) a2p
388
389 (P,x) p2x
390
391 (x,y) childCurves
392 (y,z) childCurves
393 (z,x) childCurves
394
395 (x,P) x2p
396
397 -}
398 cutSingleHole :: PolyShape -> PolyShape -> (Double, PolyShape)
399 cutSingleHole parent child =
400 (score, PolyShape $ curvesToClosed $
401 p2b:pTail ++ [a2p] ++
402 [p2x] ++ childCurves ++
403 [x2p]
404 )
405 where
406 -- vect = (childOrigin - p) * 0 -- 0.0001
407 vectL = 0 -- rotate90L $* vect
408 vectR = 0 -- rotate90R $* vect
409 score = vectorDistance childOrigin p
410 childOrigin = polyShapeOrigin child
411 childOrigin' = childOrigin - vectL
412 (pHead:pTail) = plCurves parent
413 childCurves = plCurves child
414
415 pParam = closest pHead childOrigin polyShapeTolerance
416
417 (a2p, p2b') = splitBezier pHead pParam
418 p2b = case p2b' of
419 CubicBezier a b c d -> CubicBezier (a - vectL) b c d
420
421 p = evalBezier pHead pParam
422 -- straight line to child origin
423 p2x = lineBetween (p - vectR) childOrigin
424 -- straight line from child origin
425 x2p = lineBetween childOrigin' p
426
427 lineBetween a = CubicBezier a a a
428
429 -- | Destruct a polyshape into constituent curves.
430 plCurves :: PolyShape -> [CubicBezier Double]
431 plCurves = closedPathCurves . unPolyShape
432
433 polyShapePermutations :: PolyShape -> [PolyShape]
434 polyShapePermutations =
435 map (PolyShape . curvesToClosed) . cycleList . plCurves
436 where
437 cycleList lst =
438 let n = length lst in
439 [ take n $ drop i $ cycle lst
440 | i <- [0.. n-1] ]