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)

src/Geometry/Intersect.hs

@@ -4,6 +4,7 @@
 {- Testing for and finding intersection points.  -}
 module Geometry.Intersect where
 
+import Data.List (sortOn)
 import Control.Applicative
 import Control.Lens
 import Control.Monad
@@ -264,6 +265,14 @@ intersectSegPolyFirst a b xs = foldr (<|>) Nothing $ zipWith lineColl xs (tail x
   where
     lineColl = intersectSegSeg a b
 
+-- orders intersecting points according to the line
+intersectLinePoly :: Point2 -> Point2 -> [Point2] -> [Point2]
+intersectLinePoly a b (p:ps) = sortOn (dotV (b - a)) 
+    . catMaybes
+    $ zipWith (\x y -> intersectSegLine x y a b) (p:ps) (ps ++[p])
+intersectLinePoly _ _ [] = error "intersectLinePoly empty polygon"
+
+
 {- | Given a line and a point return the point on the line closest to the
  point.
 -}

src/Geometry/Polygon.hs

@@ -202,3 +202,41 @@ shrinkPolyOnEdges _ _ = error "too few vertices in polygon"
 shrinkVert :: Float -> [Point2] -> Point2
 shrinkVert d [x, y, z] = x +.+ (d *.* normalizeV (x -.- y)) +.+ (d *.* normalizeV (z -.- y))
 shrinkVert _ _ = error "wrong number of vertices"
+
+-- divide a polygon into two along a line
+-- assumes the line intersects the polygon exactly twice, nocolinearity
+-- this may duplicate points
+-- this should be tested: there are many possible points of failure...
+cutPoly :: Point2 -> Point2 -> [Point2] -> ([Point2],[Point2])
+cutPoly a b (p:ps)
+    | not (isLHS a b p) && not (isRHS a b p) = cutPolyL a b ps p p [p] [p]
+    | isLHS a b p = cutPolyL a b ps p p [p] []
+    | otherwise = cutPolyR a b ps p p [] [p]
+cutPoly _ _ [] = error "cutPoly empty poly"
+
+cutPolyL :: Point2 -> Point2 -> [Point2] -> Point2 -> Point2 -> [Point2] -> [Point2] -> ([Point2], [Point2])
+cutPolyL a b (p:ps) e x ls rs
+    | isLHS a b p = cutPolyL a b ps e p (p\:ls) rs
+    | otherwise = case intersectLineLine x p a b of
+        Nothing -> error "cutPolyL nonintersecting lines"
+        Just p' -> cutPolyR a b ps e p (p'\:ls) (p\:p'\:rs)
+cutPolyL a b [] e x ls rs = case intersectSegLine x e a b of
+    Nothing -> (reverse ls,reverse rs)
+    Just p -> (reverse (p\:ls), reverse (p\:rs))
+
+cutPolyR :: Point2 -> Point2 -> [Point2] -> Point2 -> Point2 -> [Point2] -> [Point2] -> ([Point2], [Point2])
+cutPolyR a b (p:ps) e x ls rs
+    | isRHS a b p = cutPolyR a b ps e p ls (p\:rs)
+    | otherwise = case intersectLineLine x p a b of
+        Nothing -> error "cutPolyR nonintersecting lines"
+        Just p' -> cutPolyL a b ps e p (p\:p'\:ls) (p'\:rs)
+cutPolyR a b [] e x ls rs = case intersectSegLine x e a b of
+    Nothing -> (reverse ls,reverse rs)
+    Just p -> (reverse (p\:ls), reverse (p\:rs))
+
+infixr 5 \:
+(\:) :: Eq a => a -> [a] -> [a]
+(\:) x (y:ys) 
+    | x /= y = x:y:ys
+    | otherwise = y:ys 
+(\:) x [] = [x]