ALGO: try to implement y-monotonization
This commit is contained in:
parent
b6b9cead2a
commit
6b873e9e5c
@ -3,8 +3,12 @@
|
||||
|
||||
module Algorithms.PolygonTriangulation where
|
||||
|
||||
import Algebra.Polygon
|
||||
import Algebra.Vector
|
||||
import Data.List
|
||||
import Data.Maybe
|
||||
import Diagrams.Coordinates
|
||||
import MyPrelude
|
||||
|
||||
|
||||
data VCategory = VStart
|
||||
@ -102,3 +106,37 @@ isYmonotone poly =
|
||||
. any (\x -> x == VSplit || x == VMerge)
|
||||
. fmap snd
|
||||
$ 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'
|
||||
|
||||
|
@ -264,3 +264,12 @@ polyTriCategorizedPoints = Diag f
|
||||
vcatToCol VMerge = pink
|
||||
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')
|
||||
|
Loading…
Reference in New Issue
Block a user