ALGO: try to implement y-monotonization

This commit is contained in:
hasufell 2015-01-08 01:44:47 +01:00
parent b6b9cead2a
commit 6b873e9e5c
No known key found for this signature in database
GPG Key ID: 220CD1C5BDEED020
2 changed files with 47 additions and 0 deletions

View File

@ -3,8 +3,12 @@
module Algorithms.PolygonTriangulation where module Algorithms.PolygonTriangulation where
import Algebra.Polygon
import Algebra.Vector import Algebra.Vector
import Data.List
import Data.Maybe
import Diagrams.Coordinates import Diagrams.Coordinates
import MyPrelude
data VCategory = VStart data VCategory = VStart
@ -102,3 +106,37 @@ isYmonotone poly =
. any (\x -> x == VSplit || x == VMerge) . any (\x -> x == VSplit || x == VMerge)
. fmap snd . fmap snd
$ classifyList poly $ classifyList poly
monotonize :: [PT] -> [[PT]]
monotonize pts
| isYmonotone pts = [pts]
| and . fmap isYmonotone $ maybeMonotone = maybeMonotone
| otherwise = (\(x, y) -> x ++ (concat . fmap monotonize $ y))
(partition isYmonotone maybeMonotone)
where
go (x:xs) = splitPoly pts x ++ go xs
go _ = []
maybeMonotone = go (monotoneDiagonals pts)
monotoneDiagonals :: [PT] -> [(PT, PT)]
monotoneDiagonals pts = catMaybes . go $ classifyList pts
where
go (x:xs) = case snd x of
VMerge -> getSeg (belowS (fst x) pts) (fst x) pts : go xs
VSplit -> getSeg (aboveS (fst x) pts) (fst x) pts : go xs
_ -> [] ++ go xs
go [] = []
getSeg [] _ _ = Nothing
getSeg (z:zs) pt pts'
| null
. catMaybes
. fmap (intersectSeg'' (z, pt))
$ polySegments pts
= Just (z, pt)
| otherwise = getSeg zs pt pts'
aboveS pt pts' = tail . dropWhile (/= pt) $ sortedYX pts'
belowS pt pts' = reverse . takeWhile (/= pt) $ sortedYX pts'

View File

@ -264,3 +264,12 @@ polyTriCategorizedPoints = Diag f
vcatToCol VMerge = pink vcatToCol VMerge = pink
vcatToCol VRegular = yellow vcatToCol VRegular = yellow
monotonePolys :: Diag
monotonePolys = Diag f
where
f _ vts = foldl (\x y -> x <> strokePoly y) mempty
$ monotonize (concat vts)
where
strokePoly x' = fromVertices $ x' ++ (maybeToList . headMay $ x')