From 8179a2aa4f23cfac36ea44c59c7b51da38d43259 Mon Sep 17 00:00:00 2001 From: justin Date: Tue, 8 Mar 2022 09:48:45 +0000 Subject: [PATCH] Fix incorrect creation of unused links pos --- src/Dodge/Annotation.hs | 9 +++++---- src/Dodge/LevelGen/Data.hs | 5 +++-- src/Dodge/Placement/Instance/LightSource.hs | 3 ++- src/Dodge/Placement/PlaceSpot.hs | 1 - src/Dodge/Room/Branch.hs | 8 +++++--- src/Dodge/Room/Link.hs | 19 +++++-------------- src/Dodge/Room/Start.hs | 6 +++--- src/Dodge/Tree/Shift.hs | 19 ++++++++++++------- 8 files changed, 35 insertions(+), 35 deletions(-) diff --git a/src/Dodge/Annotation.hs b/src/Dodge/Annotation.hs index a99a5f8d5..3d70dfe9b 100644 --- a/src/Dodge/Annotation.hs +++ b/src/Dodge/Annotation.hs @@ -37,8 +37,9 @@ randomPadCorridors (Node x xs) = do return $ treeFromTrunk (replicate n [Corridor]) (Node x xs') {- | Add a corridor to a random out-link of a room. -} roomThenCorridor :: RandomGen g => Room -> State g (SubCompTree Room) -roomThenCorridor theRoom = fmap (\r -> Node (PassDown theRoom) [(pure . UseAll) r]) - (randomiseOutLinks corridor) +roomThenCorridor theRoom = fmap + (\r -> Node (PassDown theRoom) [(pure . UseAll) r]) + (shuffleLinks corridor) {- | Create a random room tree structure from a list of annotations. -} anoToRoomTree :: RandomGen g => [Annotation g] -> State g (SubCompTree Room) @@ -62,7 +63,7 @@ anoToRoomTree anos = case anos of [OrAno as] -> do a <- takeOne as anoToRoomTree a - [Corridor] -> pure . UseAll <$> randomiseOutLinks corridor + [Corridor] -> pure . UseAll <$> shuffleLinks corridor [AirlockAno] -> airlock >>= roomThenCorridor [FirstWeapon] -> do branchWP <- branchRectWith weaponRoom @@ -77,4 +78,4 @@ anoToRoomTree anos = case anos of _ -> do w <- state $ randomR (100,400) h <- state $ randomR (200,400) - fmap (pure . UseAll) . randomiseOutLinks $ roomRectAutoLinks w h + fmap (pure . UseAll) . shuffleLinks $ roomRectAutoLinks w h diff --git a/src/Dodge/LevelGen/Data.hs b/src/Dodge/LevelGen/Data.hs index 063ba78ed..c5eec08fb 100644 --- a/src/Dodge/LevelGen/Data.hs +++ b/src/Dodge/LevelGen/Data.hs @@ -50,7 +50,7 @@ data PlacementSpot , _psRandShift :: (Point2,Float) -> PlacementSpot } data Placement - = Placement + = Placement { _plSpot :: PlacementSpot , _plType :: PSType , _plMID :: Maybe Int @@ -207,7 +207,8 @@ psj ps pst plmnt = Placement ps pst Nothing (const $ Just plmnt) -- the NoShiftCont is necessary when shifting then combining rooms ps0jPushPS :: PSType -> Placement -> Placement -ps0jPushPS pst plmnt = Placement (PSNoShiftCont (V2 0 0) 0) pst Nothing (\p -> Just $ plmnt & plSpot .~ _plSpot p) +ps0jPushPS pst plmnt = Placement (PSNoShiftCont (V2 0 0) 0) pst Nothing + $ \p -> Just $ plmnt & plSpot .~ _plSpot p addPlmnt :: Placement -> Placement -> Placement addPlmnt pl pl2 = case pl2 of diff --git a/src/Dodge/Placement/Instance/LightSource.hs b/src/Dodge/Placement/Instance/LightSource.hs index fcab8bb85..4faff2ad4 100644 --- a/src/Dodge/Placement/Instance/LightSource.hs +++ b/src/Dodge/Placement/Instance/LightSource.hs @@ -21,7 +21,6 @@ mntLSOn -> LightSource -> Point2 -> Point3 -> (Placement -> Maybe Placement) -> Placement mntLSOn shapeF mcol ls wallp lsp@(V3 lx ly _) = ps0jPushPS (PutShape . setCol $ shapeF wallp lsp) - -- = ps0j (PutShape . setCol $ shapeF wallp lsp) . pt0 (PutLS $ ls & lsParam . lsPos .~ lsp') where lsp' = lsp -.-.- V3 x y 1 @@ -111,6 +110,8 @@ mntLightLnkCond f = RandomPlacement $ do unusedLnkToPS :: RoomPos -> Room -> Maybe (PlacementSpot,RoomPos) unusedLnkToPS rp _ = case rp of UnusedLink p a -> Just (PS p a,UsedSpot p a) +-- UsedInLink _ p a -> Just (PS p a,UsedSpot p a) +-- UsedOutLink _ _ p a -> Just (PS p a,UsedSpot p a) _ -> Nothing spanLSLightI :: LightSource -> Float -> Point2 -> Point2 -> Placement diff --git a/src/Dodge/Placement/PlaceSpot.hs b/src/Dodge/Placement/PlaceSpot.hs index 5d9569f8b..6676b4203 100644 --- a/src/Dodge/Placement/PlaceSpot.hs +++ b/src/Dodge/Placement/PlaceSpot.hs @@ -54,7 +54,6 @@ placePlainPSSpot :: GenWorld -> Room -> Placement -> DPoint2 -> ((GenWorld,Room) placePlainPSSpot w rm plmnt shift = let (i,w') = placeSpotID (shiftPSBy shift (_plSpot plmnt)) (_plType plmnt) w newplmnt = plmnt & plMID ?~ i - --in maybe ((w',rm),[newplmnt]) (recrPlace newplmnt w') (_plIDCont plmnt newplmnt) in maybe ((w',rm),[newplmnt]) (recrPlace newplmnt w') (_plIDCont plmnt newplmnt) where recrPlace newplmnt w' pl = let (wr,newplmnts) = placeSpot (w',rm) pl diff --git a/src/Dodge/Room/Branch.hs b/src/Dodge/Room/Branch.hs index bbece0614..a5ac30528 100644 --- a/src/Dodge/Room/Branch.hs +++ b/src/Dodge/Room/Branch.hs @@ -20,6 +20,8 @@ branchRectWith t = do x <- state $ randomR (100,200) y <- state $ randomR (100,200) b <- t - root <- randomiseOutLinks $ roomRectAutoLinks x y - return $ Node (PassDown root) [Node (UseAll door) [], changeToPassDown <$> - treeFromTrunk [PassDown door] b] + root <- shuffleLinks $ roomRectAutoLinks x y + return $ Node (PassDown root) + [ Node (UseAll door) [] + , changeToPassDown <$> treeFromTrunk [PassDown door] b + ] diff --git a/src/Dodge/Room/Link.hs b/src/Dodge/Room/Link.hs index 9f967b573..ee1f3d6c8 100644 --- a/src/Dodge/Room/Link.hs +++ b/src/Dodge/Room/Link.hs @@ -14,7 +14,6 @@ module Dodge.Room.Link , randomiseAllLinks , shuffleLinks , filterLinks - , randomiseOutLinks , chooseOneInLink , restrictRMInLinksPD ) where @@ -47,13 +46,6 @@ restrictToFstInLink = rmLinks %~ f | otherwise = rl : f xs f [] = [] -{- Shuffle the initial links of a room randomly. -} -randomiseOutLinks :: RandomGen g => Room -> State g Room -randomiseOutLinks r = do - let (outs,xs) = partition (S.member OutLink . _rlType) $ _rmLinks r - newLinks <- shuffle outs - return $ r {_rmLinks = newLinks ++ xs } - sortOutLinksOn :: Ord b => ((Point2,Float) -> b) -> Room -> Room sortOutLinksOn f = overLnkType OutLink $ sortOn (f . lnkPosDir) @@ -95,8 +87,8 @@ shiftRoomBy shift r = r & rmShift %~ shiftPosDirBy shift & rmFloor . tiles %~ map ( (tilePoly %~ map (shiftPointBy shift)) - . (tileZero %~ shiftPointBy shift ) - . (tileX %~ shiftPointBy shift ) + . (tileZero %~ shiftPointBy shift ) + . (tileX %~ shiftPointBy shift ) ) & rmViewpoints %~ map (shiftPointBy shift) @@ -109,8 +101,8 @@ moveRoomBy shift r = r & rmPmnts %~ map (shiftPlacement shift) & rmFloor . tiles %~ map ( (tilePoly %~ map (shiftPointBy shift)) - . (tileZero %~ shiftPointBy shift ) - . (tileX %~ shiftPointBy shift ) + . (tileZero %~ shiftPointBy shift ) + . (tileX %~ shiftPointBy shift ) ) & rmViewpoints %~ map (shiftPointBy shift) @@ -124,8 +116,7 @@ shiftRoomShiftToLink l inlink r (p,a) = inlink -- NOTE placements, when placed, will be shifted by the value _rmShift shiftRoomShiftBy :: (Point2,Float) -> Room -> Room -shiftRoomShiftBy shift r = r - & rmShift %~ shiftPosDirBy shift +shiftRoomShiftBy shift = rmShift %~ shiftPosDirBy shift shiftPosDirBy :: (Point2,Float) -> (Point2,Float) -> (Point2,Float) shiftPosDirBy (pos,rot) (p,r) = (shiftPointBy (pos,rot) p, r + rot) diff --git a/src/Dodge/Room/Start.hs b/src/Dodge/Room/Start.hs index cbbacb625..f8bb49177 100644 --- a/src/Dodge/Room/Start.hs +++ b/src/Dodge/Room/Start.hs @@ -25,7 +25,7 @@ import Dodge.Item.Weapon.Utility import Geometry --import Padding import Color ---import Shape +import Shape import LensHelp --import Data.Maybe @@ -96,11 +96,11 @@ startRoom' = do h <- state $ randomR (200,400) let plmnts = [ sPS (V2 0 0) 0 $ PutShape $ girderV 40 20 10 (V2 0 (h/2)) (V2 w (h/2)) - --, mntLS jShape (V2 0 (h/3)) (V3 40 (h/3) 70) +-- , mntLS jShape (V2 0 (h/3)) (V3 40 (h/3) 70) , tankSquareEmboss4 (dim orange) 50 (h-60) , tankSquare (dim orange) 50 50 , tankSquare (dim orange) 50 120 - --, sps0 $ PutShape $ colorSH orange $ pipePP 2 (V3 50 50 25) (V3 50 120 25) + , sps0 $ PutShape $ colorSH orange $ pipePP 2 (V3 50 50 25) (V3 50 120 25) ] thecol <- rezColor treeFromPost [PassDown $ rezBox thecol, PassDown door] . UseAll diff --git a/src/Dodge/Tree/Shift.hs b/src/Dodge/Tree/Shift.hs index 7a940f132..b7f438fbd 100644 --- a/src/Dodge/Tree/Shift.hs +++ b/src/Dodge/Tree/Shift.hs @@ -24,7 +24,8 @@ type RoomInt = (Room,Int) positionRoomsFromTree :: Tree RoomInt -> IO (Maybe [RoomInt]) positionRoomsFromTree (Node (r,i) ts) = printHeader - >> posRms (map pointsToPoly $ _rmBound r') (r',i) (zipCount ts) Empty + >> (fmap (fmap (map $ first createUnusedLinkPos))) + (posRms (map pointsToPoly $ _rmBound r') (r',i) (zipCount ts) Empty) where r' = r & rmMID ?~ 0 @@ -41,7 +42,7 @@ posRms bounds parenti@(parent,_) ( (numChild,t@(Node childi _) ):its) tseq = do tryParentLinks outlinks where child = fst childi - outlinks = zipCount + outlinks = zipCount . Prelude.filter (not . S.null . S.intersection (_rmConnectsTo child) . _rlType) $ _rmLinks parent tryParentLinks [] = putStrLn "no viable link pairs, backtrack" >> return Nothing @@ -62,19 +63,23 @@ posRms bounds parenti@(parent,_) ( (numChild,t@(Node childi _) ):its) tseq = do newBounds = map pointsToPoly . _rmBound . doRoomShift . fst $ rootLabel shiftedt clipping = or (convexPolysOverlap <$> newBounds <*> bounds) updateparent rm = doLnkEff (lnkPosDir outlnk) $ rm - & rmLinks %~ delete outlnk - & rmPos .:~ uncurry (UsedOutLink numChild (snd childi)) (lnkPosDir outlnk) + & rmLinks %~ delete outlnk + & rmPos .:~ uncurry (UsedOutLink numChild (snd childi)) (lnkPosDir outlnk) & rmChildren .:~ snd childi shiftedoutlink = shiftLinkBy (_rmShift parent) outlnk updatechild rm = rm & rmMParent ?~ snd parenti & rmMID ?~ snd childi - & rmLinks %~ delete il - & rmPos %~ ( (uncurry (UsedInLink 0) (lnkPosDir il):) - . (map (uncurry UnusedLink . lnkPosDir) (delete il (_rmLinks rm)) ++) ) + & rmLinks %~ delete il + & rmPos %~ ( (uncurry (UsedInLink 0) (lnkPosDir il):) +-- . (map (uncurry UnusedLink . lnkPosDir) (delete il (_rmLinks rm)) ++) + ) shiftedt = applyToRoot (first $ updatechild . shiftRoomShiftToLink (lnkPosDir shiftedoutlink) (lnkPosDir il)) t +createUnusedLinkPos :: Room -> Room +createUnusedLinkPos rm = rm & rmPos .++~ map (uncurry UnusedLink . lnkPosDir) (_rmLinks rm) + zipCount :: [a] -> [(Int,a)] zipCount = Prelude.zip [0..]