ALGO: add partitioning of polygons for triangulation

This commit is contained in:
hasufell 2015-01-09 03:24:09 +01:00
parent c96474e6fd
commit f53207b48c
No known key found for this signature in database
GPG Key ID: 220CD1C5BDEED020
2 changed files with 51 additions and 2 deletions

View File

@ -3,6 +3,7 @@
module Algebra.Polygon where module Algebra.Polygon where
import Algebra.Vector import Algebra.Vector
import Data.Maybe
import MyPrelude import MyPrelude
{- import Diagrams.Coordinates -} {- import Diagrams.Coordinates -}
@ -33,3 +34,19 @@ isInsidePoly pts seg =
. fmap (intersectSeg'' seg) . fmap (intersectSeg'' seg)
$ polySegments pts $ polySegments pts
adjacent :: PT -> PT -> [PT] -> Bool
adjacent u v = any (\x -> x == (u, v) || x == (v, u)) . polySegments
isTrianglePoly :: [PT] -> Bool
isTrianglePoly [_, _, _] = True
isTrianglePoly _ = False
triangleOnly :: [[PT]] -> [[PT]]
triangleOnly = filter isTrianglePoly
nonTriangleOnly :: [[PT]] -> [[PT]]
nonTriangleOnly = filter (not . isTrianglePoly)

View File

@ -5,8 +5,10 @@ module Algorithms.PolygonTriangulation where
import Algebra.Polygon import Algebra.Polygon
import Algebra.Vector import Algebra.Vector
import qualified Control.Arrow as A
import Data.List import Data.List
import Data.Maybe import Data.Maybe
import Safe
import Diagrams.Coordinates import Diagrams.Coordinates
import MyPrelude import MyPrelude
@ -110,8 +112,9 @@ isYmonotone poly =
monotonize :: [PT] -> [[PT]] monotonize :: [PT] -> [[PT]]
monotonize pts monotonize pts
| isYmonotone pts = [pts] | isYmonotone pts = partitionPoly pts
| and . fmap isYmonotone $ maybeMonotone = maybeMonotone | and . fmap isYmonotone $ maybeMonotone =
concat . fmap partitionPoly $ maybeMonotone
| otherwise = (\(x, y) -> x ++ (concat . fmap monotonize $ y)) | otherwise = (\(x, y) -> x ++ (concat . fmap monotonize $ y))
(partition isYmonotone maybeMonotone) (partition isYmonotone maybeMonotone)
where where
@ -136,3 +139,32 @@ monotoneDiagonals pts = catMaybes . go $ classifyList pts
aboveS pt pts' = tail . dropWhile (/= pt) $ sortedYX pts' aboveS pt pts' = tail . dropWhile (/= pt) $ sortedYX pts'
belowS pt pts' = reverse . takeWhile (/= pt) $ sortedYX pts' belowS pt pts' = reverse . takeWhile (/= pt) $ sortedYX pts'
partitionPoly :: [PT] -> [[PT]]
partitionPoly pts =
go pts . A.first reverse . splitAt 3 . reverse . sortedYX $ pts
where
go xs (p@[_, _], r:rs) = go xs (r:p, rs)
go xs (p@(u:vi:vi1:ys), rs)
-- case 1 and 3
| adjacent u (last p) xs =
splitPoly xs (u, (last . init) p)
++ go (fromMaybe []
. headMay
. nonTriangleOnly
. splitPoly xs
$ (u, (last . init) p))
(init p, rs)
-- case 2
| adjacent u vi xs && (not . null) rs =
if getAngle (vp2 vi u) (vp2 vi vi1) < pi / 2
then splitPoly xs (u, vi1)
++ go (fromMaybe []
. headMay
. nonTriangleOnly
. splitPoly xs
$ (u, vi1))
(u:vi1:ys, rs)
else go xs (head rs:p, tail rs)
| otherwise = [[]]
go _ _ = [[]]