Non-convex chasms

src/Dodge/Creature/Update.hs

@@ -124,7 +124,8 @@ chasmTest :: Creature -> World -> World
 chasmTest cr w
     | _crZVel cr < 0 = w & tocr . crZVel -~ 0.5
             & tocr . crPos . _z +~ _crZVel cr
-    | Just (x, y) <- List.find g (foldMap loopPairs $ w ^. cWorld . chasms) = w
+--    | Just (x, y) <- List.find g (foldMap loopPairs $ w ^. cWorld . chasms') = w
+    | Just (x, y) <- List.find g (w ^. cWorld . cliffs) = w
             & soundContinue (CrChasm (_crID cr)) (cr ^. crPos . _xy) debrisS (Just 100)
             & tocr . crPos . _xy -~ normalizeV (vNormal (x - y))
     | any f (w ^. cWorld . chasms) = w & tocr . crZVel -~ 0.5

src/Dodge/Data/CWorld.hs

@@ -31,6 +31,7 @@ data CWorld = CWorld
     , _incEdges :: [(Int,Int)]
     , _numberFloorVerxs :: Int
     , _chasms :: [[Point2]]
+    , _cliffs :: [(Point2,Point2)]
     , _numberChasmVerxs :: Int
     , _highlightItems :: IM.IntMap Int
     }

src/Dodge/Data/GenWorld.hs

@@ -58,11 +58,18 @@ data PSType
     | PutWorldUpdate (Int -> PlacementSpot -> GenWorld -> GenWorld) -- the Int is the roomid
     | PutNothing
     | PutID {_putID :: Int}
-    | PutChasm {_putChasmPoly :: [Point2]}
+    | PutChasm {_putChasmChasms :: [[Point2]], _putChasmCliffs :: [[Point2]]}
+        -- the chasms should be a convex partition of the cliffs.
+        -- Chasm and cliff polygons are orientated anticlockwise, so platforms 
+        -- within a chasm will appear as a clockwise oriented list of points
+        -- in _putChasmCliffs.
     | PutLabel {_putLabel :: String} -- currently not actually put anywhere
         -- just used for later inspection as top level 
         -- of a continuing placement in a room placement list
 
+putConvexChasm :: [Point2] -> PSType
+putConvexChasm ps = PutChasm [ps] [ps]
+
 instance ShortShow PSType where
     shortShow PutCrit {} = "PutCrit"
     shortShow PutMachine {} = "PutMachine"

src/Dodge/Default/World.hs

@@ -94,6 +94,7 @@ defaultCWorld =
         , _cwTiles = mempty
         , _numberFloorVerxs = 0
         , _chasms = mempty
+        , _cliffs = mempty
         , _numberChasmVerxs = 0
         , _incGraph = mempty
         , _incNode = mempty

src/Dodge/Placement/PlaceSpot.hs

@@ -142,7 +142,8 @@ placeSpotID rid ps pt w = case pt of
     PutNothing -> (0, w)
     PutID i -> (i, w)
     PutWorldUpdate f -> (0, w & f rid ps)
-    PutChasm ps' -> (0, placeChasm w rid ps' $ map doShift ps')
+    PutChasm ps' qs -> (0, placeChasm w rid ps' (map (map doShift) ps') 
+        (foldMap loopPairs (map (map doShift) qs)))
     PutLabel{} -> (0, w)
   where
     p@(V2 px py) = _psPos ps
@@ -151,13 +152,15 @@ placeSpotID rid ps pt w = case pt of
     doShift = shiftPointBy (p, rot)
     pashift = compP2A (p, rot)
 
-placeChasm :: GenWorld -> Int -> [Point2] -> [Point2] -> GenWorld
+placeChasm :: GenWorld -> Int -> [[Point2]] -> [[Point2]] -> [(Point2,Point2)] -> GenWorld
-placeChasm gw rid ps shiftps =
+placeChasm gw rid ps shiftps cfs =
-    gw & gwWorld . cWorld . chasms .:~ shiftps
+    gw & gwWorld . cWorld . chasms <>~ shiftps
-        & genRooms . ix rid . rmPos %~ filter (\rp -> not $ pointInPoly (_rpPos rp) ps)
+        & gwWorld . cWorld . cliffs <>~ cfs
+        & genRooms . ix rid . rmPos %~ filter (\rp -> not $ any (pointInPoly (_rpPos rp)) ps)
         & gwWorld %~ f
   where
