Add function for cutting polygons

src/Dodge/LevelGen/StaticWalls.hs

@@ -6,7 +6,7 @@ module Dodge.LevelGen.StaticWalls
     ( cutWalls
     , removeInverseWalls
     , expandPolyByFixed
-    , cutPoly
+    , carvePoly
     , expandPolyCorners
     )
     where
@@ -35,13 +35,13 @@ cutWalls ps wls = case mapMaybe (`checkWallRight` newWalls) newWalls of
     [] -> newWalls
     _  -> cutWallsRetry 0 ps wls
   where
-    newWalls = cutPoly ps wls
+    newWalls = carvePoly ps wls
 cutWallsRetry :: Int -> [Point2] -> [WallP] -> [WallP]
 cutWallsRetry i ps wls = case mapMaybe (`checkWallRight` newWalls) newWalls of
     [] -> newWalls
     _  -> cutWallsRetry (i+1) ps wls
   where
-    newWalls = cutPoly ps' wls
+    newWalls = carvePoly ps' wls
     ps' = map (rotateV a) $ expandPolyBy x ps
     x = fromIntegral i / 100
     a | even i    = 0.001
@@ -74,8 +74,8 @@ checkWallRight (x,y) wls
 -- wall may be added where it shouldn't because the wrong facing wall is
 -- collided with
 -- Be aware that we do not remove all colinear walls; this may still cause bugs
-cutPoly :: [Point2] -> [WallP] -> [WallP]
-cutPoly qs wls = nubOrd
+carvePoly :: [Point2] -> [WallP] -> [WallP]
+carvePoly qs wls = nubOrd
     . removeInverseWalls
     . filter (not . wallIsZeroLength) 
     . fuseWallsWith zs

src/Dodge/LevelGen/StaticWalls/Deprecated.hs

@@ -49,7 +49,7 @@ cutWalls'' ps wls = case mapMaybe (`checkWallRight` newWalls) newWalls of
         ++ "\nWalls after cut:\n"
         ++ unlines (map show newWalls)
   where
-    newWalls = cutPoly ps wls
+    newWalls = carvePoly ps wls
     errsL = mapMaybe (`checkWallLeft` newWalls) newWalls
 -- | Given a specific wall and list of walls, checks that the number of walls leaving the
 -- second point is the same as the number of walls entering the second point of

src/Dodge/Room/Tutorial.hs

@@ -57,11 +57,12 @@ tutAnoTree = do
     foldMTRS
         [ tToBTree "TutStartRez" . return . cleatOnward <$> tutRezBox
         , corDoor
+        , tToBTree "" . return . cleatOnward <$> xChasm 200 200
 --        , tToBTree "" . return . cleatOnward <$> (cChasm
 --            <&> rmPmnts .:~ (sps0 (PutCrit slimeCrit) & plSpot . psPos .~ V2 100 20))
 --        , corDoor
 --        , loadAmmoTut
---        , corDoor
+        , corDoor
         , chasmSpitTerminal
         , corDoor
         , tutHub
@@ -141,6 +142,27 @@ tutDrop = do
                , makeTermLine "-------------------------------------------"
                ]
 
+xChasm :: Float -> Float -> State LayoutVars Room
+xChasm x y = shuffleLinks =<< putSingleLight (roomRect x y 2 2
+    & rmLinks %~ (setOutLinks f . setInLinks f)
+    & rmPmnts <>~ fmap g [id,vNormal,vNormal.vNormal,vNormal.vNormal.vNormal]
+    )
+  where
+    g g' = sps0 $ putConvexChasm (ps & each %~ g'
+        & each +~ V2 (x/2) (y/2))
+    ps = fst (cutPoly (V2 x' (y'-10)) (V2 (x'-10) y') $ rectWH x' y')
+        & each -~ V2 (x/4+10) (y/4+10)
+    x' = x/4 - 10
+    y' = y/4 - 10
+    f rl = FromEdge North 1 `S.member` xs || FromEdge East 1 `S.member` xs
+      where
+        xs = rl ^. rlType
+--        & rmLinks %~ setOutLinks (isCornerLink NorthWest)
+--        <&> rmLinks
+--        %~ setInLinks (isCornerLink SouthWest)
+--        <&> rmPmnts
+--        <>~ [sps0 $ putConvexChasm (rectNSWE (y - 50) 50 0 (x - 50))]
+
 cChasm :: State LayoutVars Room
 cChasm = do
     x <- state $ randomR (150, 300)