diff --git a/src/Dodge/Layout.hs b/src/Dodge/Layout.hs index 2d96708fb..e3e5b8924 100644 --- a/src/Dodge/Layout.hs +++ b/src/Dodge/Layout.hs @@ -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)] diff --git a/src/Dodge/LevelGen/Data.hs b/src/Dodge/LevelGen/Data.hs index ce003eb6f..2d20c08a6 100644 --- a/src/Dodge/LevelGen/Data.hs +++ b/src/Dodge/LevelGen/Data.hs @@ -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 diff --git a/src/Dodge/PlacementSpot.hs b/src/Dodge/PlacementSpot.hs index fbcfd79d6..7457839f4 100644 --- a/src/Dodge/PlacementSpot.hs +++ b/src/Dodge/PlacementSpot.hs @@ -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 ( ( Just (PS p a,UsedSpot p a t rpls) - _ -> Nothing + f rp r + | _rpLinkStatus rp == NotLink + && _rpPlacementUse rp == 0 + && any ( ( [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) diff --git a/src/Dodge/Room/LongDoor.hs b/src/Dodge/Room/LongDoor.hs index eb2d25541..0cabd2e8f 100644 --- a/src/Dodge/Room/LongDoor.hs +++ b/src/Dodge/Room/LongDoor.hs @@ -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 diff --git a/src/Dodge/Room/Procedural.hs b/src/Dodge/Room/Procedural.hs index 58d67d64e..f3ef450bc 100644 --- a/src/Dodge/Room/Procedural.hs +++ b/src/Dodge/Room/Procedural.hs @@ -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)]] } diff --git a/src/Dodge/Room/Room.hs b/src/Dodge/Room/Room.hs index 370fa405f..43d7b1e00 100644 --- a/src/Dodge/Room/Room.hs +++ b/src/Dodge/Room/Room.hs @@ -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)) diff --git a/src/Dodge/Tree/Shift.hs b/src/Dodge/Tree/Shift.hs index 59f400360..0b1a2a9a9 100644 --- a/src/Dodge/Tree/Shift.hs +++ b/src/Dodge/Tree/Shift.hs @@ -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)] diff --git a/src/Geometry/Vector.hs b/src/Geometry/Vector.hs index 2db5a5ae8..41bbe3eab 100644 --- a/src/Geometry/Vector.hs +++ b/src/Geometry/Vector.hs @@ -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