diff --git a/generative-art.cabal b/generative-art.cabal
index 843f287e7..b1604f8ed 100644
--- a/generative-art.cabal
+++ b/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
diff --git a/package.yaml b/package.yaml
index 9616319d3..5b24bdae4 100644
--- a/package.yaml
+++ b/package.yaml
@@ -19,6 +19,7 @@ dependencies:
- base >= 4.7 && < 5
- cairo
- colour
+ - containers
ghc-options:
- -Wall
diff --git a/src/Geometry.hs b/src/Geometry.hs
index 4611cbfba..3b971d982 100644
--- a/src/Geometry.hs
+++ b/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
diff --git a/test/Test/Visual/Common.hs b/test/Test/Visual/Common.hs
index 8c734003a..736009cb2 100644
--- a/test/Test/Visual/Common.hs
+++ b/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
diff --git a/test/Test/Visual/Cut.hs b/test/Test/Visual/Cut.hs
index ee16bebda..9b53108f4 100644
--- a/test/Test/Visual/Cut.hs
+++ b/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 )
diff --git a/test/out/cut.svg b/test/out/cut.svg
index 5d989a8c9..b62d1d27d 100644
--- a/test/out/cut.svg
+++ b/test/out/cut.svg
@@ -51,14 +51,11 @@
-
+
-
-
-
@@ -98,18 +95,13 @@
+
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
@@ -134,32 +126,23 @@
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+