Work towards convex partition of polygons

This commit is contained in:
2026-03-22 13:41:45 +00:00
parent 1a3d54e3b5
commit 505ced95bb
2 changed files with 24 additions and 7 deletions
+16 -7
View File
@@ -238,10 +238,12 @@ sqPlatformChasm b a =
sqSpitChasm :: Float -> Float -> ([[Point2]], [[Point2]]) sqSpitChasm :: Float -> Float -> ([[Point2]], [[Point2]])
sqSpitChasm b a = sqSpitChasm b a =
( [[ibr, obr, otr, itr], [itr, otr, otl, itl], [itl, otl, obl, ibl]] ( --[[ibr, obr, otr, itr], [itr, otr, otl, itl], [itl, otl, obl, ibl]]
, [[ibr, obr, otr, otl, obl, ibl, itl, itr]] convexPartition clfs
, [clfs]
) )
where where
clfs = [ibr, obr, otr, otl, obl, ibl, itl, itr]
obr = V2 a (-a) obr = V2 a (-a)
obl = V2 (-a) (-a) obl = V2 (-a) (-a)
otl = V2 (-a) a otl = V2 (-a) a
@@ -250,6 +252,12 @@ sqSpitChasm b a =
ibl = V2 (-b) (-a) ibl = V2 (-b) (-a)
itl = V2 (-b) b itl = V2 (-b) b
itr = V2 b b itr = V2 b b
-- otl---------otr
-- | itl-itr |
-- obr-ibl ibr-obl
nonConvexChasm :: [Point2] -> PSType
nonConvexChasm ps = PutChasm [] [ps]
midChasmSpit :: State LayoutVars Room midChasmSpit :: State LayoutVars Room
midChasmSpit = do midChasmSpit = do
@@ -300,13 +308,14 @@ chasmSpitTerminal = do
, [spanLightI (V2 0 128) (V2 300 128)] , [spanLightI (V2 0 128) (V2 300 128)]
, [spanLightI (V2 300 0) (V2 0 300), sps0 $ putShape $ thinHighBar 95 0 300] , [spanLightI (V2 300 0) (V2 0 300), sps0 $ putShape $ thinHighBar 95 0 300]
] ]
gh <- takeOne [55,97] gh <- takeOne [55,75,97]
gird <- takeOne [girderZ gh 30 10,girder gh 30 10,girderV gh 30 10] gird <- takeOne [girderZ gh 30 10,girder gh 30 10,girderV gh 30 10]
dec <- takeOne $ -- replicate 3 [] <> dec <- takeOne $ -- replicate 3 [] <>
[ [--[]
[sps0 $ putShape $ gird (V2 30 0) (V2 30 300) -- ,[sps0 $ putShape $ gird (V2 30 0) (V2 30 300)
,sps0 $ putShape $ gird (V2 270 0) (V2 270 300)] -- ,sps0 $ putShape $ gird (V2 270 0) (V2 270 300)]
,[sps0 $ putShape $ gird (V2 0 20) (V2 300 20)] -- ,[sps0 $ putShape $ gird (V2 0 20) (V2 300 20)]
[sps0 $ putShape $ gird (V2 0 200) (V2 300 200)]
] ]
-- let y' = y & rmPmnts <>~ [l3, l4, l5] -- let y' = y & rmPmnts <>~ [l3, l4, l5]
let y' = y & rmPmnts <>~ ls <> dec let y' = y & rmPmnts <>~ ls <> dec
+8
View File
@@ -151,6 +151,14 @@ convexHull :: [Point2] -> [Point2]
convexHull (x : y : z : xs) = grahamScan $ orderAroundFirst $ sortOn (\(V2 a b) -> (b, a)) (x : y : z : xs) convexHull (x : y : z : xs) = grahamScan $ orderAroundFirst $ sortOn (\(V2 a b) -> (b, a)) (x : y : z : xs)
convexHull _ = error "Tried to create the convex hull of two or fewer points" convexHull _ = error "Tried to create the convex hull of two or fewer points"
-- assumes the points go "anticlockwise" around a non-self intersecting shape
convexPartition :: [Point2] -> [[Point2]]
convexPartition (x:y:z:[]) = [[x,y,z]]
convexPartition (x:y:z:xs)
| isLHS x y z = [x,y,z] : convexPartition (x:z:xs)
| otherwise = convexPartition (y:z:xs <> [x])
convexPartition _ = error "unexpected shape for convexPartition"
{- | Creates the convex hull of a set of points. {- | Creates the convex hull of a set of points.
assumes no repetition of points: try nubbing! assumes no repetition of points: try nubbing!
-} -}