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

Move towards unifying RoomPos constructors

Browse Source
This commit is contained in:
justin
2022-03-10 16:21:44 +00:00
parent 907cca0ef0
commit 7b1ac2b682
7 changed files with 94 additions and 60 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Layout.hs
+6 -6
View File
@@ -215,16 +215,16 @@ gameRoomFromRoom rm = GameRoom
[p +.+ 10 *.* unitVectorAtAngle a
,p -.- 10 *.* unitVectorAtAngle a
]
filterUnusedLinks (UnusedLink p _ _) = Just p
filterUnusedLinks (UnusedLink p _ _ _) = Just p
filterUnusedLinks _ = Nothing
filterUsedLinks (UsedOutLink _ _ p a _) = doubleShift p a
filterUsedLinks (UsedInLink _ p a _) = doubleShift p a
filterUsedLinks (UsedOutLink _ _ p a _ _) = doubleShift p a
filterUsedLinks (UsedInLink _ p a _ _) = doubleShift p a
filterUsedLinks _ = []
undir (UsedOutLink _ _ _ a _) = Just $ 0.5*pi + a + snd (_rmShift rm)
undir (UsedInLink _ _ a _) = Just $ 0.5*pi + a + snd (_rmShift rm)
undir (UsedOutLink _ _ _ a _ _) = Just $ 0.5*pi + a + snd (_rmShift rm)
undir (UsedInLink _ _ a _ _) = Just $ 0.5*pi + a + snd (_rmShift rm)
undir _ = Nothing
closePoints x y = roundPoint2 x == roundPoint2 y
getDir (UsedInLink _ _ a _:_) = a + snd (_rmShift rm)
getDir (UsedInLink _ _ a _ _:_) = a + snd (_rmShift rm)
getDir (_:xs) = getDir xs
getDir _ = 0 -- fallback
src/Dodge/LevelGen/Data.hs
+43 -21
View File
@@ -116,39 +116,60 @@ data CardinalPoint
data RoomWire
= --RoomWire Point2 Float
WallWire Point2 Float Float
data RPLinkStatus
= UsedAsOutLink
{ _rplsType :: S.Set RoomLinkType
, _rplsChildNum :: Int
, _rplsOutRoomID :: Int
}
| UsedAsInLink
{ _rplsType :: S.Set RoomLinkType
, _rplsInRoomID :: Int
}
| UnusedAsLink { _rplsType :: S.Set RoomLinkType }
| NotLink
deriving (Eq,Ord,Show)
data RoomPos
= UsedOutLink
{_rpChildNum :: Int
,_rpOutRoomID :: Int
,_rpPos :: Point2
,_rpDir :: Float
,_rpLinkType :: S.Set RoomLinkType
{ _rpChildNum :: Int
, _rpOutRoomID :: Int
, _rpPos :: Point2
, _rpDir :: Float
, _rpLinkType :: S.Set RoomLinkType
, _rpLinkStatus :: RPLinkStatus
}
| UsedInLink
{_rpInRoomID :: Int
,_rpPos :: Point2
,_rpDir :: Float
,_rpLinkType :: S.Set RoomLinkType
{ _rpInRoomID :: Int
, _rpPos :: Point2
, _rpDir :: Float
, _rpLinkType :: S.Set RoomLinkType
, _rpLinkStatus :: RPLinkStatus
}
| UnusedLink
{_rpPos :: Point2
,_rpDir ::Float
,_rpLinkType :: S.Set RoomLinkType
{ _rpPos :: Point2
, _rpDir ::Float
, _rpLinkType :: S.Set RoomLinkType
, _rpLinkStatus :: RPLinkStatus
}
| UsedLink
{_rpPos :: Point2
,_rpDir :: Float
,_rpLinkType :: S.Set RoomLinkType
{ _rpPos :: Point2
, _rpDir :: Float
, _rpLinkType :: S.Set RoomLinkType
, _rpLinkStatus :: RPLinkStatus
}
| UsedSpot
{_rpPos :: Point2
,_rpDir :: Float
,_rpType :: S.Set RoomPosType
{ _rpPos :: Point2
, _rpDir :: Float
, _rpType :: S.Set RoomPosType
, _rpLinkStatus :: RPLinkStatus
}
| UnusedSpot
{_rpPos :: Point2
,_rpDir :: Float
,_rpType :: S.Set RoomPosType
{ _rpPos :: Point2
, _rpDir :: Float
, _rpType :: S.Set RoomPosType
, _rpLinkStatus :: RPLinkStatus
}
deriving (Eq,Ord,Show)
@@ -165,6 +186,7 @@ makeLenses ''Placement
makeLenses ''RoomLink
makeLenses ''RoomPos
makeLenses ''RoomPosType
makeLenses ''RPLinkStatus
spNoID :: PlacementSpot -> PSType -> Placement
spNoID ps pst = Placement ps pst Nothing (const Nothing)
src/Dodge/PlacementSpot.hs
+21 -14
View File
@@ -26,16 +26,16 @@ anyUnusedSpot :: PlacementSpot
anyUnusedSpot = PSPos f (const id) Nothing
where
f rp _ = case rp of
UnusedSpot p a t -> Just (PS p a,UsedSpot p a t)
UnusedSpot p a t rpls -> Just (PS p a,UsedSpot p a t rpls)
_ -> Nothing
unusedSpotAwayFromLink :: Float -> PlacementSpot
unusedSpotAwayFromLink x = PSPos f (const id) Nothing
where
f rp r = case rp of
UnusedSpot p a t
UnusedSpot p a t rpls
| all ( (>x) . dist p ) (usedRoomLinkPoss r)
-> Just (PS p a,UsedSpot p a t)
-> Just (PS p a,UsedSpot p a t rpls)
_ -> Nothing
setFallback :: Placement -> Placement -> Placement
@@ -47,16 +47,17 @@ unusedOffPathAwayFromLink :: Float -> PlacementSpot
unusedOffPathAwayFromLink x = PSPos f (const id) Nothing
where
f rp r = case rp of
UnusedSpot p a t
UnusedSpot p a t rpls
| all ( (>x) . dist p ) (usedRoomLinkPoss r) && RoomPosOffPath `S.member` t
-> Just (PS p a,UsedSpot p a t)
-> Just (PS p a,UsedSpot p a t rpls)
_ -> Nothing
unusedSpotAwayFromInLink :: Float -> PlacementSpot
unusedSpotAwayFromInLink x = PSPos f (const id) Nothing
where
f rp r = case rp of
UnusedSpot p a t | all ( (>x) . dist p ) (usedRoomInLinkPoss r) -> Just (PS p a,UsedSpot p a t)
UnusedSpot p a t rpls
| all ( (>x) . dist p ) (usedRoomInLinkPoss r) -> Just (PS p a,UsedSpot p a t rpls)
_ -> Nothing
twoUnusedLinks :: (PlacementSpot -> PlacementSpot -> Placement)
@@ -82,7 +83,7 @@ useRoomPos cond = PSPos (useRoomPosCond cond) (const id) Nothing
useRoomPosCond :: (RoomPos -> Bool)
-> RoomPos -> Room -> Maybe (PlacementSpot,RoomPos)
useRoomPosCond t rp _
| t rp = Just (PS p a, UsedSpot p a (fromMaybe S.empty $ rp ^? rpType))
| t rp = Just (PS p a, UsedSpot p a (fromMaybe S.empty $ rp ^? rpType) NotLink)
| otherwise = Nothing
where
p = _rpPos rp
@@ -93,6 +94,11 @@ unusedLnkToPS = useRoomPosCond $ \case
UnusedLink {} -> True
_ -> False
usedInLnkToPS :: RoomPos -> Room -> Maybe (PlacementSpot,RoomPos)
usedInLnkToPS = useRoomPosCond $ \case
UsedInLink {} -> True
_ -> False
isUnusedLinkType :: RoomLinkType -> RoomPos -> Bool
isUnusedLinkType rlt rp = case rp of
UnusedLink{_rpLinkType = rlts} -> rlt `S.member` rlts
@@ -102,7 +108,8 @@ unusedSpotNearInLink :: Float -> PlacementSpot
unusedSpotNearInLink x = PSPos f (const id) Nothing
where
f rp r = case rp of
UnusedSpot p a t | any ( (<x) . dist p ) (usedRoomInLinkPoss r) -> Just (PS p a,UsedSpot p a t)
UnusedSpot p a t rpls
| any ( (<x) . dist p ) (usedRoomInLinkPoss r) -> Just (PS p a,UsedSpot p a t rpls)
_ -> Nothing
usedRoomInLinkPoss :: Room -> [Point2]
@@ -124,19 +131,19 @@ usedRoomLinkPoss r = mapMaybe f $ _rmPos r
anyLnkOutPS :: PlacementSpot
anyLnkOutPS = PSPos f (const id) Nothing
where
f (UnusedLink p a _) _ = Just (PS p a, UsedSpot p a S.empty)
f (UnusedLink p a _ rpls) _ = Just (PS p a, UsedSpot p a S.empty rpls)
f _ _ = Nothing
atFstLnkOut :: PlacementSpot
atFstLnkOut = PSPos f (const id) Nothing
where
f (UsedOutLink 0 i p a lt) _ = Just (PS p a, UsedOutLink 0 i p a lt)
f (UsedOutLink 0 i p a lt rpls) _ = Just (PS p a, UsedOutLink 0 i p a lt rpls)
f _ _ = Nothing
atNthLnkOutShiftBy :: Int -> ((Point2,Float) -> (Point2,Float)) -> PlacementSpot
atNthLnkOutShiftBy n theshift = PSPos f (const id) Nothing
where
f (UsedOutLink i rmid p a lt) _ | n == i = Just (PS p' a', UsedOutLink n rmid p a lt)
f (UsedOutLink i rmid p a lt rpls) _ | n == i = Just (PS p' a', UsedOutLink n rmid p a lt rpls)
where
(p',a') = theshift (p,a)
f _ _ = Nothing
@@ -155,14 +162,14 @@ atNthLnkOutShiftInward n x = atNthLnkOutShiftBy n f
overFstLnkOut :: PlacementSpot
overFstLnkOut = PSPos f (const id) Nothing
where
f (UsedOutLink 0 _ p a lt) _ = Just (PS p a, UsedLink p a lt)
f (UsedOutLink 0 _ p a lt rpls) _ = Just (PS p a, UsedLink p a lt rpls)
f _ _ = Nothing
anyLnkInPS :: Float -- ^ amount to shift inward
-> PlacementSpot
anyLnkInPS x = PSPos f (const id) Nothing
where
f (UnusedLink v a _) _ = Just (PS v' a' ,UsedSpot v' a' S.empty)
f (UnusedLink v a _ rpls) _ = Just (PS v' a' ,UsedSpot v' a' S.empty rpls)
where
v' = v -.- x *.* unitVectorAtAngle (a + 0.5 * pi)
a' = a + pi
@@ -170,7 +177,7 @@ anyLnkInPS x = PSPos f (const id) Nothing
useLnkRoomPos :: RoomPos -> Room -> Maybe (PlacementSpot,RoomPos)
useLnkRoomPos rp _ = case rp of
(UnusedLink (V2 x y) a lt) -> Just (PS (V2 x y) a , UsedLink (V2 x y) a lt)
(UnusedLink (V2 x y) a lt rpls) -> Just (PS (V2 x y) a , UsedLink (V2 x y) a lt rpls)
_ -> Nothing
psRandRanges :: (Float,Float) -> (Float,Float) -> (Float,Float) -> State StdGen (Point2,Float)
src/Dodge/Room/LongDoor.hs
+13 -12
View File
@@ -9,6 +9,7 @@ import Dodge.Tree
import Dodge.Default.Room
import Dodge.LevelGen.Data
import Dodge.Placement.Instance
import Dodge.PlacementSpot
import Dodge.Room.Link
import Dodge.Room.Door
import Dodge.Room.Procedural
@@ -92,7 +93,7 @@ southPillarsRoom x y h = do
pillarsc = putBlockRect (x/3-20) (x/3+20) (h/2-20) (h/2+20)
++ putBlockRect (2*x/3-20) (2*x/3+20) (h/2-20) (h/2+20)
pillars <- takeOne [pillarsa, pillarsb, pillarsc]
return $ roomRectAutoLinks x y & rmPmnts .~ pillars
return $ roomRectAutoLinks x y & rmPmnts .~ (pillars ++ [mntLightLnkCond usedInLnkToPS])
addSouthPillars :: RandomGen g => Float -> Float -> Room -> State g Room
addSouthPillars x h r = do
@@ -118,21 +119,21 @@ addButtonSlowDoor x h rm = do
openDoorBound = rectNSEW (h + 5) (h - 5) (-x/2) (3*x/2)
belowH y = (sndV2 . fst) y < h - 40
aboveH y = (sndV2 . fst) y > h + 40
amountedlight dr xoff = Just . moveLSThen (getdoorpos (fromJust $ _plMID dr))
(V3 15 xoff 89) (aShape (V2 15 0) (V3 15 xoff 90)) . const . const
-- TODO make the height of this light source and of other mounted lights
-- be taken from a single consistent source
butDoor _ _ = putLitButOnPos col butPosCond
$ \btid -> Just $ putDoubleDoorThen False col (cond' btid) 30 (V2 0 h) (V2 x h) 2
$ \dr1 dr2 -> Just $ moveLSThen (getdoorpos (fromJust $ _plMID dr1))
(V3 15 50 88) (aShape (V2 15 0) (V3 15 50 90))
$ \_ _ -> Just $ moveLSThen (getdoorpos (fromJust $ _plMID dr2))
(V3 15 (-50) 88) (aShape (V2 15 0) (V3 15 (-50) 90))
$ \_ _ -> Just $ moveLSThen (getdoorpos (fromJust $ _plMID dr2))
(V3 15 50 88) (aShape (V2 15 0) (V3 15 50 90))
$ \_ _ -> Just $ moveLSThen (getdoorpos (fromJust $ _plMID dr1))
(V3 15 (-50) 88) (aShape (V2 15 0) (V3 15 (-50) 90))
$ \_ _ ->Nothing
$ \dr1 dr2 -> amountedlight dr1 50
$ amountedlight dr1 (-50)
$ amountedlight dr2 50
$ amountedlight dr2 (-50)
$ Nothing
getdoorpos drid w = let Just (a,b) = w ^? doors . ix drid . drPos
in (b, argV (a-.-b))
butPosCond (UnusedLink (V2 x' y') a' _) _ | y' < 0.5 * h
= Just (PS (V2 x' y') a' , UsedSpot (V2 x' y') a' (S.singleton RoomPosExLink))
butPosCond (UnusedLink (V2 x' y') a' _ rpls) _ | y' < 0.5 * h
= Just (PS (V2 x' y') a' , UsedSpot (V2 x' y') a' (S.singleton RoomPosExLink) rpls)
butPosCond _ _ = Nothing
--butPosCond _ = True -- y < h
col = dim $ light red
src/Dodge/Room/Procedural.hs
+6 -6
View File
@@ -53,8 +53,8 @@ roomRect x y xn yn = defaultRoom
{ _rmPolys = [rectNSWE y 0 0 x ]
, _rmLinks = lnks
, _rmPath = concatMap doublePair pth
, _rmPos = map (\pd -> UnusedSpot pd 0 $ S.singleton RoomPosOnPath) posps
++ map (\pd -> UnusedSpot pd 0 $ S.singleton RoomPosOffPath) interposps
, _rmPos = map (\pd -> UnusedSpot pd 0 (S.singleton RoomPosOnPath) NotLink) posps
++ map (\pd -> UnusedSpot pd 0 (S.singleton RoomPosOffPath) NotLink) interposps
, _rmPmnts = []
, _rmBound = [rectNSWE (y+5) (-5) (-5) (x+5)]
, _rmFloor = Tiled [Tile
@@ -147,8 +147,8 @@ quarterRoomTri w = do
, sPS (V2 (w-15) (w-25)) pi PutNothing
]
, _rmPos =
[ UnusedSpot (V2 (w-20) (w-20)) pi S.empty
, UnusedSpot (V2 (w-15) (w-25)) pi S.empty
[ UnusedSpot (V2 (w-20) (w-20)) pi S.empty NotLink
, UnusedSpot (V2 (w-15) (w-25)) pi S.empty NotLink
]
, _rmBound = [[V2 0 0,V2 w w,V2 (-w) w]]
}
@@ -188,8 +188,8 @@ quarterRoomSquare w = do
, sPS (V2 20 (2*w-40)) pi PutNothing
, sPS (V2 25 (2*w-45)) pi PutNothing
]
, _rmPos = [UnusedSpot (V2 20 (2*w-40)) pi S.empty
, UnusedSpot (V2 25 (2*w-45)) pi S.empty
, _rmPos = [UnusedSpot (V2 20 (2*w-40)) pi S.empty NotLink
, UnusedSpot (V2 25 (2*w-45)) pi S.empty NotLink
]
, _rmBound = [map toV2 [(w,w),(0,2*w),(-w,w)]]
}
src/Dodge/Room/Room.hs
+2 -1
View File
@@ -83,7 +83,8 @@ glassSwitchBack = do
hgt <- state $ randomR (400,600)
wllen <- state $ randomR (60,wth/2-40)
let hf = hgt/5
con1 cond (UnusedLink (V2 x y) a _) _ | cond y = Just (PS (V2 x y) a , UsedSpot (V2 x y) a $ S.singleton RoomPosExLink)
con1 cond (UnusedLink (V2 x y) a _ rpls) _
| cond y = Just (PS (V2 x y) a , UsedSpot (V2 x y) a (S.singleton RoomPosExLink) rpls)
con1 _ _ _ = Nothing
plmnts =
[ mntLightLnkCond $ con1 (< 0.5 * hgt)
src/Dodge/Tree/Shift.hs
+3
View File
@@ -73,6 +73,7 @@ posRms bounds parenti@(parent,_) ( (numChild,t@(Node childi _) ):its) tseq = do
, _rpPos = fst (lnkPosDir outlnk)
, _rpDir = snd (lnkPosDir outlnk)
, _rpLinkType = _rlType outlnk
, _rpLinkStatus = UsedAsOutLink (_rlType outlnk) numChild (snd childi)
}
& rmChildren .:~ snd childi
shiftedoutlink = shiftLinkBy (_rmShift parent) outlnk
@@ -85,6 +86,7 @@ posRms bounds parenti@(parent,_) ( (numChild,t@(Node childi _) ):its) tseq = do
, _rpPos = fst (lnkPosDir il)
, _rpDir = snd (lnkPosDir il)
, _rpLinkType = _rlType il
, _rpLinkStatus = UsedAsInLink (_rlType il) 0
}
shiftedt = applyToRoot
(first $ updatechild . shiftRoomShiftToLink (lnkPosDir shiftedoutlink) (lnkPosDir il))
@@ -97,6 +99,7 @@ createUnusedLinkPos rm = rm & rmPos .++~ map f (_rmLinks rm)
{ _rpPos = _rlPos rl
, _rpDir = _rlDir rl
, _rpLinkType = _rlType rl
, _rpLinkStatus = UnusedAsLink $ _rlType rl
}
zipCount :: [a] -> [(Int,a)]