WIP: fix polygon splitting with own algorithm

To do: a point in a cut polygon can have two outgoing lines; the 
implementation currently assumes just one, hence aliasing kills a lot of 
connections.

generative-art.cabal

@@ -4,7 +4,7 @@ cabal-version: 1.12
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: 009cdd28b8d98ecefa029442527504ce13d53e648f7e8c3b9129db757db0417c
+-- hash: 40ea66694b74fbb9f13d5883ab453cc3bed5fec1ca5c865614ce4222dffd9e4e
 
 name:           generative-art
 version:        0.1.0.0
@@ -37,6 +37,7 @@ library
       base >=4.7 && <5
     , cairo
     , colour
+    , containers
   default-language: Haskell2010
 
 executable haskell-logo-billard
@@ -50,6 +51,7 @@ executable haskell-logo-billard
       base >=4.7 && <5
     , cairo
     , colour
+    , containers
     , generative-art
   default-language: Haskell2010
 
@@ -74,6 +76,7 @@ test-suite generative-art-test
     , base >=4.7 && <5
     , cairo
     , colour
+    , containers
     , generative-art
     , process
     , tasty

package.yaml

@@ -19,6 +19,7 @@ dependencies:
     - base >= 4.7 && < 5
     - cairo
     - colour
+    - containers
 
 ghc-options:
     - -Wall

src/Geometry.hs

@@ -62,10 +62,15 @@ module Geometry (
 
 
 
-import Control.Monad
-import Data.Fixed
-import Data.List
-import Text.Printf
+import           Control.Monad
+import           Data.Fixed
+import           Data.List
+import           Data.Map      (Map)
+import qualified Data.Map      as M
+import           Data.Set      (Set)
+import qualified Data.Set      as S
+import           Debug.Trace
+import           Text.Printf
 
 
 
@@ -357,8 +362,8 @@ isConvex (Polygon ps)
 -- | Cut a polygon in multiple pieces with a line.
 --
 -- Algorithm inspired by https://geidav.wordpress.com/2015/03/21/splitting-an-arbitrary-polygon-by-a-line/
-cutPolygon :: Line -> Polygon -> [Polygon]
-cutPolygon scissors polygon
+cutPolygon_old :: Line -> Polygon -> [Polygon]
+cutPolygon_old scissors polygon
   = let extendedPolygon :: [CutLine]
         extendedPolygon = map (cutLine scissors) (polygonEdges polygon)
 
@@ -383,6 +388,44 @@ cutPolygon scissors polygon
 
     in walk (Polygon []) (rotateToFirstSource extendedPolygon)
 
+cutPolygon :: Line -> Polygon -> [Polygon]
+cutPolygon scissors polygon
+  = let cutEdges = map (cutLine scissors) (polygonEdges polygon)
+    in reconstructPolygons (traceShowId $ gatherAllEdges Nothing cutEdges)
+  where
+    (-->) = M.insert
+
+    gatherAllEdges :: Maybe Vec2 -> [CutLine] -> Map Vec2 Vec2
+    gatherAllEdges Nothing (Cut p thisCut q : rest)
+      = ((p --> thisCut) . (thisCut --> q))
+        (gatherAllEdges (Just thisCut) rest)
+    gatherAllEdges (Just otherCut) (Cut p thisCut q : rest)
+      = ((p --> thisCut) . (thisCut --> q) . (otherCut --> thisCut) . (thisCut --> otherCut))
+        (gatherAllEdges Nothing rest)
+
+    gatherAllEdges lastCut (NoCut p q : rest)
+      = (p --> q) (gatherAllEdges lastCut rest)
+
+    -- Out of potential cuts, terminate
+    gatherAllEdges Nothing [] = M.empty
+    gatherAllEdges (Just _) [] = error "woops, cutting polygon is buggy"
+
+    reconstructPolygons :: Map Vec2 Vec2 -> [Polygon]
+    reconstructPolygons = gatherCycles
+      where
+        gatherCycles edgeMap = case M.lookupMin edgeMap of
+            Nothing -> []
+            Just (start, _) ->
+                let (cy, edgeMap') = extractCycle start edgeMap
+                in Polygon cy : gatherCycles edgeMap'
+
+extractCycle :: Ord k => k -> Map k k -> ([k], Map k k)
+extractCycle = go []
+  where
+    go xs start db = case M.lookup start db of
+        Nothing -> (xs, db)
+        Just end -> go (start:xs) end (M.delete start db)
+
 data CutLine
     = NoCut Vec2 Vec2
         -- ^ (start, end). No cut has occurred, i.e. the cutting line did not

test/Test/Visual/Common.hs

@@ -65,4 +65,4 @@ renderSvg picWidth picHeight filename drawing
 renderAllFormats :: Int -> Int -> FilePath -> Render () -> IO ()
 renderAllFormats w h filename drawing = do
     renderPng w h (filename ++ ".png") drawing
-    renderSvg w h (filename ++ ".svg") drawing
+    -- renderSvg w h (filename ++ ".svg") drawing

test/Test/Visual/Cut.hs

@@ -112,3 +112,17 @@ cutComplicatedPolygon = do
     setFontSize 12
     moveTo (-10) 100
     showText (show (length cutResult) ++ " polygons")
+
+    let hakkk = [(Vec2 0.0 0.0,Vec2 60.0 0.0),(Vec2 0.0 65.17298893531841,Vec2 0.0 0.0),(Vec2 0.0 80.0,Vec2 0.0 65.17298893531841),(Vec2 20.0 20.0,Vec2 20.000000000000004 48.39099631177281),(Vec2 20.0 60.0,Vec2 60.0 60.0),(Vec2 20.000000000000004 48.39099631177281,Vec2 20.0 60.0),(Vec2 40.0 20.0,Vec2 20.0 20.0),(Vec2 40.0 40.0,Vec2 40.00000000000001 31.6090036882272),(Vec2 40.00000000000001 31.6090036882272,Vec2 40.0 20.0),(Vec2 60.0 0.0,Vec2 60.0 14.827011064681587),(Vec2 60.0 14.827011064681587,Vec2 60.0 40.0),(Vec2 60.0 40.0,Vec2 40.0 40.0),(Vec2 60.0 60.0,Vec2 60.0 80.0),(Vec2 60.0 80.0,Vec2 0.0 80.0)]
+    -- for_ hakkk (\(point, _) -> do
+    --     mmaColor 3 1
+    --     circleSketch point (Distance 4)
+    --     fill )
+    -- for_ hakkk (\(_, point) -> do
+    --     mmaColor 0 1
+    --     circleSketch point (Distance 2.5)
+    --     fill )
+    for_ hakkk (\(start,end) -> do
+        mmaColor 0 1
+        arrowSketch (Line start end)
+        stroke )