From 6b873e9e5c29672b15e0978ca811f98ddbb921ba Mon Sep 17 00:00:00 2001
From: hasufell <hasufell@hasufell.de>
Date: Thu, 8 Jan 2015 01:44:47 +0100
Subject: [PATCH] ALGO: try to implement y-monotonization

---
 Algorithms/PolygonTriangulation.hs | 38 ++++++++++++++++++++++++++++++
 Graphics/Diagram/AlgoDiags.hs      |  9 +++++++
 2 files changed, 47 insertions(+)

diff --git a/Algorithms/PolygonTriangulation.hs b/Algorithms/PolygonTriangulation.hs
index 58388c5..91e1e50 100644
--- a/Algorithms/PolygonTriangulation.hs
+++ b/Algorithms/PolygonTriangulation.hs
@@ -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'
+
diff --git a/Graphics/Diagram/AlgoDiags.hs b/Graphics/Diagram/AlgoDiags.hs
index d985722..cb52662 100644
--- a/Graphics/Diagram/AlgoDiags.hs
+++ b/Graphics/Diagram/AlgoDiags.hs
@@ -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')