-    f w = foldl' g w (loopPairs shiftps)
+    --f w = foldl' g w (loopPairs shiftps)
+    f w = foldl' g w cfs
     g w (x, y) = obstructPathsCrossing (S.singleton ChasmObstacle) x y w
 
 placeWallPoly :: [Point2] -> Wall -> World -> World

src/Dodge/Render/ShapePicture.hs

@@ -38,7 +38,8 @@ worldSPic cfig u =
             )
         <> foldup btSPic (filtOn _btPos _buttons)
         <> foldup (mcSPic (w ^. cWorld)) (filtOn _mcPos _machines)
-        <> foldMap' drawChasm (w ^. cWorld . chasms)
+--        <> foldMap' drawChasm (w ^. cWorld . chasms)
+        <> foldMap' (Prelude.uncurry drawCliff) (w ^. cWorld . cliffs)
         <> w ^. cWorld . lWorld . tempSPic
         <> testSPic cfig u
   where
@@ -79,8 +80,8 @@ testPic _ _ = mempty
 drawBlock :: Block -> SPic
 drawBlock = noPic . _blDraw
 
-drawChasm :: [Point2] -> SPic
+--drawChasm :: [Point2] -> SPic
-drawChasm = foldMap (Prelude.uncurry drawCliff) . loopPairs
+--drawChasm = foldMap (Prelude.uncurry drawCliff) . loopPairs
 
 drawCliff :: Point2 -> Point2 -> SPic
 drawCliff x y =

src/Dodge/Room/Pillar.hs

@@ -126,5 +126,5 @@ roomPillars pillarsize w h wn hn = do
   where
     pilw = ((w - 40 * (fromIntegral wn + 1)) / fromIntegral wn) - pillarsize
     pilh = ((h - 40 * (fromIntegral hn + 1)) / fromIntegral hn) - pillarsize
-    testchasm = Placement (PS 0 0) (PutChasm (map (+V2 50 120) (rectWH 50 25))) Nothing Nothing
+    testchasm = Placement (PS 0 0) (putConvexChasm (map (+V2 50 120) (rectWH 50 25))) Nothing Nothing
         (\_ _ -> Nothing)

src/Dodge/Room/Tutorial.hs

@@ -135,7 +135,7 @@ cChasm = do
     roomRectAutoLinks x y
         <&> rmLinks %~ setOutLinks (isCornerLink NorthWest)
         <&> rmLinks %~ setInLinks (isCornerLink SouthWest)
-        <&> rmPmnts <>~ [sps0 $ PutChasm (rectNSWE (y -50) 50 0 (x -50))]
+        <&> rmPmnts <>~ [sps0 $ putConvexChasm (rectNSWE (y -50) 50 0 (x -50))]
 
 lChasm :: State LayoutVars Room
 lChasm = do
@@ -144,7 +144,7 @@ lChasm = do
     roomRectAutoLinks x y
         <&> rmLinks %~ setOutLinks (isCornerLink NorthWest)
         <&> rmLinks %~ setInLinks (isCornerLink SouthEast)
-        <&> rmPmnts <>~ [sps0 $ PutChasm (rectNSWE (y -50) 0 0 (x -50))]
+        <&> rmPmnts <>~ [sps0 $ putConvexChasm (rectNSWE (y -50) 0 0 (x -50))]
 
 -- the Float is the width of the bridge
 zChasm :: Float -> State LayoutVars Room
@@ -156,8 +156,8 @@ zChasm z = do
         <&> rmLinks %~ setInLinks (isCornerLink SouthEast)
         <&> rmPath %~ addNodesCrossing (V2 0 (y/2),V2 x (y/2))
         <&> rmPmnts
