never executed always true always false
1 {-# LANGUAGE BangPatterns #-}
2 {-# LANGUAGE ConstraintKinds #-}
3 module Reanimate.Math.Polygon
4 ( APolygon(..)
5 , Polygon
6 , FPolygon
7 , P
8 , mkPolygon -- :: (Fractional a, Ord a) => V.Vector (V2 a) -> APolygon a
9 , mkPolygonFromRing -- :: (Fractional a, Ord a) => Ring a -> APolygon a
10 , castPolygon -- :: (Real a, Fractional b, Ord a) => APolygon a -> APolygon b
11 , pParent -- :: Polygon -> Int -> Int -> Int
12 , pSetOffset -- :: APolygon a -> Int -> APolygon a
13 , pAdjustOffset -- :: APolygon a -> Int -> APolygon a
14 , pSize -- :: APolygon a -> Int
15 , pNull -- :: APolygon a -> Bool
16 , pNext -- :: APolygon a -> Int -> Int
17 , pPrev -- :: APolygon a -> Int -> Int
18 , pIsSimple -- :: Polygon -> Bool
19 , pIsConvex -- :: Polygon -> Bool
20 , pIsCCW -- :: Polygon -> Bool
21 , pScale -- :: Rational -> Polygon -> Polygon
22 , pAtCentroid -- :: Polygon -> Polygon
23 , pAtCenter -- :: Polygon -> Polygon
24 , pTranslate -- :: V2 Rational -> Polygon -> Polygon
25 , pCenter -- :: Polygon -> V2 Rational
26 , pBoundingBox -- :: Polygon -> (Rational, Rational, Rational, Rational)
27 , pIsInside -- :: Polygon -> V2 Rational -> Bool
28 , pAccess -- :: APolygon a -> Int -> V2 a
29 , pMkWinding -- :: Int -> Polygon
30 , pDeoverlap -- :: Polygon -> Polygon
31 , pCycles -- :: Polygon -> [Polygon]
32 , pCycle -- :: (Real a, Fractional a, Ord a) => APolygon a -> Double -> APolygon a
33 , pCentroid -- :: Polygon -> V2 Rational
34 , pMapEdges -- :: (V2 Rational -> V2 Rational -> a) -> Polygon -> V.Vector a
35 , pArea -- :: Polygon -> Rational
36 , pCircumference -- :: (Real a, Fractional a) => APolygon a -> a
37 , pCircumference' -- :: (Real a, Fractional a) => APolygon a -> Double
38 , pAddPoints -- :: Int -> Polygon -> Polygon
39 , pAddPointsRestricted -- :: [Int] -> Int -> Polygon -> Polygon
40 , pAddPointsBetween -- :: (Fractional a, Ord a, Real a) => (Int, Int) -> Int -> APolygon a -> APolygon a
41 , pRayIntersect -- :: Polygon -> (Int, Int) -> (Int,Int) -> Maybe (V2 Rational)
42 , pOverlap -- :: Polygon -> Polygon -> Polygon
43 , pCuts -- :: Polygon -> [(Polygon,Polygon)]
44 , pCutEqual -- :: Polygon -> (Polygon, Polygon)
45 -- * Triangulation
46 , isValidTriangulation -- :: Polygon -> Triangulation -> Bool
47 , triangulationsToPolygons -- :: Polygon -> Triangulation -> [Polygon]
48 -- * Single-Source-Shortest-Path
49 , ssspVisibility -- :: Polygon -> Polygon
50 , ssspWindows -- :: Polygon -> [(V2 Rational, V2 Rational)]
51 -- * Duals
52 , pdualPolygons -- :: Polygon -> PDual -> [Polygon]
53 -- * Built-in shapes for testing
54 , triangle -- :: Polygon
55 , triangle' -- :: [P]
56 , shape1 -- :: Polygon
57 , shape2 -- :: Polygon
58 , shape3 -- :: Polygon
59 , shape4 -- :: Polygon
60 , shape5 -- :: Polygon
61 , shape6 -- :: Polygon
62 , shape7 -- :: Polygon
63 , shape8 -- :: Polygon
64 , shape9 -- :: Polygon
65 , shape10 -- :: Polygon
66 , shape11 -- :: Polygon
67 , shape12 -- :: Polygon
68 , shape13 -- :: Polygon
69 , shape14 -- :: Polygon
70 , shape15 -- :: Polygon
71 , shape16 -- :: Polygon
72 , shape17 -- :: Polygon
73 , shape18 -- :: Polygon
74 , shape19 -- :: Polygon
75 , shape20 -- :: Polygon
76 , shape21 -- :: Polygon
77 , shape22 -- :: Polygon
78 , shape23 -- :: Polygon
79 , concave -- :: Polygon
80 -- * Internals
81 , pRing -- :: APolygon a -> Ring a
82 , pUnsafeMap -- :: (Ring a -> Ring a) -> APolygon a -> APolygon a
83 , pCopy -- :: Polygon -> Polygon
84 , pGenerate -- :: [(Double, Double)] -> Polygon
85 , pUnGenerate -- :: Polygon -> [(Double, Double)]
86 , Epsilon
87 ) where
88
89 -- import Control.Exception
90 import Data.Hashable
91 import Data.List (intersect, maximumBy, sort, sortOn,
92 tails)
93 import Data.Maybe
94 import Data.Ratio
95 import Data.Serialize
96 import Data.Vector (Vector)
97 import qualified Data.Vector as V
98 import Linear.V2
99 import Linear.Vector
100 import Reanimate.Math.Common
101 import Reanimate.Math.EarClip
102 import Reanimate.Math.SSSP
103 import Reanimate.Math.Triangulate
104
105 -- import Debug.Trace
106
107 -- Generate random polygons, options:
108 -- 1. put corners around a circle. Vary the radius.
109 -- 2. close a hilbert curve
110 type FPolygon = APolygon Double
111 -- Optimize representation?
112 -- Polygon = (Vector XNumerator, Vector XDenominator
113 -- ,Vector YNumerator, Vector YDenominator)
114 data APolygon a = Polygon
115 { polygonPoints :: Vector (V2 a)
116 , polygonOffset :: Int
117 , polygonTriangulation :: Triangulation
118 , polygonSSSP :: Vector SSSP
119 }
120 type Polygon = APolygon Rational
121 type P = V2 Double
122
123 instance Show a => Show (APolygon a) where
124 show = show . V.toList . polygonPoints
125
126 instance Hashable a => Hashable (APolygon a) where
127 hashWithSalt s p = V.foldl' hashWithSalt s (polygonPoints p)
128
129 instance (PolyCtx a, Serialize a) => Serialize (APolygon a) where
130 put = put . V.toList . polygonPoints
131 get = mkPolygon . V.fromList <$> get
132
133 pRing :: APolygon a -> Ring a
134 pRing = ringPack . polygonPoints
135
136 type PolyCtx a = (Real a, Fractional a, Epsilon a)
137
138 mkPolygon :: PolyCtx a => V.Vector (V2 a) -> APolygon a
139 mkPolygon points = Polygon
140 { polygonPoints = points
141 , polygonOffset = 0
142 , polygonTriangulation = trig
143 , polygonSSSP = V.generate n $ \i -> sssp ring (dual i trig)
144 }
145 where
146 n = length points
147 ring = ringPack points
148 trig = earCut ring
149 -- earClip ring
150
151 castPolygon :: (PolyCtx a, PolyCtx b) => APolygon a -> APolygon b
152 castPolygon = mkPolygon . V.map (fmap realToFrac) . polygonPoints
153
154 mkPolygonFromRing :: PolyCtx a => Ring a -> APolygon a
155 mkPolygonFromRing = mkPolygon . ringUnpack
156
157 pUnsafeMap :: (Ring a -> Ring a) -> APolygon a -> APolygon a
158 pUnsafeMap fn p = p{ polygonPoints = ringUnpack (fn (pRing p)) }
159
160 -- pParent p i j = shortest-path parent from j to i
161 pParent :: APolygon a -> Int -> Int -> Int
162 pParent p i j =
163 (sTree V.! mod (j + polygonOffset p) n - polygonOffset p) `mod` n
164 where
165 sTree = polygonSSSP p V.! mod (i + polygonOffset p) n
166 n = pSize p
167
168 pCopy :: Polygon -> Polygon
169 pCopy p = mkPolygon $ V.generate (pSize p) $ pAccess p
170
171 pSetOffset :: APolygon a -> Int -> APolygon a
172 pSetOffset p offset =
173 p { polygonOffset = offset `mod` pSize p }
174
175 pAdjustOffset :: APolygon a -> Int -> APolygon a
176 pAdjustOffset p offset =
177 p { polygonOffset = (polygonOffset p + offset) `mod` pSize p }
178
179 {-# INLINE pSize #-}
180 pSize :: APolygon a -> Int
181 pSize = length . polygonPoints
182
183 pNull :: APolygon a -> Bool
184 pNull = V.null . polygonPoints
185
186 pNext :: APolygon a -> Int -> Int
187 pNext p i = (i+1) `mod` pSize p
188
189 pPrev :: APolygon a -> Int -> Int
190 pPrev p i = (i-1) `mod` pSize p
191
192 -- When is a polygon valid/simple?
193 -- It is counter-clockwise.
194 -- No edges intersect.
195 -- O(n^2)
196 -- 'checkEdge' takes 90% of the time.
197 pIsSimple :: Polygon -> Bool
198 pIsSimple p | pSize p < 3 = False
199 pIsSimple p = pIsCCW p && noDups && checkEdge 0 2
200 where
201 noDups = checkForDups (sort (V.toList (polygonPoints p)))
202 checkForDups (x:y:xs)
203 = x /= y && checkForDups (y:xs)
204 checkForDups _ = True
205 len = pSize p
206 -- check i,i+1 against j,j+1
207 -- j > i+1
208 checkEdge i j
209 | j >= len = (i > len-3) || checkEdge (i+1) (i+3)
210 | otherwise =
211 case lineIntersect (pAccess p i, pAccess p $ i+1)
212 (pAccess p j, pAccess p $ j+1) of
213 Just u | u /= pAccess p i -> False
214 _nothing -> checkEdge i (j+1)
215
216 pScale :: Rational -> Polygon -> Polygon
217 pScale s = pUnsafeMap (ringMap (^* s))
218
219 pAtCentroid :: Polygon -> Polygon
220 pAtCentroid p = pTranslate (negate c) p
221 where c = pCentroid p ^/ 2
222
223 pAtCenter :: Polygon -> Polygon
224 pAtCenter p = pTranslate (negate $ pCenter p) p
225
226 pTranslate :: V2 Rational -> Polygon -> Polygon
227 pTranslate v = pUnsafeMap (ringMap (+v))
228
229 pCenter :: Polygon -> V2 Rational
230 pCenter p = V2 (x+w/2) (y+h/2)
231 where
232 (x,y,w,h) = pBoundingBox p
233
234 -- Returns (min-x, min-y, width, height)
235 pBoundingBox :: Polygon -> (Rational, Rational, Rational, Rational)
236 pBoundingBox = \p ->
237 let V2 x y = pAccess p 0 in
238 case V.foldl' worker (x, y, 0, 0) (polygonPoints p) of
239 (xMin, yMin, xMax, yMax) ->
240 (xMin, yMin, xMax-xMin, yMax-yMin)
241 where
242 worker (xMin,yMin,xMax,yMax) (V2 thisX thisY) =
243 (min xMin thisX, min yMin thisY
244 ,max xMax thisX, max yMax thisY)
245
246 -- Place n points on a circle, use one parameter to slide the points back and forth.
247 -- Use second parameter to move points closer to center circle.
248 pGenerate :: [(Double, Double)] -> Polygon
249 pGenerate points
250 | len < 4 = error "pGenerate: require at least four points"
251 | otherwise = mkPolygon $ V.fromList
252 [ V2 (realToFrac $ cos ang * rMod)
253 (realToFrac $ sin ang * rMod)
254 | (i,(angMod,rMod)) <- zip [0..] points
255 , let minAngle = tau / len * i - pi
256 maxAngle = tau / len * (i+1) - pi
257 ang = minAngle + (maxAngle-minAngle)*angMod
258 ]
259 where
260 tau = 2*pi
261 len = fromIntegral (length points)
262
263 pUnGenerate :: Polygon -> [(Double, Double)]
264 pUnGenerate p =
265 [ worker i (fmap realToFrac e)
266 | (i,e) <- zip [0..] (V.toList $ polygonPoints p) ]
267 where
268 len = fromIntegral (pSize p)
269 worker i (V2 x y) =
270 let ang = atan2 y x
271 minAngle = tau / len * i - pi
272 maxAngle = tau / len * (i+1) - pi
273 in ((ang-minAngle)/(maxAngle-minAngle), sqrt (x*x+y*y))
274 tau = 2*pi
275
276 -- When is a triangulation valid?
277 -- Intersection: No internal edges intersect.
278 -- Completeness: All edge neighbours share a single internal edge.
279 isValidTriangulation :: Polygon -> Triangulation -> Bool
280 isValidTriangulation p t = isComplete && intersectionFree
281 where
282 o = polygonOffset p
283 isComplete = all isProper [0 .. pSize p-1]
284 isProper i =
285 let j = pNext p i in
286 length ((pPrev p i : (t V.! i)) `intersect` (pNext p j : t V.! j)) == 1
287 intersectionFree = and
288 [ case lineIntersect (pAccess p (a-o), pAccess p (b-o)) (pAccess p (c-o), pAccess p (d-o)) of
289 Nothing -> True
290 Just u -> u == pAccess p (a-o) || u == pAccess p (b-o) ||
291 u == pAccess p (c-o) || u == pAccess p (d-o)
292 | ((a,b),(c,d)) <- edgePairs ]
293 edgePairs = [ (e1, e2) | (e1, rest) <- zip edges (drop 1 $ tails edges), e2 <- rest]
294 edges =
295 [ (n, i)
296 | (n, lst) <- zip [0..] (V.toList t)
297 , i <- lst
298 , n < i
299 ]
300
301 triangulationsToPolygons :: Polygon -> Triangulation -> [Polygon]
302 triangulationsToPolygons p t =
303 [ mkPolygon $ V.fromList
304 [ pAccess p g, pAccess p i, pAccess p j ]
305 | i <- [0 .. pSize p-1]
306 , let js = filter (i<) $ t V.! i
307 , (g, j) <- zip (i-1:js) js
308 ]
309
310 pIsInside :: Polygon -> V2 Rational -> Bool
311 pIsInside p point = or
312 [ isInside (rawAccess g) (rawAccess i) (rawAccess j) point
313 | i <- [0 .. pSize p-1]
314 , let js = filter (i<) $ polygonTriangulation p V.! i
315 , (g, j) <- zip (i-1:js) js
316 ]
317 where
318 rawAccess x = polygonPoints p V.! x
319
320 -- reducePolygons :: Int -> [Polygon] -> [Polygon]
321 -- reducePolygons n ps
322 -- | length ps <= n = ps
323 -- | otherwise =
324 -- let p = findSmallest ps
325 -- es = edges p
326 -- e = findSmallest es
327 -- in reducePolygons n (merge p e : delete p (delete e ps))
328 -- where
329 -- findSmallest = minimumBy (comparing area2X)
330 -- shareEdge p1 p2 =
331
332 {-# INLINE pAccess #-}
333 pAccess :: APolygon a -> Int -> V2 a
334 pAccess p i = -- polygonPoints p V.! ((polygonOffset p + i) `mod` pSize p)
335 polygonPoints p `V.unsafeIndex` ((polygonOffset p + i) `mod` pSize p)
336
337 triangle :: Polygon
338 triangle = mkPolygon $ V.fromList [V2 1 1, V2 0 0, V2 2 0]
339
340 triangle' :: [P]
341 triangle' = reverse [V2 1 1, V2 0 0, V2 2 0]
342
343 shape1 :: Polygon
344 shape1 = mkPolygon $ V.fromList
345 [ V2 0 0, V2 2 0
346 , V2 2 1, V2 2 2, V2 2 3, V2 2 4, V2 2 5, V2 2 6
347 , V2 1 1, V2 0 1 ]
348
349 shape2 :: Polygon
350 shape2 = mkPolygon $ V.fromList
351 [ V2 0 0, V2 1 0, V2 1 1, V2 2 1, V2 2 (-1), V2 0 (-1), V2 0 (-2)
352 , V2 3 (-2), V2 3 2, V2 0 2]
353
354 shape3 :: Polygon
355 shape3 = mkPolygon $ V.fromList
356 [ V2 0 0, V2 1 0, V2 1 1, V2 2 1, V2 2 2, V2 0 2]
357
358 shape4 :: Polygon
359 shape4 = mkPolygon $ V.fromList
360 [ V2 0 0, V2 1 0, V2 1 1, V2 2 1, V2 2 (-1), V2 3 (-1),V2 3 2, V2 0 2]
361
362 shape5 :: Polygon
363 shape5 = pCycles shape4 !! 2
364
365 -- square
366 shape6 :: Polygon
367 shape6 = mkPolygon $ V.fromList [ V2 0 0, V2 1 0, V2 1 1, V2 0 1 ]
368
369 shape7 :: Polygon
370 shape7 = pScale 6 $ mkPolygon $ V.fromList
371 [V2 ((-1567171105775771) % 144115188075855872) ((-7758063241391039) % 1152921504606846976)
372 ,V2 ((-2711114907999263) % 18014398509481984) ((-3561889280168807) % 18014398509481984)
373 ,V2 ((-6897139157863177) % 72057594037927936) ((-1632144794297397) % 4503599627370496)
374 ,V2 (5592137945106423 % 36028797018963968) ((-71351641856107) % 281474976710656)
375 ,V2 (2568147525079071 % 4503599627370496) ((-4312925637247687) % 18014398509481984)
376 ,V2 (1291079014395023 % 2251799813685248) (321513444515769 % 2251799813685248)
377 ,V2 (2071709221627247 % 4503599627370496) (4019115966736491 % 9007199254740992)
378 ,V2 ((-1589087869859839) % 144115188075855872) (4904023654354179 % 9007199254740992)
379 ,V2 ((-2328090886101149) % 36028797018963968) (2587887893460759 % 36028797018963968)
380 ,V2 ((-7990199074159871) % 18014398509481984) (1301850651537745 % 4503599627370496)]
381
382 shape8 :: Polygon
383 shape8 = pScale 10 $ pGenerate
384 [(0.36,0.4),(0.7,1.8e-2),(0.7,0.2),(0.1,0.4),(0.2,0.2),(0.7,0.1),(0.4,8.0e-2)]
385
386 shape9 :: Polygon
387 shape9 = pScale 5 $ pGenerate
388 [(0.5,0.2),(0.7,0.6),(0.4,0.3),(0.1,0.7),(0.3,1.0e-2),(0.5,0.3),(0.2,0.8),(0.1,0.8),(0.7,6.0e-2),(0.1,0.6)]
389
390 shape10 :: Polygon
391 shape10 = pGenerate
392 [(0.4,0.7),(0.2,0.2),(0.3,0.9),(5.0e-2,0.1),(0.7,1.0e-2),(0.7,0.9),(0.2,0.1),(0.5,6.0e-2),(0.6,9.0e-2)]
393
394 shape11 :: Polygon
395 shape11 = pGenerate
396 [(0.1,0.8),(0.7,0.6),(0.7,0.4),(0.3,0.5),(0.8,0.9),(0.8,6.0e-2),(1.0e-2,4.0e-2),(0.8,0.1)]
397
398 shape12 :: Polygon
399 shape12 = mkPolygon $ V.fromList
400 [ V2 0 0, V2 0.5 1.5, V2 2 2, V2 (-2) 2, V2 (-0.5) 1.5 ]
401
402 -- F shape
403 shape13 :: Polygon
404 shape13 = pCycles (mkPolygon $ V.reverse (V.fromList
405 [ V2 0 0, V2 0 2
406 , V2 1 2, V2 1 1.7, V2 0.3 1.7, V2 0.3 1
407 , V2 1 1, V2 1 0.7
408 , V2 0.3 0.7, V2 0.3 0 ])) !! 7
409
410 -- E shape
411 shape14 :: Polygon
412 shape14 = pCycles (mkPolygon $ V.reverse $ V.fromList
413 [ V2 0 0, V2 0 2 -- up
414 , V2 1 2, V2 1 1.7, V2 0.3 1.7, V2 0.3 1 -- first prong
415 , V2 1 1, V2 1 0.7, V2 0.3 0.7, V2 0.3 0.3 -- second prong
416 , V2 1 0.3, V2 1 0 -- last prong
417 ]) !! 9
418
419 --
420 shape15 :: Polygon
421 shape15 = mkPolygon $ V.fromList
422 [ V2 0 0, V2 2 0
423 , V2 2 2, V2 1 2
424 , V2 1 1, V2 0 1]
425
426 shape16 :: Polygon
427 shape16 = mkPolygon $ V.fromList
428 [ V2 0 0, V2 2 0
429 , V2 2 1, V2 1 1
430 , V2 1 2, V2 0 2]
431
432 shape17 :: Polygon
433 shape17 = mkPolygon $ V.fromList
434 [ V2 2 0, V2 2 1
435 , V2 1 1, V2 1 2
436 , V2 0 2, V2 0 1, V2 0 0 ]
437
438 shape18 :: Polygon
439 shape18 = mkPolygon $ V.fromList
440 [ V2 2 0, V2 2 1, V2 2 2
441 , V2 1 2, V2 1 1
442 , V2 0 1, V2 0 0 ]
443
444 shape19 :: Polygon
445 shape19 = mkPolygon $ V.fromList
446 [ V2 (-3) (-3), V2 0 (-1)
447 , V2 3 (-3), V2 1 0
448 , V2 3 3, V2 0 1
449 , V2 (-3) 3, V2 (-1) 0 ]
450
451 shape20 :: Polygon
452 shape20 = mkPolygon $ V.fromList
453 [ V2 (-3) (-3)
454 , V2 0 (-1)
455 , V2 3 (-3)
456 , V2 5 0
457 , V2 2.5 (-2)
458 , V2 1 0
459 , V2 3 3
460 , V2 0 1
461 , V2 (-3) 3
462 , V2 (-1) 0 ]
463
464 shape21 :: Polygon
465 shape21 = mkPolygon $ V.fromList
466 [V2 0.0 0.0,V2 1.0 0.0,V2 1.0 1.0,V2 2.0 1.0,V2 2.0 (-1.0),V2 3.0 (-1.0)
467 ,V2 3.0 2.0,V2 0.0 2.0]
468
469 shape22 :: Polygon
470 shape22 = pScale 2 $ mkPolygon $ V.fromList
471 [V2 (-0.17) (-0.08)
472 ,V2 (-0.34) (-0.21)
473 ,V2 0.0 0.0
474 ,V2 (-0.10) 0.60
475 ,V2 (-0.14) 0.19
476 ,V2 (-0.05) 0.03
477 ]
478
479 shape23 :: Polygon
480 shape23 = mkPolygon $ V.fromList
481 [ V2 0 0, V2 4 0
482 , V2 4 3, V2 2 3
483 , V2 2 2, V2 3 2
484 , V2 3 1, V2 1 1
485 , V2 1 2, V2 2 2
486 , V2 2 3, V2 0 3 ]
487
488 concave :: Polygon
489 concave = mkPolygon $
490 V.fromList [V2 0 0, V2 2 0, V2 2 2, V2 1 1, V2 0 2]
491
492 pMkWinding :: Int -> Polygon
493 pMkWinding n | n < 1 = error "Polygon must have at least one winding."
494 pMkWinding n = mkPolygon $
495 V.fromList $ p0 : p1 : walkTo p1 1 n (V2 1 0) ++ reverse (walkTo p0 1 (n+2) (V2 (-1) 0))
496 where
497 p0 = V2 0 0
498 p1 = V2 0 1
499 walkTo at a b dir
500 | a == b = []
501 | otherwise =
502 let newAt = at + (dir ^* toRational a)
503 in newAt : walkTo newAt (a+1) b (rot dir)
504 rot (V2 x y) =
505 V2 y (-x)
506
507 pDeoverlap :: Polygon -> Polygon
508 pDeoverlap p = mkPolygon arr
509 where
510 arr = V.generate (pSize p) worker
511 worker 0 = pAccess p 0
512 worker n =
513 if length (V.elemIndices (pAccess p n) (polygonPoints p)) /= 1
514 then
515 let prev = arr V.! (n-1)
516 this = pAccess p n
517 in lerp 0.99999 this prev
518 else pAccess p n
519
520 pCycles :: APolygon a -> [APolygon a]
521 pCycles p = map (pAdjustOffset p) [0 .. pSize p-1]
522
523 pCycle :: PolyCtx a => APolygon a -> Double -> APolygon a
524 pCycle p 0 = p
525 pCycle p t = mkPolygon $ worker 0 0
526 where
527 worker acc i
528 | segment + acc > limit =
529 V.singleton (lerp (realToFrac $ (segment + acc - limit)/segment) x y) <>
530 -- V.drop (i+1) (polygonPoints p) <>
531 V.fromList (map (pAccess p) [i+1..pSize p-1]) <>
532 V.fromList (map (pAccess p) [0 .. i])
533 -- V.take (i+1) (polygonPoints p)
534 | i == pSize p-1 = V.fromList (map (pAccess p) [0 .. pSize p-1])
535 | otherwise = worker (acc+segment) (i+1)
536 where
537 x = pAccess p i
538 y = pAccess p $ i+1
539 segment = distance' x y
540 len = pCircumference' p
541 limit = t * len
542
543 pCentroid :: Fractional a => APolygon a -> V2 a
544 pCentroid p = V2 cx cy
545 where
546 a = pArea p
547 cx = recip (6*a) * V.sum (pMapEdges fnX p)
548 cy = recip (6*a) * V.sum (pMapEdges fnY p)
549 fnX (V2 x y) (V2 x' y') = (x+x')*(x*y' - x'*y)
550 fnY (V2 x y) (V2 x' y') = (y+y')*(x*y' - x'*y)
551
552 {-# INLINE pMapEdges #-}
553 pMapEdges :: (V2 a -> V2 a -> b) -> APolygon a -> V.Vector b
554 pMapEdges fn p = V.generate n $ \i ->
555 if i == n-1
556 then fn (arr `V.unsafeIndex` i) (arr `V.unsafeIndex` 0)
557 else fn (arr `V.unsafeIndex` i) (arr `V.unsafeIndex` (i+1))
558 where
559 n = pSize p
560 arr = polygonPoints p
561
562 {-# SPECIALIZE pArea :: APolygon Double -> Double #-}
563 {-# SPECIALIZE pArea :: APolygon Rational -> Rational #-}
564 pArea :: (Fractional a) => APolygon a -> a
565 pArea p =
566 -- 0.5 * V.sum (pMapEdges (\(V2 x y) (V2 x' y') -> x*y' - x'*y) p)
567 0.5 * worker 0 0
568 where
569 fn (V2 x y) (V2 x' y') = x*y' - x'*y
570 arr = polygonPoints p
571 worker !acc i
572 | i == pSize p - 1 = acc + fn (arr `V.unsafeIndex` i) (arr `V.unsafeIndex` 0)
573 | otherwise =
574 worker (acc + fn (arr `V.unsafeIndex` i) (arr `V.unsafeIndex` (i+1))) (i+1)
575
576 pCircumference :: (Real a, Fractional a) => APolygon a -> a
577 pCircumference p = sum
578 [ approxDist (pAccess p i) (pAccess p $ i+1)
579 | i <- [0 .. pSize p-1]]
580
581 pCircumference' :: (Real a, Fractional a) => APolygon a -> Double
582 pCircumference' p = sum
583 [ distance' (pAccess p i) (pAccess p $ i+1)
584 | i <- [0 .. pSize p-1]]
585
586
587 -- Add points by splitting the longest lines in half repeatedly.
588 pAddPoints :: PolyCtx a => Int -> APolygon a -> APolygon a
589 pAddPoints n p | n <= 0 = p
590 pAddPoints n p = pAddPoints (n-1) $
591 mkPolygon $ V.fromList $ concatMap worker [0 .. pSize p-1]
592 where
593 worker idx
594 | idx == longestEdge =
595 let start = pAccess p idx
596 end = pAccess p $ idx+1
597 middle = lerp 0.5 end start
598 in [start, middle]
599 | otherwise = [pAccess p idx]
600 longestEdge = maximumBy cmpLength [0 .. pSize p-1]
601 cmpLength a b =
602 distSquared (pAccess p a) (pAccess p $ a+1) `compare`
603 distSquared (pAccess p b) (pAccess p $ b+1)
604
605 pAddPointsRestricted :: PolyCtx a => [(V2 a, V2 a)] -> Int -> APolygon a -> APolygon a
606 pAddPointsRestricted _immutableEdges n p | n <= 0 = p
607 pAddPointsRestricted immutableEdges n p = pAddPointsRestricted immutableEdges (n-1) $
608 mkPolygon $ V.fromList $ concatMap worker [0 .. pSize p-1]
609 where
610 isImmutable idx =
611 (pAccess p idx, pAccess p $ idx+1) `elem` immutableEdges ||
612 (pAccess p $ idx+1, pAccess p idx) `elem` immutableEdges
613 worker idx
614 | idx == longestEdge && not (isImmutable idx) =
615 let start = pAccess p idx
616 end = pAccess p $ idx+1
617 middle = lerp 0.5 end start
618 in [start, middle]
619 | otherwise = [pAccess p idx]
620 longestEdge = maximumBy cmpLength [0 .. pSize p-1]
621 cmpLength a _ | isImmutable a = LT
622 cmpLength _ b | isImmutable b = GT
623 cmpLength a b =
624 distSquared (pAccess p a) (pAccess p $ a+1) `compare`
625 distSquared (pAccess p b) (pAccess p $ b+1)
626
627 pAddPointsBetween :: PolyCtx a => (Int, Int) -> Int -> APolygon a -> APolygon a
628 pAddPointsBetween _ n p | n <= 0 = p
629 pAddPointsBetween (i,l) n p = pAddPointsBetween (i,l+1) (n-1) $
630 mkPolygon $ V.fromList $ concatMap worker [0 .. pSize p-1]
631 where
632 worker idx
633 | idx == longestEdge =
634 let start = pAccess p idx
635 end = pAccess p $ idx+1
636 middle = lerp 0.5 end start
637 in [start, middle]
638 | otherwise = [pAccess p idx]
639 longestEdge = maximumBy cmpLength [i .. i+l-1]
640 cmpLength a b =
641 distSquared (pAccess p a) (pAccess p $ a+1) `compare`
642 distSquared (pAccess p b) (pAccess p $ b+1)
643
644 -- addPoints :: Int -> Polygon -> Polygon
645 -- addPoints n p = mkPolygon $ V.fromList $ worker n 0 (map (pAccess p) [0..s])
646 -- where
647 -- worker 0 _ rest = init rest
648 -- worker i acc (x:y:xs) =
649 -- let xy = approxDist x y in
650 -- if acc + xy > limit
651 -- then x : worker (i-1) 0 (lerp ((limit-acc)/xy) y x : y:xs)
652 -- else x : worker i (acc+xy) (y:xs)
653 -- worker _ _ [_] = []
654 -- worker _ _ _ = error "addPoints: invalid polygon"
655 -- s = pSize p
656 -- len = polygonLength p
657 -- limit = len / fromIntegral (n+1)
658
659 pIsConvex :: Polygon -> Bool
660 pIsConvex p = and
661 [ area2X (pAccess p i) (pAccess p j) (pAccess p k) > 0
662 | i <- [0..n-1]
663 , j <- [i+1..n-1]
664 , k <- [j+1..n-1]
665 ]
666 where n = pSize p
667
668 pIsCCW :: Polygon -> Bool
669 pIsCCW p | pNull p = False
670 pIsCCW p = V.sum (pMapEdges fn p) < 0
671 where
672 fn (V2 x1 y1) (V2 x2 y2) = (x2-x1)*(y2+y1)
673
674 {-# INLINE pRayIntersect #-}
675 pRayIntersect :: PolyCtx a => APolygon a -> (Int, Int) -> (Int,Int) -> Maybe (V2 a)
676 pRayIntersect p (a,b) (c,d) =
677 rayIntersect (pAccess p a, pAccess p b) (pAccess p c, pAccess p d)
678
679 pCuts :: (Real a, Fractional a, Epsilon a) => APolygon a -> [(APolygon a,APolygon a)]
680 pCuts p =
681 [ pCutAt (pAdjustOffset p i) (j-i)
682 | i <- [0 .. pSize p-1 ]
683 , j <- [i+2 .. pSize p-1 ]
684 , (j+1) `mod` pSize p /= i
685 , pParent p i j == i ]
686
687 pCutEqual :: PolyCtx a => APolygon a -> (APolygon a, APolygon a)
688 pCutEqual p =
689 fromMaybe (p,p) $ listToMaybe $ sortOn f $ pCuts p
690 where
691 f (a,b) = abs (pArea a - pArea b)
692
693 -- FIXME: This should be more efficient
694 pCutAt :: PolyCtx a => APolygon a -> Int -> (APolygon a, APolygon a)
695 pCutAt p i = (mkPolygon $ V.fromList left, mkPolygon $ V.fromList right)
696 where
697 n = pSize p
698 left = map (pAccess p) [0 .. i]
699 right = map (pAccess p) (0:[i..n-1])
700
701 pOverlap :: PolyCtx a => APolygon a -> APolygon a -> APolygon a
702 pOverlap a b = mkPolygon $ V.fromList $ clearDups $ concatMap edgeIntersect [0 .. pSize a-1]
703 where
704 clearDups (x:y:xs)
705 | x == y = clearDups (y:xs)
706 | otherwise = x : clearDups (y:xs)
707 clearDups xs = xs
708 edgeIntersect edge =
709 sortOn (distSquared (pAccess a edge)) $ catMaybes
710 [ lineIntersect (aP, aP') (bP, bP')
711 | i <- [0 .. pSize b-1]
712 , let aP = pAccess a edge
713 aP' = pAccess a (edge+1)
714 bP = pAccess b i
715 bP' = pAccess b (i+1)
716 ]
717
718 ---------------------------------------------------------
719 -- SSSP visibility and SSSP windows
720
721 ssspVisibility :: PolyCtx a => APolygon a -> APolygon a
722 ssspVisibility p = mkPolygon $
723 V.fromList $ clearDups $ go [0 .. pSize p-1] -- ([root..pSize p-1] ++ [0 .. root-1])
724 where
725 clearDups (x:y:xs)
726 | x == y = clearDups (y:xs)
727 | otherwise = x : clearDups (y:xs)
728 clearDups xs = xs
729 obstructedBy n =
730 case pParent p 0 n of
731 0 -> n
732 i -> obstructedBy i
733 go [] = []
734 go [x] = [pAccess p x]
735 go (x:y:xs) =
736 let xO = obstructedBy x
737 yO = obstructedBy y
738 in case () of
739 ()
740 -- Both ends are visible.
741 | xO == x && yO == y -> pAccess p x : go (y:xs)
742 -- X is visible, x to intersect (0,yO) (x,y)
743 | xO == x ->
744 pAccess p x : fromMaybe (pAccess p y) (pRayIntersect p (0,yO) (x,y)) : go (y:xs)
745 -- Y is visible
746 | yO == y -> fromMaybe (pAccess p x) (pRayIntersect p (0,xO) (x,y)) : pAccess p y : go (y:xs)
747 -- Neither is visible and they've obstructed by the same point
748 -- so the entire edge is hidden.
749 | xO == yO -> go (y:xs)
750 -- Neither is visible. Cast shadow from obstruction points to
751 -- find if a subsection of the edge is visible.
752 | otherwise ->
753 let a = fromMaybe (error "a") (pRayIntersect p (0,xO) (x,y))
754 b = fromMaybe (error "b") (pRayIntersect p (0,yO) (x,y))
755 in if a /= b
756 then a : b : go (y:xs)
757 else go (y:xs)
758
759 ssspWindows :: Polygon -> [(V2 Rational, V2 Rational)]
760 ssspWindows p = clearDups $ go (pAccess p 0) [0..pSize p-1]
761 where
762 clearDups (x:y:xs)
763 | x == y = clearDups (y:xs)
764 | otherwise = x : clearDups (y:xs)
765 clearDups xs = xs
766 obstructedBy n =
767 case pParent p 0 n of
768 0 -> n
769 i -> obstructedBy i
770 go _ [] = []
771 go _ [_] = []
772 go l (x:y:xs) =
773 let xO = obstructedBy x
774 yO = obstructedBy y
775 in case () of
776 ()
777 -- Both ends are visible.
778 | xO == x && yO == y -> go (pAccess p x) (y:xs)
779 -- X is visible, x to intersect (0,yO) (x,y)
780 | xO == x ->
781 go (fromMaybe (pAccess p y) (pRayIntersect p (0,yO) (x,y))) (y:xs)
782 -- Y is visible
783 | yO == y ->
784 let newL = fromMaybe (pAccess p x) (pRayIntersect p (0,xO) (x,y)) in
785 (l, newL) :
786 go newL (y:xs)
787 -- Neither is visible and they've obstructed by the same point
788 -- so the entire edge is hidden.
789 | xO == yO -> go l (y:xs)
790 -- Neither is visible. Cast shadow from obstruction points to
791 -- find if a subsection of the edge is visible.
792 | otherwise ->
793 let a = fromMaybe (error "a") (pRayIntersect p (0,xO) (x,y))
794 b = fromMaybe (error "b") (pRayIntersect p (0,yO) (x,y))
795 in if a /= b
796 then (l, a) : (b, pAccess p yO) : go (pAccess p yO) (y:xs)
797 else go l (y:xs)
798
799 pdualPolygons :: Polygon -> PDual -> [Polygon]
800 pdualPolygons p pdual = map mkPolygonFromRing (pdualRings (pRing p) pdual)