Improve xIntercepts (still not perfect)

2025-10-22 22:07:45 +01:00
parent d5f985f3ab
commit 59472b16d2
9 changed files with 316 additions and 208 deletions
@@ -1,5 +1,9 @@
-module Dodge.DrWdWd (doDrWdWd) where
+module Dodge.DrWdWd (doDrWdWd,doDrWdWd') where

+import ListHelp
+import Dodge.Zoning.Pathing
+import Dodge.Zoning.Base
+import Geometry.Data
 import Control.Lens
 import Data.Maybe
 import Dodge.Block.Debris
@@ -8,6 +12,7 @@ import Dodge.ShiftPoint
 import Dodge.SoundLogic
 import Dodge.Wall.Move
 import Dodge.WorldBool
+import qualified Data.Set as S

 doDrWdWd :: DrWdWd -> Door -> World -> World
 doDrWdWd dww = case dww of
@@ -15,6 +20,12 @@ doDrWdWd dww = case dww of
    DrWdMakeDoorDebris -> makeDoorDebris
    DoorLerp -> doorLerp

+doDrWdWd' ::  Door -> World -> (S.Set Int2, World)
+doDrWdWd' dr w = case dr ^. drMech of
+    DrWdId -> (mempty,w)
+    DrWdMakeDoorDebris -> (mempty, makeDoorDebris dr w)
+    DoorLerp -> doorLerp' dr w
+
 doorLerp :: Door -> World -> World
 doorLerp dr w = fromMaybe w $ do
    x <- newlerp
@@ -38,4 +49,29 @@ doorLerp dr w = fromMaybe w $ do
        | _drPushedBy dr == PushesItself =
            soundContinue (WallSound drid) (fst $ p2a x) slideDoorS (Just 1)
        | otherwise = id
--    dpos = snd $ _drPos dr
+
+doorLerp' :: Door -> World -> (S.Set Int2,World)
+doorLerp' dr w = fromMaybe (mempty,w) $ do
+    x <- newlerp
+    let ps = (dr ^. drFootPrint) & each . each %~ shiftPointBy (p2a x)
+        is = foldMap (S.fromList . uncurry (zoneOfSeg peZoneSize)) ps
+    return $ (is,
+        f x
+            & playSound x
+            & cWorld . lWorld . doors . ix drid . drLerp .~ x)
+  where
+    f = ifoldl' (flip . moveWallID) w . wlposs
+    p2a = lerpP2A (dr ^. drZeroPos) (dr ^. drOnePos)
+    wlposs x = (dr ^. drFootPrint) & each . each %~ shiftPointBy (p2a x)
+    clerp = dr ^. drLerp
+    newlerp
+        | toOpen && clerp < 1 = Just . min 1 $ clerp + speed
+        | clerp > 0 && not toOpen = Just . max 0 $ clerp - speed
+        | otherwise = Nothing
+    toOpen = doWdBl (_drTrigger dr) w
+    speed = _drSpeed dr
+    drid = _drID dr
+    playSound x
+        | _drPushedBy dr == PushesItself =
+            soundContinue (WallSound drid) (fst $ p2a x) slideDoorS (Just 1)
+        | otherwise = id
@@ -40,6 +40,14 @@ import Linear
 getNodePos :: Int -> World -> Maybe Point2
 getNodePos i w = w ^? cWorld . incNode . ix i

+getEdgesCrossingPoly :: [Point2] -> World -> [(Int,Int)]
+getEdgesCrossingPoly ps w = filter tcross $ zonesExtract (w ^. incEdgeZoning)
+    $ Set.toList $ foldMap (uncurry $ zoneOfSegSet peZoneSize) $ pairs
+  where
+    pairs = loopPairs ps
+    tcross (i,j) = any (isJust . uncurry (intersectSegSeg (f i) (f j))) pairs
+    f i = w ^?! cWorld . incNode . ix i
+
 getEdgesCrossing :: Point2 -> Point2 -> World -> [(Int,Int)]
 getEdgesCrossing s e w = filter inedgecrosses $ nearSeg peZoneSize _incEdgeZoning s e w
  where
@@ -3,6 +3,7 @@
 {- Rooms that contain two doors and a switch alternating both.  -}
 module Dodge.Room.Airlock where

+import Dodge.Room.Path
 import Control.Lens
 import Control.Monad
 import Data.Maybe
@@ -164,12 +165,9 @@ airlockZ = do
        defaultRoom
            { _rmPolys =
                [rectNSWE 120 0 0 180]
-            , _rmLinks = muout [(V2 0 30, pi / 2)] ++ muin [(V2 180 30, 1.5 * pi)]
-            , _rmPath = mempty
-            , --         [(V2 0 40,V2 40 0)
-              --         ,(V2 40 0,V2 0 40)
-              --         ]
-              _rmPmnts =
+            , _rmLinks = lnks
+            , _rmPath = linksGridToPath' lnks $ loopPairs $ rectNSWE 100 40 40 140
+            , _rmPmnts =
                [ pContID (PS (V2 90 115) pi) (PutButton $ makeSwitch col red NoWorldEffect NoWorldEffect) $
                    \btid ->
                        airlockDoubleDoor
@@ -191,6 +189,7 @@ airlockZ = do
                [rectNSWE 120 0 0 180]
            }
  where
+    lnks = muout [(V2 0 30, pi / 2)] ++ muin [(V2 180 30, 1.5 * pi)]
    col = dim $ dim $ bright red
    l1 = 61
    l2 = 61
@@ -4,6 +4,7 @@ module Dodge.Room.Path (
    makeGrid,
    createPathGrid,
    gridPoints'',
+    linksGridToPath',
 ) where

 import Control.Lens
@@ -33,11 +34,18 @@ createPathGrid rm = rm & rmPath .~ linksGridToPath (_rmLinks rm) filterGrid
            <*> L.premap sndV2 L.minimum
            <*> L.premap sndV2 L.maximum

+-- assumes subpth is symmetric
 linksGridToPath :: [RoomLink] -> [(Point2, Point2)] -> S.Set (Point2, Point2)
 linksGridToPath lnks subpth = S.fromList subpth <> foldMap (linkClosest . (^. rlPos)) lnks
  where
    linkClosest p = doublePairSet (p, minimumBy (compare `on` dist p) $ map fst subpth)

+linksGridToPath' :: Foldable f => [RoomLink] -> f (Point2, Point2) -> S.Set (Point2, Point2)
+linksGridToPath' lnks subpth' = subpth <> foldMap (linkClosest . (^. rlPos)) lnks
+  where
+    subpth = foldMap doublePairSet subpth'
+    linkClosest p = doublePairSet (p, minimumBy (compare `on` dist p) $ S.map fst subpth)
+
 testCrossWalls :: [(Point2, Point2)] -> (Point2, Point2) -> Bool
 testCrossWalls wls (a, b) = not $ any (isJust . uncurry (intersectSegSeg a b)) wls

@@ -44,6 +44,11 @@ tutAnoTree = do
        [ tToBTree "TutStartRez" . return . cleatOnward <$> tutRezBox
        , corDoor
        , return $ tToBTree "cor" $ return $ cleatOnward corridor
+--        , return $ tToBTree "cor" $ return $ cleatOnward corridor
+--        , return $ tToBTree "cor" $ return $ cleatOnward corridor
+--        , return $ tToBTree "cor" $ return $ cleatOnward (twinSlowDoorRoom 80 200 40)
+--        , return $ tToBTree "cor" $ return $ cleatOnward corridor
+--        , return $ tToBTree "cor" $ return $ cleatOnward corridor
        , return $ tToBTree "cor" $ return $ cleatOnward corridor
        , tToBTree "asdf" . return . cleatOnward <$> airlockZ
        --, return . tToBTree "asdf" . return . cleatOnward $ airlockCrystal
@@ -3,6 +3,11 @@

 module Dodge.Update (updateUniverse) where

+import Dodge.Zoning.Pathing
+import Dodge.Debug.Picture
+import Dodge.Zoning.Base
+import Dodge.Path
+import Data.Foldable
 import qualified Data.Set as S
 import Color
 import Control.Applicative
@@ -247,7 +252,8 @@ functionalUpdate =
        . over uvWorld updateCreatureSoundPositions
        . colCrsWalls
        . over uvWorld simpleCrSprings
-        . over uvWorld (updateIMl' (_doors . _lWorld . _cWorld) updateDoor)
+--        . over uvWorld (updateIMl' (_doors . _lWorld . _cWorld) updateDoor)
+        . over uvWorld updateDoors
        . over uvWorld doWorldEvents
        . over uvWorld updateDelayedEvents
        . over
@@ -307,6 +313,27 @@ updateAimPos u =
    u & uvWorld . cWorld . lWorld . lAimPos
        .~ mouseWorldPos (u ^. uvWorld . input) (u ^. uvWorld . wCam)

+updateEdgesWall :: S.Set (Int,Int) -> World -> World
+updateEdgesWall = flip $ foldl' updateEdgeWallObs
+
+updateEdgeWallObs :: World -> (Int,Int) -> World
+updateEdgeWallObs w (i,j) = fromMaybe w $ do
+    s <- getNodePos i w
+    e <- getNodePos i w
+    let wls = snd <$> wlsHitUnsorted s e w
+    return $ w & cWorld . incGraph %~ updateEdge (f wls) (i,j)
+  where
+    f wls = at DoorObstacle ?~ ()
+--        | all _wlWalkable wls = (at BlockObstacle .~ Nothing) . (at DoorObstacle .~ Nothing)
+--        | otherwise = at DoorObstacle ?~ ()
+
+updateDoors :: World -> World
+updateDoors w = let (is,w') = foldrM doDrWdWd' w (w ^. cWorld . lWorld . doors)
+    in updateEdgesWall (zonesExtract (w ^. incEdgeZoning & each . each %~ S.fromList) is) w'
+        & cWorld . lWorld . flares <>~ foldMap (drawZoneCol green peZoneSize) is
+--updateDoors w = uncurry updateEdgesWall .
+--    over _1 (zonesExtract (w ^. incEdgeZoning & each . each %~ S.fromList)) $ foldrM doDrWdWd' w (w ^. cWorld . lWorld . doors)
+
 updateDoor :: Door -> World -> World
 updateDoor dr = doDrWdWd (_drMech dr) dr

@@ -534,6 +561,14 @@ updateIMl fim fup w = alaf Endo foldMap (dbArg fup) (fim w) w
 updateIMl' :: (World -> IM.IntMap a) -> (a -> World -> World) -> World -> World
 updateIMl' fim fup w = alaf Endo foldMap fup (fim w) w

+updateAccum :: (Foldable f, Monoid m) 
+    => (World -> f a) 
+    -> (a -> World -> (m, World))
+    -> World 
+    -> (m, World)
+updateAccum fim fup w = foldrM fup w (fim w)
+    --alaf Endo foldMap fup (fim w) w
+
 updateCreatureGroups :: World -> World
 updateCreatureGroups w =
    w & cWorld . lWorld . creatureGroups
@@ -13,6 +13,7 @@ module Dodge.WorldEvent.ThingsHit (
    wlsHitRadial,
    crHit,
    crWlPbHit,
+    wlsHitUnsorted,
 ) where

 import Linear
@@ -131,11 +132,13 @@ thingsHitExceptCr (Just cid) sp ep = filter t . thingsHit sp ep
    t = (Just cid /=) . (^? _2 . _Left . crID)

 wlsHit :: Point2 -> Point2 -> World -> [(Point2, Wall)]
-wlsHit sp ep
+wlsHit sp ep = sortOn (dist sp . fst) . wlsHitUnsorted sp ep
+
+wlsHitUnsorted :: Point2 -> Point2 -> World -> [(Point2, Wall)]
+wlsHitUnsorted sp ep
    | sp == ep = const mempty
    | otherwise =
-        sortOn (dist sp . fst)
-            . overlapSegWalls sp ep
+            overlapSegWalls sp ep
            . wlsNearSeg sp ep

 wlsHitRadial :: Point2 -> Float -> World -> [(Point2, Wall)]
@@ -4,18 +4,20 @@ module Dodge.Zoning.Base
    , zoneOfPoint
    , zonesExtract
    , zoneOfSeg
+    , zoneOfSegSet
    , zoneOfRect
    , zoneMonoid
    , deZoneIX
    , zoneOfCirc
    , zonesAroundPoint
    , xIntercepts
-    , yIntercepts'
+    , yIntercepts
    , updateInt2Map
    ) where

 import Control.Lens
 import qualified Data.IntSet as IS
+import qualified Data.Set as S
 --import Data.Maybe
 import Geometry
 import Geometry.Zone
@@ -46,21 +48,26 @@ zoneOfPoint = fmap . divTo

 zoneOfSeg :: Float -> Point2 -> Point2 -> [Int2]
 {-# INLINE zoneOfSeg #-}
-zoneOfSeg s sp ep = map (zoneOfPoint s) (sp : xIntercepts s sp ep ++ yIntercepts' s sp ep)
+zoneOfSeg s sp ep = map (zoneOfPoint s) (sp : xIntercepts s sp ep ++ yIntercepts s sp ep)
+--zoneOfSeg s sp ep = map (zoneOfPoint s) (sp : xIntercepts s sp ep )
+
+zoneOfSegSet :: Float -> Point2 -> Point2 -> S.Set Int2
+{-# INLINE zoneOfSegSet #-}
+zoneOfSegSet s sp = S.fromList . zoneOfSeg s sp

 -- | zoneExtract (V2 x y) == fromMaybe mempty . (^? ix x . ix y)
 zoneExtract :: Monoid m => Int2 -> IM.IntMap (IM.IntMap m) -> m
 {-# INLINE zoneExtract #-}
 zoneExtract (V2 x y) = foldOf (ix x . ix y)

-zonesExtract :: Monoid m => IM.IntMap (IM.IntMap m) -> [Int2] -> m
+zonesExtract :: (Foldable f,Monoid m) => IM.IntMap (IM.IntMap m) -> f Int2 -> m
 {-# INLINE zonesExtract #-}
 zonesExtract = foldMap . flip zoneExtract

 xIntercepts :: Float -> Point2 -> Point2 -> [Point2]
 {-# INLINE xIntercepts #-}
 xIntercepts s (V2 sx sy) (V2 ex ey)
-    | xdx == 0 = []
+    | divTo s sx == divTo s ex = []
    | otherwise = zipWith V2 [halfstep + sx', halfstep + sx' + xdx * s .. ex] ([sy', sy' + ydx * s .. ey] ++ repeat ey)
  where
    halfstep
@@ -73,9 +80,9 @@ xIntercepts s (V2 sx sy) (V2 ex ey)
        | xdx < 0 = sx - modTo s sx
        | otherwise = s + sx - modTo s sx

-yIntercepts' :: Float -> Point2 -> Point2 -> [Point2]
-{-# INLINE yIntercepts' #-}
-yIntercepts' s sp ep = map f $ xIntercepts s (f sp) (f ep)
+yIntercepts :: Float -> Point2 -> Point2 -> [Point2]
+{-# INLINE yIntercepts #-}
+yIntercepts s sp ep = map f $ xIntercepts s (f sp) (f ep)
  where
    f (V2 x y) = V2 y x