justin/loop
1
0
Fork 0
Code Issues Pull Requests 1 Packages Projects Releases Wiki Activity

Simplify room link functions

Browse Source
This commit is contained in:
justin
2025-10-03 18:55:18 +01:00
parent a8348a3515
commit 2d44809900
14 changed files with 229 additions and 205 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Room/Boss.hs
+4 -3
View File
@@ -29,10 +29,10 @@ roomGlassOctogon x =
[ rectNSWE x (- x) (- x) x
, rectNSWE 0 (- (x + 40)) (-20) 20
]
, _rmLinks = map (uncurry outLink) (init lnks) ++ [uncurry inLink $ last lnks]
, _rmLinks = lnks'
, _rmPath =
linksAndPath
lnks
linksAndPath'
lnks'
[ (V2 0 x, V2 0 (- (x + 40)))
, (V2 0 (- (x + 40)), V2 0 x)
]
@@ -52,6 +52,7 @@ roomGlassOctogon x =
}
where
fx = 4 * x / 5
lnks' = map (uncurry outLink) (init lnks) ++ [uncurry inLink $ last lnks]
lnks =
[ (V2 0 x, 0)
, (V2 0 (- (x + 40)), pi)
src/Dodge/Room/CheckConsistency.hs
+1 -1
View File
@@ -7,7 +7,7 @@ import Dodge.RoomLink
linksOnPath :: Room -> Bool
linksOnPath r = all pointOnPath linkPoints
where
linkPoints = map (fst . lnkPosDir) $ _rmLinks r
linkPoints = map (_rlPos) $ _rmLinks r
pointOnPath p = elem p $ concatMap flat2 $ _rmPath r
flat2 (x,y) = [x,y]
src/Dodge/Room/Path.hs
+11 -7
View File
@@ -1,12 +1,12 @@
module Dodge.Room.Path (
gridPoints,
linksAndPath,
linksAndPath',
makeGrid,
createPathGrid,
gridPoints'',
) where
import Control.Lens
import qualified Control.Foldl as L
import Data.Function (on)
import Data.List
@@ -21,7 +21,7 @@ import Grid
createPathGrid :: Room -> Room
createPathGrid rm =
rm
{ _rmPath = linksAndPath (map lnkPosDir $ _rmLinks rm) filterGrid
{ _rmPath = linksAndPath' (_rmLinks rm) filterGrid
}
where
filterGrid = filter (\p -> pairInPolys (_rmPolys rm) p && testCrossWalls outerWalls p) grid
@@ -36,13 +36,17 @@ createPathGrid rm =
<*> L.premap sndV2 L.minimum
<*> L.premap sndV2 L.maximum
linksAndPath :: [(Point2, Float)] -> [(Point2, Point2)] -> S.Set (Point2, Point2)
linksAndPath lnks subpth = S.fromList subpth <> foldMap linkClosest lnks
where
linkClosest (p, _) = doublePairSet (p, minimumBy (compare `on` dist p) $ map fst subpth)
--linksAndPath :: [(Point2, Float)] -> [(Point2, Point2)] -> S.Set (Point2, Point2)
--linksAndPath lnks subpth = S.fromList subpth <> foldMap linkClosest lnks
-- where
-- linkClosest (p, _) = doublePairSet (p, minimumBy (compare `on` dist p) $ map fst subpth)
linksAndPath' :: [RoomLink] -> [(Point2, Point2)] -> S.Set (Point2, Point2)
linksAndPath' = linksAndPath . map lnkPosDir
linksAndPath' lnks subpth = S.fromList subpth
<> foldMap (linkClosest . (^. rlPos) ) lnks
where
linkClosest p = doublePairSet (p, minimumBy (compare `on` dist p) $ map fst subpth)
--linksAndPath' = linksAndPath . map lnkPosDir
testCrossWalls :: [(Point2, Point2)] -> (Point2, Point2) -> Bool
testCrossWalls wls (a, b) = not $ any (isJust . uncurry (intersectSegSeg a b)) wls
src/Dodge/Room/Procedural.hs
+1 -1
View File
@@ -6,7 +6,7 @@ module Dodge.Room.Procedural (
randomFourCornerRoomCrsIts,
centerVaultRoom,
combineRooms,
linksAndPath,
-- linksAndPath,
makeGrid,
) where
src/Dodge/Room/RezBox.hs
+2 -1
View File
@@ -98,7 +98,8 @@ rezBoxesWpCrit = do
centralRoom <- roomRectAutoLinks w h <&> rmPmnts .~ []
onwardpassage <-
over root (rmConnectsTo .~ S.member (OnEdge West)) <$> maybeBlockedPassage
let n = length $ filter bottomEdgeTest $ map lnkPosDir $ _rmLinks centralRoom
let n = length $ filter bottomEdgeTest $ map (\rl -> (rl ^. rlPos, rl ^. rlDir))
$ _rmLinks centralRoom
i <- state $ randomR (0, n -3)
j <- state $ randomR (i, n -2)
let rezrooms =
src/Dodge/Room/Tutorial.hs
-10
View File
@@ -1,16 +1,6 @@
module Dodge.Room.Tutorial where
import Control.Monad
--import Dodge.Room.Corridor
--import Dodge.Room.Door
--import Dodge.Room.Link
--import Dodge.Room.RoadBlock
--import Dodge.Tree
--import Padding
import qualified Data.IntMap.Strict as IM
import qualified Data.IntSet as IS
import Data.Maybe (mapMaybe)
src/Dodge/RoomLink.hs
+1 -1
View File
@@ -5,7 +5,7 @@ module Dodge.RoomLink (
inLink,
restrictLinkType,
overLnkType,
lnkPosDir,
-- lnkPosDir,
overLnkPosDir,
toBothLnk,
rmInLinks,
src/Dodge/Tree/Shift.hs
+11 -5
View File
@@ -87,8 +87,10 @@ posRms prs parenti@(parent, _) ((numChild, t@(Node childi _)) : its) tseq = do
& rmLinks %~ delete outlnk
& rmPos
.:~ RoomPos
{ _rpPos = fst (lnkPosDir outlnk)
, _rpDir = snd (lnkPosDir outlnk)
--{ _rpPos = fst (lnkPosDir outlnk)
--, _rpDir = snd (lnkPosDir outlnk)
{ _rpPos = outlnk ^. rlPos
, _rpDir = outlnk ^. rlDir
, _rpType = S.empty
, _rpLinkStatus = UsedOutLink (_rlType outlnk) numChild (snd childi)
, _rpPlacementUse = mempty
@@ -102,8 +104,10 @@ posRms prs parenti@(parent, _) ((numChild, t@(Node childi _)) : its) tseq = do
& rmLinks %~ delete il
& rmPos
.:~ RoomPos
{ _rpPos = fst (lnkPosDir il)
, _rpDir = snd (lnkPosDir il)
--{ _rpPos = fst (lnkPosDir outlnk)
--, _rpDir = snd (lnkPosDir outlnk)
{ _rpPos = outlnk ^. rlPos
, _rpDir = outlnk ^. rlDir
, _rpType = S.empty
, _rpLinkStatus = UsedInLink (_rlType il) (snd parenti)
, _rpPlacementUse = mempty
@@ -111,7 +115,9 @@ posRms prs parenti@(parent, _) ((numChild, t@(Node childi _)) : its) tseq = do
shiftedt =
over
root
(first $ updatechild . shiftRoomShiftToLink (lnkPosDir shiftedoutlink) (lnkPosDir il))
(first $ updatechild . shiftRoomShiftToLink
(shiftedoutlink ^. rlPos, shiftedoutlink ^. rlDir)
(il ^. rlPos, il ^. rlDir))
t
createUnusedLinkPos :: Room -> Room