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

Make chasms remove RoomPos within their boundaries

Browse Source
This commit is contained in:
justin
2025-10-07 10:43:15 +01:00
parent 4cc5477f07
commit e9178f9643
12 changed files with 280 additions and 256 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Data/Room.hs
+14 -8
View File
@@ -1,5 +1,6 @@
{-# LANGUAGE StrictData #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE LambdaCase #-}
module Dodge.Data.Room (
module Dodge.Data.Room,
@@ -14,8 +15,8 @@ import Geometry
data RoomPos = RoomPos
{ _rpPos :: Point2
, _rpDir :: Float
, _rpType :: S.Set RoomPosType
, _rpLinkStatus :: RPLinkStatus
, _rpFlags :: S.Set RoomPosFlag
, _rpType :: RPLinkStatus
, _rpPlacementUse :: S.Set UsedPos
}
deriving (Eq, Ord, Show)
@@ -53,6 +54,7 @@ data RoomWire
= --RoomWire Point2 Float
WallWire Point2 Float Float
-- the link constructors should probably be combined in some way
data RPLinkStatus
= UsedOutLink
{ _rplsType :: S.Set RoomLinkType
@@ -64,16 +66,20 @@ data RPLinkStatus
, _rplsInRoomID :: Int
}
| UnusedLink {_rplsType :: S.Set RoomLinkType}
| PathNodeRP
| NotLink
| NotLink {_rpOnPath :: Bool}
deriving (Eq, Ord, Show)
notLink :: RPLinkStatus -> Bool
notLink = \case
NotLink {} -> True
_ -> False
data PathFromEdge = PathFromEdge CardinalPoint Int
deriving (Eq, Ord, Show)
data RoomPosType
= RoomPosOnGrid {_onPathFromEdges :: S.Set PathFromEdge}
| RoomPosOffGrid {_offPathFromEdges :: S.Set PathFromEdge}
data RoomPosFlag
= RoomPosOnGrid {_onGridFromEdges :: S.Set PathFromEdge}
| RoomPosOffGrid {_offGridFromEdges :: S.Set PathFromEdge}
deriving (Eq, Ord, Show)
data UsedPos
@@ -85,5 +91,5 @@ data UsedPos
makeLenses ''RoomLink
makeLenses ''RoomPos
makeLenses ''RoomPosType
makeLenses ''RoomPosFlag
makeLenses ''RPLinkStatus
src/Dodge/Layout.hs
+4 -4
View File
@@ -168,21 +168,21 @@ gameRoomFromRoom rm =
[ p +.+ 10 *.* unitVectorAtAngle a
, p -.- 10 *.* unitVectorAtAngle a
]
filterUnusedLinks rp = case _rpLinkStatus rp of
filterUnusedLinks rp = case _rpType rp of
UnusedLink{} -> Just $ _rpPos rp
_ -> Nothing
filterUsedLinks rp = case _rpLinkStatus rp of
filterUsedLinks rp = case _rpType rp of
UsedOutLink{} -> doubleShift (_rpPos rp) (_rpDir rp)
UsedInLink{} -> doubleShift (_rpPos rp) (_rpDir rp)
_ -> []
undir rp = case _rpLinkStatus rp of
undir rp = case _rpType rp of
UsedOutLink{} -> ma
UsedInLink{} -> ma
_ -> Nothing
where
ma = Just $ 0.5 * pi + _rpDir rp + snd (_rmShift rm)
closePoints x y = roundPoint2 x == roundPoint2 y
getDir (rp : xs) = case _rpLinkStatus rp of
getDir (rp : xs) = case _rpType rp of
UsedInLink{} -> _rpDir rp + snd (_rmShift rm)
_ -> getDir xs
getDir _ = 0 -- fallback
src/Dodge/Placement/PlaceSpot.hs
+5 -2
View File
@@ -126,7 +126,8 @@ placeSpotID rid ps pt w = case pt of
w
PutMachine pps mc wl mitm -> plMachine (map doShift pps) mc wl mitm p rot w
PutLS ls -> plNewUpID (gwWorld . cWorld . lWorld . lightSources) lsID (mvLS p' rot ls) w
PutPPlate pp -> plNewUpID (gwWorld . cWorld . lWorld . pressPlates) ppID (mvPP p rot pp) w
PutPPlate pp
-> plNewUpID (gwWorld . cWorld . lWorld . pressPlates) ppID (mvPP p rot pp) w
RandPS _ -> error "RandPS should not be reachable here" --evaluateRandPS rid rgn ps w
PutDoor col eo f pss -> plDoor col eo f (map (bimap doShift doShift) pss) w
PutCoord cp -> plNewID (gwWorld . coordinates) (doShift cp) w
@@ -143,7 +144,9 @@ 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, w & gwWorld . cWorld . chasms .:~ map doShift ps')
PutChasm ps' -> (0, w & gwWorld . cWorld . chasms .:~ map doShift ps'
& genRooms . ix rid . rmPos %~ filter (\rp -> not $ pointInPoly (_rpPos rp) ps')
)
PutLabel{} -> (0, w)
where
p@(V2 px py) = _psPos ps
src/Dodge/PlacementSpot.hs
+24 -24
View File
@@ -1,9 +1,9 @@
--{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE LambdaCase #-}
module Dodge.PlacementSpot (
atFstLnkOut,
atNthLnkOutShiftBy,
rpIsOnGrid,
rpIsOffPath,
rpIsOffGrid,
rpOffPathFromEdge,
useUnusedLnk,
psRandRanges,
@@ -59,35 +59,35 @@ randDirPS ps = do
return $ setDirPS a ps
isUnusedLnk :: RoomPos -> Room -> Bool
isUnusedLnk rp _ = case _rpLinkStatus rp of
isUnusedLnk rp _ = case _rpType rp of
UnusedLink{} -> null $ _rpPlacementUse rp
_ -> False
anyUnusedSpot :: PlacementSpot
anyUnusedSpot = rprBool $ \rp _ -> _rpLinkStatus rp == NotLink && null (_rpPlacementUse rp)
anyUnusedSpot = rprBool $ \rp _ -> notLink (_rpType rp) && null (_rpPlacementUse rp)
psposAddLabel :: RoomPosType -> PlacementSpot -> PlacementSpot
psposAddLabel lab = psSelect %~ (\f rp r -> f rp r & _Just . _2 . rpType %~ S.insert lab)
psposAddLabel :: RoomPosFlag -> PlacementSpot -> PlacementSpot
psposAddLabel lab = psSelect %~ (\f rp r -> f rp r & _Just . _2 . rpFlags %~ S.insert lab)
rprBool :: (RoomPos -> Room -> Bool) -> PlacementSpot
rprBool t = PSPos (useRoomPosRoomCond (S.singleton UsedPosLow) t) (const id) Nothing
rpIsOnGrid :: RoomPos -> Bool
rpIsOnGrid = any f . _rpType
rpIsOnGrid = any f . _rpFlags
where
f RoomPosOnGrid{} = True
f _ = False
rpIsOffPath :: RoomPos -> Bool
rpIsOffPath = any f . _rpType
rpIsOffGrid :: RoomPos -> Bool
rpIsOffGrid = any f . _rpFlags
where
f RoomPosOffGrid{} = True
f _ = False
rpOffPathFromEdge :: PathFromEdge -> RoomPos -> Bool
rpOffPathFromEdge pe = any f . _rpType
rpOffPathFromEdge pe = any f . _rpFlags
where
f rt = maybe False (pe `elem`) (rt ^? offPathFromEdges)
f rt = maybe False (pe `elem`) (rt ^? offGridFromEdges)
resetPLUse :: PlacementSpot -> PlacementSpot
resetPLUse (PSPos f g fallback) = PSPos f' g fallback
@@ -118,7 +118,7 @@ rprBoolShift t shift = PSPos f (const id) Nothing
unusedSpotAwayFromLink :: Float -> PlacementSpot
unusedSpotAwayFromLink x = rprBool $ \rp r ->
_rpLinkStatus rp == NotLink
notLink (_rpType rp)
&& null (_rpPlacementUse rp)
&& all ((> x) . dist (_rpPos rp)) (usedRoomLinkPoss r)
@@ -132,11 +132,11 @@ unusedOffPathAwayFromLink :: Float -> PlacementSpot
unusedOffPathAwayFromLink x = rprBool $ \rp r ->
null (_rpPlacementUse rp)
&& all ((> x) . dist (_rpPos rp)) (usedRoomLinkPoss r)
&& rpIsOffPath rp
&& rpIsOffGrid rp
unusedSpotAwayFromInLink :: Float -> PlacementSpot
unusedSpotAwayFromInLink x = rprBool $ \rp r ->
_rpLinkStatus rp == NotLink
notLink (_rpType rp)
&& null (_rpPlacementUse rp)
&& all ((> x) . dist (_rpPos rp)) (usedRoomInLinkPoss r)
@@ -159,12 +159,12 @@ twoRoomPoss cond1 cond2 f = Placement (rprBool cond1) PutNothing Nothing Nothing
-- _ -> False
isInLnk :: RoomPos -> Bool
isInLnk rp = case _rpLinkStatus rp of
isInLnk rp = case _rpType rp of
UsedInLink{} -> null $ _rpPlacementUse rp
_ -> False
isOutLnk :: RoomPos -> Bool
isOutLnk rp = case _rpLinkStatus rp of
isOutLnk rp = case _rpType rp of
UsedOutLink{} -> null $ _rpPlacementUse rp
_ -> False
@@ -172,7 +172,7 @@ useUnusedLnk :: PlacementSpot
useUnusedLnk = rprBool isUnusedLnk
isUsedLnkUnplaced :: RoomPos -> Bool
isUsedLnkUnplaced rp = case _rpLinkStatus rp of
isUsedLnkUnplaced rp = case _rpType rp of
UsedOutLink{} -> null (_rpPlacementUse rp)
UsedInLink{} -> null (_rpPlacementUse rp)
_ -> False
@@ -188,28 +188,28 @@ useRoomPosRoomCond xs t rp r
| otherwise = Nothing
isUnusedLnkType :: RoomLinkType -> RoomPos -> Room -> Bool
isUnusedLnkType rlt rp _ = case _rpLinkStatus rp of
isUnusedLnkType rlt rp _ = case _rpType rp of
UnusedLink{_rplsType = rlts} -> rlt `S.member` rlts
&& null (_rpPlacementUse rp)
_ -> False
unusedSpotNearInLink :: Float -> PlacementSpot
unusedSpotNearInLink x = rprBool $ \rp r ->
_rpLinkStatus rp == NotLink
notLink (_rpType rp)
&& null (_rpPlacementUse rp)
&& any ((< x) . dist (_rpPos rp)) (usedRoomInLinkPoss r)
usedRoomInLinkPoss :: Room -> [Point2]
usedRoomInLinkPoss r = mapMaybe f $ _rmPos r
where
f rp = case _rpLinkStatus rp of
f rp = case _rpType rp of
UsedInLink{} -> Just $ _rpPos rp
_ -> Nothing
usedRoomLinkPoss :: Room -> [Point2]
usedRoomLinkPoss r = mapMaybe f $ _rmPos r
where
f rp = case _rpLinkStatus rp of
f rp = case _rpType rp of
UsedInLink{} -> Just $ _rpPos rp
UsedOutLink{} -> Just $ _rpPos rp
_ -> Nothing
@@ -218,12 +218,12 @@ atFstLnkOut :: PlacementSpot
atFstLnkOut = atNthLinkOut 0
atNthLinkOut :: Int -> PlacementSpot
atNthLinkOut n = rprBool $ \rp _ -> rp ^? rpLinkStatus . rplsChildNum == Just n
atNthLinkOut n = rprBool $ \rp _ -> rp ^? rpType . rplsChildNum == Just n
atNthLnkOutShiftBy :: Int -> ((Point2, Float) -> ((Point2, Float),S.Set UsedPos))
-> PlacementSpot
atNthLnkOutShiftBy n = rprBoolShift $
\rp _ -> rp ^? rpLinkStatus . rplsChildNum == Just n
\rp _ -> rp ^? rpType . rplsChildNum == Just n
--atNthLnkOutShiftBy n theshift = PSPos f (const id) Nothing
-- where
@@ -253,7 +253,7 @@ shiftByV2 x (p, a) = (p +.+ rotateV a x, a)
-- this should probably check the placement use, but so should others: should
-- unify these
useLnkRoomPos :: S.Set UsedPos -> RoomPos -> Room -> Maybe (PlacementSpot, RoomPos)
useLnkRoomPos xs rp _ = case _rpLinkStatus rp of
useLnkRoomPos xs rp _ = case _rpType rp of
UnusedLink{} -> Just (PS (_rpPos rp) (_rpDir rp), rp & rpPlacementUse <>~ xs)
_ -> Nothing
src/Dodge/Room/Ngon.hs
+3
View File
@@ -25,6 +25,7 @@ roomNgon n x = do
, _rmBound = [poly]
, _rmFloor = Tiled [makeTileFromPoly poly 2]
, _rmName = show n ++ "gon"
, _rmPos = poss
}
where
rot = 2 * pi / fromIntegral n
@@ -34,6 +35,8 @@ roomNgon n x = do
path2 = concat $ zipWith g path1 (tail path1 <> [head path1])
path3 = loopPairs path2 <> fmap (,V2 0 0) path2
path4 = concatMap doublePair path3
poss = map (\p -> RoomPos p 0 mempty (NotLink True) mempty)
(V2 0 0 : path1)
g z y = [z, 0.5 * (z + y)]
lnks =
sortOn ((\(V2 a b) -> (negate b, a)) . fst . snd)
src/Dodge/Room/Pillar.hs
+5 -5
View File
@@ -87,8 +87,8 @@ roomPillarsSquare = do
++ concatMap (replicate nlns . makepill) [East, West]
where
makepill edge = sps (rprBool $ \rp _ -> t edge rp) smallPillar
t edge rp = any (f edge) (_rpType rp) && null (_rpPlacementUse rp)
f edge rpt = maybe False (PathFromEdge edge 0 `S.member`) (rpt ^? offPathFromEdges)
t edge rp = any (f edge) (_rpFlags rp) && null (_rpPlacementUse rp)
f edge rpt = maybe False (PathFromEdge edge 0 `S.member`) (rpt ^? offGridFromEdges)
roomPillarsPassage :: RandomGen g => State g Room
roomPillarsPassage = do
@@ -106,16 +106,16 @@ roomPillarsPassage = do
roomPillars :: RandomGen g => Float -> Float -> Float -> Int -> Int -> State g Room
roomPillars pillarsize w h wn hn = do
let rm = roomRect w h wn hn
npillars = length $ filter rpIsOffPath $ _rmPos rm
npillars = length $ filter rpIsOffGrid $ _rmPos rm
plmnts =
replicate
npillars
( blockPillar (0.5 * pilw) (0.5 * pilh) & plSpot
.~ rprBool
( \rp _ ->
rpIsOffPath rp
rpIsOffGrid rp
&& null (_rpPlacementUse rp)
&& _rpLinkStatus rp == NotLink
&& notLink (_rpType rp)
)
)
addGirderLights $
src/Dodge/Room/Procedural.hs
+5 -5
View File
@@ -98,7 +98,7 @@ roomRect x y xn yn =
pth = linksGridToPath lnks
$ map (bimap (+.+ V2 20 20) (+.+ V2 20 20)) (makeGrid xd xn yd yn)
makeonpos (p, a) = RoomPos p 0 (S.singleton $ RoomPosOnGrid $ makerpedges a)
NotLink mempty
(NotLink True) mempty
makerpedges (a, b) =
S.fromList
[ PathFromEdge South b
@@ -109,7 +109,7 @@ roomRect x y xn yn =
posps = map (over _1 (+.+ V2 20 20)) $ gridPoints'' xd (xn + 1) yd (yn + 1)
interposps = map (over _1 (+.+ V2 (20 + xd / 2) (20 + yd / 2))) $ gridPoints'' xd xn yd yn
makeoffpos (p, a) = RoomPos
p 0 (S.singleton $ RoomPosOffGrid $ makerpedges' a) NotLink mempty
p 0 (S.singleton $ RoomPosOffGrid $ makerpedges' a) (NotLink False) mempty
makerpedges' (a, b) =
S.fromList
[ PathFromEdge South b
@@ -206,8 +206,8 @@ quarterRoomTri w = do
]
, _rmPmnts = b ++ [mntLS iShape (V2 (w -20) w) (V3 (w -20) (w -20) 70)]
, _rmPos =
[ RoomPos (V2 (w -20) (w -20)) pi S.empty NotLink mempty
, RoomPos (V2 (w -15) (w -25)) pi S.empty NotLink mempty
[ RoomPos (V2 (w -20) (w -20)) pi S.empty (NotLink False) mempty
, RoomPos (V2 (w -15) (w -25)) pi S.empty (NotLink False) mempty
]
, _rmBound = [[V2 0 0, V2 w w, V2 (- w) w]]
}
@@ -255,7 +255,7 @@ quarterRoomSquare w = do
]
, _rmPmnts = b ++ [blockLine (V2 (w / 2) (w / 2)) (V2 0 w)]
, _rmPos =
[ RoomPos p pi S.empty NotLink mempty
[ RoomPos p pi S.empty (NotLink False) mempty
| p <- [V2 20 (2 * w -40), V2 25 (2 * w -45)]
]
, --, _rmBound = [map toV2 [(w,w),(0,2*w),(-w,w)]]
src/Dodge/Room/Room.hs
+2 -2
View File
@@ -77,7 +77,7 @@ glassSwitchBack = do
l2 <-
mntLightLnkCond $
rprBool $ \rp _ ->
rp ^. rpLinkStatus . rplsType . at (OnEdge West) == Just ()
rp ^. rpType . rplsType . at (OnEdge West) == Just ()
&& null (rp ^. rpPlacementUse)
let hf = hgt / 5
awindow h xl xr = windowLine (V2 xl h) (V2 xr h)
@@ -207,7 +207,7 @@ weaponBetweenPillars = do
and
[ rpIsOnGrid rp
, null $ _rpPlacementUse rp
, _rpLinkStatus rp == NotLink
, notLink (_rpType rp)
, any ((< 100) . dist (_rpPos rp)) (usedRoomInLinkPoss r)
]
ncrits <- state $ randomR (1, 3)
src/Dodge/Room/Tutorial.hs
+14 -2
View File
@@ -1,6 +1,5 @@
module Dodge.Room.Tutorial where
import Dodge.Room.Pillar
import Dodge.Item.Held.Utility
import Control.Monad
import qualified Data.IntMap.Strict as IM
@@ -39,12 +38,25 @@ import TreeHelp
--import Data.List (intersperse)
testf = PSPos (\x _ -> f x) (\_ -> id) Nothing
where
f x = case _rpType x of
NotLink{} -> Just (PS (_rpPos x) (_rpDir x), x)
_ -> Nothing
tutAnoTree :: State LayoutVars MTRS
tutAnoTree = do
foldMTRS
[ tToBTree "TutStartRez" . return . cleatOnward <$> tutRezBox
, corDoor
, tToBTree "x" . return . cleatOnward <$> roomPillarsSquare
, tToBTree "test" . return . cleatOnward <$> (roomRectAutoLinks 100 100
<&> rmPmnts <>~
[sps0 $ PutChasm $ rectNSWE 70 30 30 70
, Placement testf (PutFlIt led) Nothing Nothing (const $ const Nothing)
]
<&> rmPos .~[RoomPos 35 0 mempty (NotLink False) mempty]
-- <&> rmPos .~[]
)
, corDoor
, tutHub
, tutLight
src/Dodge/Room/Warning.hs
+1 -1
View File
@@ -69,7 +69,7 @@ lineOutputTerminal tls = defaultTerminal & tmBootLines .~ textInputBlurb tls
moveToSideNthOutLink :: S.Set UsedPos
-> Int -> RoomPos -> Room -> Maybe ((Point2, Float), S.Set UsedPos)
moveToSideNthOutLink xs i rp rm = do
j <- rp ^? rpLinkStatus . rplsChildNum
j <- rp ^? rpType . rplsChildNum
guard $ i == j
let rppos = _rpPos rp
rpdir = _rpDir rp
src/Dodge/Tree/Shift.hs
+6 -6
View File
@@ -92,8 +92,8 @@ posRms prs parenti@(parent, _) ((numChild, t@(Node childi _)) : its) tseq = do
--, _rpDir = snd (lnkPosDir outlnk)
{ _rpPos = outlnk ^. rlPos
, _rpDir = outlnk ^. rlDir
, _rpType = S.empty
, _rpLinkStatus = UsedOutLink (_rlType outlnk) numChild (snd childi)
, _rpFlags = S.empty
, _rpType = UsedOutLink (_rlType outlnk) numChild (snd childi)
, _rpPlacementUse = mempty
}
& rmChildren .:~ snd childi
@@ -109,8 +109,8 @@ posRms prs parenti@(parent, _) ((numChild, t@(Node childi _)) : its) tseq = do
--, _rpDir = snd (lnkPosDir outlnk)
{ _rpPos = il ^. rlPos
, _rpDir = il ^. rlDir
, _rpType = S.empty
, _rpLinkStatus = UsedInLink (_rlType il) (snd parenti)
, _rpFlags = mempty
, _rpType = UsedInLink (_rlType il) (snd parenti)
, _rpPlacementUse = mempty
}
shiftedt =
@@ -128,8 +128,8 @@ createUnusedLinkPos rm = rm & rmPos .++~ map f (_rmLinks rm)
RoomPos
{ _rpPos = _rlPos rl
, _rpDir = _rlDir rl
, _rpType = S.empty
, _rpLinkStatus = UnusedLink $ _rlType rl
, _rpFlags = mempty
, _rpType = UnusedLink $ _rlType rl
, _rpPlacementUse = mempty
}