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

Unify RoomPos constructors

Browse Source
This commit is contained in:
justin
2022-03-10 18:40:22 +00:00
parent 7b1ac2b682
commit 01c58490fa
8 changed files with 135 additions and 127 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Layout.hs
+16 -10
View File
@@ -215,17 +215,23 @@ gameRoomFromRoom rm = GameRoom
[p +.+ 10 *.* unitVectorAtAngle a
,p -.- 10 *.* unitVectorAtAngle a
]
filterUnusedLinks (UnusedLink p _ _ _) = Just p
filterUnusedLinks _ = Nothing
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 _ = Nothing
filterUnusedLinks rp = case _rpLinkStatus rp of
UnusedLink{} -> Just $ _rpPos rp
_ -> Nothing
filterUsedLinks rp = case _rpLinkStatus rp of
UsedOutLink{} -> doubleShift (_rpPos rp) (_rpDir rp)
UsedInLink{} -> doubleShift (_rpPos rp) (_rpDir rp)
_ -> []
undir rp = case _rpLinkStatus 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 (UsedInLink _ _ a _ _:_) = a + snd (_rmShift rm)
getDir (_:xs) = getDir xs
getDir (rp:xs) = case _rpLinkStatus rp of
UsedInLink {} -> _rpDir rp + snd (_rmShift rm)
_ -> getDir xs
getDir _ = 0 -- fallback
floorsFromRooms :: [Room] -> [(Point3,Point3)]
src/Dodge/LevelGen/Data.hs
+10 -43
View File
@@ -118,59 +118,26 @@ data RoomWire
WallWire Point2 Float Float
data RPLinkStatus
= UsedAsOutLink
= UsedOutLink
{ _rplsType :: S.Set RoomLinkType
, _rplsChildNum :: Int
, _rplsOutRoomID :: Int
}
| UsedAsInLink
| UsedInLink
{ _rplsType :: S.Set RoomLinkType
, _rplsInRoomID :: Int
}
| UnusedAsLink { _rplsType :: S.Set RoomLinkType }
| UnusedLink { _rplsType :: S.Set RoomLinkType }
| NotLink
deriving (Eq,Ord,Show)
data RoomPos
= UsedOutLink
{ _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
, _rpLinkStatus :: RPLinkStatus
}
| UnusedLink
{ _rpPos :: Point2
, _rpDir ::Float
, _rpLinkType :: S.Set RoomLinkType
, _rpLinkStatus :: RPLinkStatus
}
| UsedLink
{ _rpPos :: Point2
, _rpDir :: Float
, _rpLinkType :: S.Set RoomLinkType
, _rpLinkStatus :: RPLinkStatus
}
| UsedSpot
{ _rpPos :: Point2
, _rpDir :: Float
, _rpType :: S.Set RoomPosType
, _rpLinkStatus :: RPLinkStatus
}
| UnusedSpot
{ _rpPos :: Point2
, _rpDir :: Float
, _rpType :: S.Set RoomPosType
, _rpLinkStatus :: RPLinkStatus
}
data RoomPos = RoomPos
{ _rpPos :: Point2
, _rpDir :: Float
, _rpType :: S.Set RoomPosType
, _rpLinkStatus :: RPLinkStatus
, _rpPlacementUse :: Int
}
deriving (Eq,Ord,Show)
data RoomPosType
src/Dodge/PlacementSpot.hs
+75 -43
View File
@@ -25,18 +25,21 @@ randDirPS ps = do
anyUnusedSpot :: PlacementSpot
anyUnusedSpot = PSPos f (const id) Nothing
where
f rp _ = case rp of
UnusedSpot p a t rpls -> Just (PS p a,UsedSpot p a t rpls)
_ -> Nothing
f rp _
| _rpLinkStatus rp == NotLink && _rpPlacementUse rp == 0
= Just $ (PS (_rpPos rp) (_rpDir rp), rp & rpPlacementUse +~ 1)
| otherwise = Nothing
unusedSpotAwayFromLink :: Float -> PlacementSpot
unusedSpotAwayFromLink x = PSPos f (const id) Nothing
where
f rp r = case rp of
UnusedSpot p a t rpls
| all ( (>x) . dist p ) (usedRoomLinkPoss r)
-> Just (PS p a,UsedSpot p a t rpls)
_ -> Nothing
f rp r
| _rpLinkStatus rp == NotLink
&& _rpPlacementUse rp == 0
&& all ( (>x) . dist p ) (usedRoomLinkPoss r)
= Just $ (PS p (_rpDir rp), rp & rpPlacementUse +~ 1)
| otherwise = Nothing
where
p = _rpPos rp
setFallback :: Placement -> Placement -> Placement
setFallback fallback plmnt = plmnt
@@ -46,19 +49,27 @@ setFallback fallback plmnt = plmnt
unusedOffPathAwayFromLink :: Float -> PlacementSpot
unusedOffPathAwayFromLink x = PSPos f (const id) Nothing
where
f rp r = case rp of
UnusedSpot p a t rpls
| all ( (>x) . dist p ) (usedRoomLinkPoss r) && RoomPosOffPath `S.member` t
-> Just (PS p a,UsedSpot p a t rpls)
_ -> Nothing
f rp r
| _rpLinkStatus rp == NotLink
&& _rpPlacementUse rp == 0
&& all ( (>x) . dist p ) (usedRoomLinkPoss r)
&& RoomPosOffPath `S.member` _rpType rp
= Just $ (PS p (_rpDir rp), rp & rpPlacementUse +~ 1)
| otherwise = Nothing
where
p = _rpPos rp
unusedSpotAwayFromInLink :: Float -> PlacementSpot
unusedSpotAwayFromInLink x = PSPos f (const id) Nothing
where
f rp r = case rp of
UnusedSpot p a t rpls
| all ( (>x) . dist p ) (usedRoomInLinkPoss r) -> Just (PS p a,UsedSpot p a t rpls)
_ -> Nothing
f rp r
| _rpLinkStatus rp == NotLink
&& _rpPlacementUse rp == 0
&& all ( (>x) . dist p ) (usedRoomInLinkPoss r)
= Just $ (PS p (_rpDir rp), rp & rpPlacementUse +~ 1)
| otherwise = Nothing
where
p = _rpPos rp
twoUnusedLinks :: (PlacementSpot -> PlacementSpot -> Placement)
-> Placement
@@ -80,73 +91,88 @@ useUnusedLink = PSPos unusedLnkToPS (const id) Nothing
useRoomPos :: (RoomPos -> Bool) -> PlacementSpot
useRoomPos cond = PSPos (useRoomPosCond cond) (const id) Nothing
isUnusedLnk :: RoomPos -> Bool
isUnusedLnk rp = case _rpLinkStatus rp of
UnusedLink {} -> _rpPlacementUse rp == 0
_ -> False
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) NotLink)
| t rp = Just (PS p a, rp & rpPlacementUse +~ 1)
| otherwise = Nothing
where
p = _rpPos rp
a = _rpDir rp
unusedLnkToPS :: RoomPos -> Room -> Maybe (PlacementSpot,RoomPos)
unusedLnkToPS = useRoomPosCond $ \case
unusedLnkToPS = useRoomPosCond $ \rp -> case _rpLinkStatus rp of
UnusedLink {} -> True
_ -> False
usedInLnkToPS :: RoomPos -> Room -> Maybe (PlacementSpot,RoomPos)
usedInLnkToPS = useRoomPosCond $ \case
usedInLnkToPS = useRoomPosCond $ \rp -> case _rpLinkStatus rp of
UsedInLink {} -> True
_ -> False
isUnusedLinkType :: RoomLinkType -> RoomPos -> Bool
isUnusedLinkType rlt rp = case rp of
UnusedLink{_rpLinkType = rlts} -> rlt `S.member` rlts
isUnusedLinkType rlt rp = case _rpLinkStatus rp of
UnusedLink{_rplsType = rlts} -> rlt `S.member` rlts
_ -> False
-- TODO unify this with other xSpotNear/FarLink
unusedSpotNearInLink :: Float -> PlacementSpot
unusedSpotNearInLink x = PSPos f (const id) Nothing
where
f rp r = case rp of
UnusedSpot p a t rpls
| any ( (<x) . dist p ) (usedRoomInLinkPoss r) -> Just (PS p a,UsedSpot p a t rpls)
_ -> Nothing
f rp r
| _rpLinkStatus rp == NotLink
&& _rpPlacementUse rp == 0
&& any ( (<x) . dist p ) (usedRoomInLinkPoss r)
= Just $ (PS p (_rpDir rp), rp & rpPlacementUse +~ 1)
| otherwise = Nothing
where
p = _rpPos rp
usedRoomInLinkPoss :: Room -> [Point2]
usedRoomInLinkPoss r = mapMaybe f $ _rmPos r
where
f rp = case rp of
f rp = case _rpLinkStatus rp of
UsedInLink {} -> Just $ _rpPos rp
_ -> Nothing
usedRoomLinkPoss :: Room -> [Point2]
usedRoomLinkPoss r = mapMaybe f $ _rmPos r
where
f rp = case rp of
f rp = case _rpLinkStatus rp of
UsedInLink {} -> Just $ _rpPos rp
UsedOutLink {} -> Just $ _rpPos rp
_ -> Nothing
-- TODO rename to any unused link facing out
-- note this can REUSE unused links
anyLnkOutPS :: PlacementSpot
anyLnkOutPS = PSPos f (const id) Nothing
where
f (UnusedLink p a _ rpls) _ = Just (PS p a, UsedSpot p a S.empty rpls)
f _ _ = Nothing
f rp _ = case _rpLinkStatus rp of
UnusedLink {} -> Just (PS (_rpPos rp) (_rpDir rp), rp & rpPlacementUse +~ 1)
_ -> Nothing
atFstLnkOut :: PlacementSpot
atFstLnkOut = PSPos f (const id) Nothing
where
f (UsedOutLink 0 i p a lt rpls) _ = Just (PS p a, UsedOutLink 0 i p a lt rpls)
f _ _ = Nothing
f rp _ = case _rpLinkStatus rp of
UsedOutLink {_rplsChildNum = 0} -> Just (PS (_rpPos rp) (_rpDir rp), rp & rpPlacementUse +~ 1)
_ -> Nothing
atNthLnkOutShiftBy :: Int -> ((Point2,Float) -> (Point2,Float)) -> PlacementSpot
atNthLnkOutShiftBy n theshift = PSPos f (const id) Nothing
where
f (UsedOutLink i rmid p a lt rpls) _ | n == i = Just (PS p' a', UsedOutLink n rmid p a lt rpls)
f rp _ = case _rpLinkStatus rp of
UsedOutLink {_rplsChildNum = i} | i == n
-> Just (PS p a, rp & rpPlacementUse +~ 1)
_ -> Nothing
where
(p',a') = theshift (p,a)
f _ _ = Nothing
(p,a) = theshift (_rpPos rp,_rpDir rp)
atFstLnkOutShiftBy :: ((Point2,Float) -> (Point2,Float)) -> PlacementSpot
atFstLnkOutShiftBy = atNthLnkOutShiftBy 0
@@ -159,25 +185,31 @@ atNthLnkOutShiftInward n x = atNthLnkOutShiftBy n f
where
f (p,a) = (p +.+ rotateV a (V2 0 (negate x)),a)
-- does not change the placement use count
overFstLnkOut :: PlacementSpot
overFstLnkOut = PSPos f (const id) Nothing
where
f (UsedOutLink 0 _ p a lt rpls) _ = Just (PS p a, UsedLink p a lt rpls)
f _ _ = Nothing
f rp _ = case _rpLinkStatus rp of
UsedOutLink {_rplsChildNum = 0} -> Just (PS (_rpPos rp) (_rpDir rp), rp)
_ -> Nothing
anyLnkInPS :: Float -- ^ amount to shift inward
-> PlacementSpot
anyLnkInPS x = PSPos f (const id) Nothing
where
f (UnusedLink v a _ rpls) _ = Just (PS v' a' ,UsedSpot v' a' S.empty rpls)
f rp _ = case _rpLinkStatus rp of
UnusedLink {} -> Just (PS v' a', rp & rpPlacementUse +~ 1)
_ -> Nothing
where
v' = v -.- x *.* unitVectorAtAngle (a + 0.5 * pi)
a = _rpDir rp
v' = _rpPos rp -.- x *.* unitVectorAtAngle (a + 0.5 * pi)
a' = a + pi
f _ _ = Nothing
-- this should probably check the placement use, but so should others: should
-- unify these
useLnkRoomPos :: RoomPos -> Room -> Maybe (PlacementSpot,RoomPos)
useLnkRoomPos rp _ = case rp of
(UnusedLink (V2 x y) a lt rpls) -> Just (PS (V2 x y) a , UsedLink (V2 x y) a lt rpls)
useLnkRoomPos rp _ = case _rpLinkStatus rp of
UnusedLink {} -> Just (PS (_rpPos rp) (_rpDir rp) , rp & rpPlacementUse +~ 1)
_ -> Nothing
psRandRanges :: (Float,Float) -> (Float,Float) -> (Float,Float) -> State StdGen (Point2,Float)
src/Dodge/Room/LongDoor.hs
+1 -3
View File
@@ -132,9 +132,7 @@ addButtonSlowDoor x h rm = do
$ Nothing
getdoorpos drid w = let Just (a,b) = w ^? doors . ix drid . drPos
in (b, argV (a-.-b))
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 = useRoomPosCond $ \rp -> isUnusedLnk rp && yV2 (_rpPos rp) < 0.5 * h
--butPosCond _ = True -- y < h
col = dim $ light red
cond' btid w = w ^? buttons . ix btid . btState /= Just BtOff
src/Dodge/Room/Procedural.hs
+8 -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) NotLink) posps
++ map (\pd -> UnusedSpot pd 0 (S.singleton RoomPosOffPath) NotLink) interposps
, _rmPos = map (roomposat RoomPosOnPath) posps
++ map (roomposat RoomPosOffPath) interposps
, _rmPmnts = []
, _rmBound = [rectNSWE (y+5) (-5) (-5) (x+5)]
, _rmFloor = Tiled [Tile
@@ -66,6 +66,7 @@ roomRect x y xn yn = defaultRoom
, _rmRandPSs = [psRandRanges (10,x-10) (10,y-10) (0,2*pi)]
}
where
roomposat onoffpath p = RoomPos p 0 (S.singleton onoffpath) NotLink 0
yd = (y - 40) / fromIntegral yn
xd = (x - 40) / fromIntegral xn
somelnks poffset ps a = zip (map (+.+ poffset) ps) (repeat a)
@@ -147,8 +148,8 @@ quarterRoomTri w = do
, sPS (V2 (w-15) (w-25)) pi PutNothing
]
, _rmPos =
[ UnusedSpot (V2 (w-20) (w-20)) pi S.empty NotLink
, UnusedSpot (V2 (w-15) (w-25)) pi S.empty NotLink
[ RoomPos (V2 (w-20) (w-20)) pi S.empty NotLink 0
, RoomPos (V2 (w-15) (w-25)) pi S.empty NotLink 0
]
, _rmBound = [[V2 0 0,V2 w w,V2 (-w) w]]
}
@@ -188,8 +189,9 @@ 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 NotLink
, UnusedSpot (V2 25 (2*w-45)) pi S.empty NotLink
, _rmPos =
[ RoomPos (V2 20 (2*w-40)) pi S.empty NotLink 0
, RoomPos (V2 25 (2*w-45)) pi S.empty NotLink 0
]
, _rmBound = [map toV2 [(w,w),(0,2*w),(-w,w)]]
}
src/Dodge/Room/Room.hs
+2 -7
View File
@@ -24,7 +24,7 @@ import Tile
import MonadHelp
import LensHelp
import qualified Data.Set as S
--import qualified Data.Set as S
import Control.Monad.State
--import Control.Monad.Loops
import System.Random
@@ -83,13 +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 _ 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)
, mntLightLnkCond $ con1 (> 0.5 * hgt)
,windowLine (V2 (wth-60 ) hf ) (V2 wllen hf )
[ windowLine (V2 (wth-60 ) hf ) (V2 wllen hf )
,windowLine (V2 (wth-wllen) (2*hf)) (V2 60 (2*hf))
,windowLine (V2 (wth-60 ) (3*hf)) (V2 wllen (3*hf))
,windowLine (V2 (wth-wllen) (4*hf)) (V2 60 (4*hf))
src/Dodge/Tree/Shift.hs
+15 -15
View File
@@ -14,7 +14,7 @@ import Padding
import LensHelp hiding (Empty, (<|) , (|>))
--import Control.Lens hiding (Empty, (<|) , (|>))
--import qualified Data.Set as S
import qualified Data.Set as S
import Data.Tree
import Data.Sequence hiding (zipWith)
import Data.List (delete)
@@ -67,13 +67,12 @@ posRms bounds parenti@(parent,_) ( (numChild,t@(Node childi _) ):its) tseq = do
clipping = or (convexPolysOverlap <$> newBounds <*> bounds)
updateparent rm = doLnkEff (lnkPosDir outlnk) $ rm
& rmLinks %~ delete outlnk
& rmPos .:~ UsedOutLink
{ _rpChildNum = numChild
, _rpOutRoomID = snd childi
, _rpPos = fst (lnkPosDir outlnk)
& rmPos .:~ RoomPos
{ _rpPos = fst (lnkPosDir outlnk)
, _rpDir = snd (lnkPosDir outlnk)
, _rpLinkType = _rlType outlnk
, _rpLinkStatus = UsedAsOutLink (_rlType outlnk) numChild (snd childi)
, _rpType = S.empty
, _rpLinkStatus = UsedOutLink (_rlType outlnk) numChild (snd childi)
, _rpPlacementUse = 0
}
& rmChildren .:~ snd childi
shiftedoutlink = shiftLinkBy (_rmShift parent) outlnk
@@ -81,12 +80,12 @@ posRms bounds parenti@(parent,_) ( (numChild,t@(Node childi _) ):its) tseq = do
& rmMParent ?~ snd parenti
& rmMID ?~ snd childi
& rmLinks %~ delete il
& rmPos .:~ UsedInLink
{ _rpInRoomID = 0
, _rpPos = fst (lnkPosDir il)
& rmPos .:~ RoomPos
{ _rpPos = fst (lnkPosDir il)
, _rpDir = snd (lnkPosDir il)
, _rpLinkType = _rlType il
, _rpLinkStatus = UsedAsInLink (_rlType il) 0
, _rpType = S.empty
, _rpLinkStatus = UsedInLink (_rlType il) (snd parenti)
, _rpPlacementUse = 0
}
shiftedt = applyToRoot
(first $ updatechild . shiftRoomShiftToLink (lnkPosDir shiftedoutlink) (lnkPosDir il))
@@ -95,11 +94,12 @@ posRms bounds parenti@(parent,_) ( (numChild,t@(Node childi _) ):its) tseq = do
createUnusedLinkPos :: Room -> Room
createUnusedLinkPos rm = rm & rmPos .++~ map f (_rmLinks rm)
where
f rl = UnusedLink
f rl = RoomPos
{ _rpPos = _rlPos rl
, _rpDir = _rlDir rl
, _rpLinkType = _rlType rl
, _rpLinkStatus = UnusedAsLink $ _rlType rl
, _rpType = S.empty
, _rpLinkStatus = UnusedLink $ _rlType rl
, _rpPlacementUse = 0
}
zipCount :: [a] -> [(Int,a)]
src/Geometry/Vector.hs
+8
View File
@@ -153,3 +153,11 @@ tweenAngles frac a1 a2
| abs (a1' - a2') < pi = frac' * (a1' - a2') + a2'
| a1' > a2' = go frac' (a1' - 2*pi) a2'
| otherwise = go frac' a1' (a2' - 2*pi)
xV2 :: Point2 -> Float
{-# INLINE xV2 #-}
xV2 (V2 x _) = x
yV2 :: Point2 -> Float
{-# INLINE yV2 #-}
yV2 (V2 _ y) = y