-            <>~ [ sps0 $ PutChasm (rectNSWE (y / 2 - z) 0 0 (x -50))
+            <>~ [ sps0 $ putConvexChasm (rectNSWE (y / 2 - z) 0 0 (x -50))
-                , sps0 $ PutChasm (rectNSWE y (y / 2 + z) 50 x)
+                , sps0 $ putConvexChasm (rectNSWE y (y / 2 + z) 50 x)
                 ]
 
 midChasm :: State LayoutVars Room
@@ -174,10 +174,10 @@ midChasm = do
   where
     censquare x y = do
         z <- state $ randomR (40, 60)
-        return [sps0 $ PutChasm (rectNSWE (y - z) z z (x - z))]
+        return [sps0 $ putConvexChasm (rectNSWE (y - z) z z (x - z))]
     cenoct x y =
         return
-            [sps0 $ PutChasm $ (V2 (x / 2) (y / 2) +) <$> polyOrthDist 8 (min x y / 2 - 25)]
+            [sps0 $ putConvexChasm $ (V2 (x / 2) (y / 2) +) <$> polyOrthDist 8 (min x y / 2 - 25)]
 
 --    dia x y = [sps0 $ PutChasm [V2 ]
 
@@ -185,7 +185,7 @@ polyChasm :: Int -> Float -> State LayoutVars Room
 polyChasm n x =
     shuffleLinks
         =<< ( roomNgon n x
-                <&> rmPmnts <>~ [sps0 $ PutChasm $ polyOrthDist n (x -30)]
+                <&> rmPmnts <>~ [sps0 $ putConvexChasm $ polyOrthDist n (x -30)]
                 <&> rmLinks %~ setOutLinks (\rl -> rl ^. rlPos . _y > 0)
                 <&> rmLinks %~ setInLinks (\rl -> rl ^. rlPos . _y < (5 - x))
             )
@@ -193,7 +193,7 @@ polyChasm n x =
 polyChasmC :: Int -> Float -> State LayoutVars Room
 polyChasmC n x =
     roomNgon n x
-        <&> rmPmnts <>~ [sps0 $ PutChasm $ rectNSWE x (60 - x) (-40) 40]
+        <&> rmPmnts <>~ [sps0 $ putConvexChasm $ rectNSWE x (60 - x) (-40) 40]
         <&> rmLinks %~ setInLinks (\rl -> PolyEdge 1 `S.member` (rl ^. rlType))
         <&> rmLinks %~ setOutLinks (\rl -> PolyEdge (n -1) `S.member` (rl ^. rlType))
 

src/Dodge/WorldEvent/ThingsHit.hs

@@ -21,7 +21,7 @@ module Dodge.WorldEvent.ThingsHit (
 import ListHelp
 import Control.Applicative
 import Dodge.Wall.Pathing
-import Data.Monoid
+--import Data.Monoid
 import qualified Data.Set as S
 import Linear
 import Dodge.Data.Object
@@ -182,6 +182,9 @@ isFlyable p1 p2 =
 
 isWalkable :: Point2 -> Point2 -> World -> Bool
 {-# INLINE isWalkable #-}
-isWalkable p1 p2 w = isFlyable p1 p2 w && not (getAny $ foldMap f (w ^. cWorld . chasms))
+isWalkable p1 p2 w = isFlyable p1 p2 w && not (any f (w ^. cWorld . cliffs))
   where
-    f = foldMap (Any . isJust . uncurry (intersectSegSeg p1 p2)) . loopPairs
+    f = isJust . uncurry (intersectSegSeg p1 p2)
+--isWalkable p1 p2 w = isFlyable p1 p2 w && not (getAny $ foldMap f (w ^. cWorld . chasms))
+--  where
+--    f = foldMap (Any . isJust . uncurry (intersectSegSeg p1 p2)) . loopPairs

src/Geometry/Triangulate.hs

@@ -4,6 +4,7 @@ module Geometry.Triangulate where
 
 import Data.List
 
+-- assumes that the polygon is convex
 polyToTris :: [s] -> [s]
 {-# INLINEABLE polyToTris #-}
 polyToTris (x : xs) = foldl' (f x) [] $ zip xs $ tail xs