From 28f8ac1fbd9dc36af56e8f245d1f13afb76d0949 Mon Sep 17 00:00:00 2001 From: justin Date: Mon, 8 Nov 2021 11:16:08 +0000 Subject: [PATCH] Add fallback placement for falled link based placement spots --- src/Dodge/Floor.hs | 5 +- src/Dodge/Layout.hs | 40 ++-------------- src/Dodge/LevelGen.hs | 16 +++++-- src/Dodge/LevelGen/Data.hs | 1 + src/Dodge/Placements/Button.hs | 2 +- src/Dodge/Placements/LightSource.hs | 4 +- src/Dodge/Room.hs | 72 +++++++++++++---------------- 7 files changed, 52 insertions(+), 88 deletions(-) diff --git a/src/Dodge/Floor.hs b/src/Dodge/Floor.hs index 92644fa7b..e7585a0bf 100644 --- a/src/Dodge/Floor.hs +++ b/src/Dodge/Floor.hs @@ -35,10 +35,7 @@ initialRoomTree = do t = treeFromTrunk [[StartRoom] ,[Corridor] - ,[AirlockAno] - ,[Corridor] - ,[Corridor] - ,[SpecificRoom $ fmap connectRoom glassSwitchBack] + ,[SpecificRoom $ fmap connectRoom glassSwitchBackCrits] ,[Corridor] ,[SpecificRoom $ return $ connectRoom lasTunnel ] ,[Corridor] diff --git a/src/Dodge/Layout.hs b/src/Dodge/Layout.hs index 2bcabb0f6..b3057a25d 100644 --- a/src/Dodge/Layout.hs +++ b/src/Dodge/Layout.hs @@ -7,8 +7,6 @@ import Dodge.LevelGen.Data import Dodge.LevelGen.StaticWalls import Dodge.LevelGen.Pathing import Dodge.Wall.Zone -import Dodge.Placements.Spot -import Dodge.RandomHelp import Dodge.Zone import Dodge.GameRoom import Dodge.Bounds @@ -28,7 +26,7 @@ import Tile import Polyhedra import Polyhedra.Data -import Data.List (nubBy, partition,mapAccumR) +import Data.List (nubBy) import Control.Monad.State import Control.Lens import System.Random @@ -43,7 +41,8 @@ generateLevelFromRoomList :: State StdGen [Room] -> World -> World generateLevelFromRoomList gr w = initWallZoning . setupWorldBounds - . flip (foldr $ flip placeSpot) plmnts + -- . flip (foldr $ flip placeSpot) plmnts + . flip (foldl' placeSpot) plmnts $ w { _walls = wallsFromRooms rs , _floorTiles = floorsFromRooms rs , _gameRooms = gameRoomsFromRooms rs @@ -54,42 +53,9 @@ generateLevelFromRoomList gr w path = pairsToGraph dist pairPath pairPath = concatMap _rmPath rs plmnts = concatMap (\rm -> map (rm,) (_rmPS rm)) rs - --plmnts = concat . snd $ mapAccumR assignPlacementSpots (_randGen w) rs rs = zipWith addTile zs . evalState gr $ _randGen w zs = map fromIntegral $ randomRs (0,63::Int) $ _randGen w --- the idea is to allow use of link coordinates for placements --- though the implementation is clunky --- this should PutNothing if there are no links available --- first it takes the random placements and derandomises them --- then it deals with link placement spots --- TODO use state monad here -assignPlacementSpots :: StdGen -> Room -> (StdGen, [(Room,Placement)]) -assignPlacementSpots g rm = (g' - , map (rm,) - $ plmnts ++ updatedLnkPlmnts - ) - where - (unrandPlmnts, g'') = runState (mapM (derandPlacement rm) (_rmPS rm)) g - (lnkplmnts, plmnts) = partition islnk unrandPlmnts - islnk Placement{_placementSpot=PSLnk{}} = True - islnk _ = False - (shuffledLnks,g') = runState (shuffle $ _rmLinks rm) g'' - (_,updatedLnkPlmnts) = mapAccumR f (map (invShiftLinkBy $ _rmShift rm) shuffledLnks) lnkplmnts - f lnks plmnt = - let (x:xs,ys) = partition (_psLinkTest $ _placementSpot plmnt) lnks - thepair = _psLinkShift (_placementSpot plmnt) x - in (xs++ys, updatePS (updatePSLnkUsing thepair) plmnt) - --- I do not see an obvious way to push randomn placement spots down into recursive placements --- So these currently only work for the "top" level -derandPlacement :: Room -> Placement -> State StdGen Placement -derandPlacement rm (RandomPlacement x) = derandPlacement rm =<< x -derandPlacement rm (Placement (PSRoomRand i) pstype cont) = do - ps <- _rmRandPSs rm !! i - return (Placement (uncurry PS ps) pstype cont) -derandPlacement _ x = return x - updatePSLnkUsing :: (Point2,Float) -> PlacementSpot -> PlacementSpot updatePSLnkUsing pf PSLnk{_psLinkShift=f} = uncurry PS $ f pf updatePSLnkUsing _ ps = ps diff --git a/src/Dodge/LevelGen.hs b/src/Dodge/LevelGen.hs index 41adbda19..1ad8b2e62 100644 --- a/src/Dodge/LevelGen.hs +++ b/src/Dodge/LevelGen.hs @@ -26,6 +26,8 @@ import Control.Monad.State import Control.Lens import qualified Data.IntSet as IS +-- potential failure cases: randomising using an already set link position +-- others? placeSpot :: World -> (Room , Placement) -> World placeSpot w (rm, plmnt@Placement{_placementSpot=PSRoomRand i}) = let (ps,g) = runState (_rmRandPSs rm !! i) $_randGen w @@ -40,20 +42,24 @@ placeSpot w (rm, plmnt@Placement{}) = placeSpot w (rm, PlacementUsingPos p subpl) = placeSpot w (rm, subpl (shiftPoint3By shift p)) where shift = _rmShift rm --- random placements SHOULD be dealt with already (see assignPlacementSpots) placeSpot w (rm, RandomPlacement rplmnt) = placeSpot (w & randGen .~ g) (rm, plmnt) where (plmnt, g) = runState rplmnt (_randGen w) --- ok, this is unsafe, but whatever +-- this should be woven into placeSpot assignPSToLnk :: Room -> Placement -> World -> World -assignPSToLnk rm plmnt w = placeSpot (w & randGen .~ g) (rm, updatePS (f lnk) plmnt) +assignPSToLnk rm plmnt w = case lnks of + (lnk:_) -> placeSpot (w & randGen .~ g) (rm, updatePS (f lnk) plmnt) + [] -> case fallback of + Nothing -> w + Just plmnt' -> placeSpot w (rm,plmnt') where rps = _placementSpot plmnt + fallback = _psFallback rps test = _psLinkTest rps - (lnk:_,g) = runState (shuffle $ filter test $ map (invShiftLinkBy $ _rmShift rm) $ _rmLinks rm) + (lnks,g) = runState (shuffle $ filter test $ map (invShiftLinkBy $ _rmShift rm) $ _rmLinks rm) $ _randGen w - f x (PSLnk t s) + f x (PSLnk t s _) | t x = uncurry PS $ s x f _ ps = ps invShiftLinkBy :: (Point2,Float) -> (Point2,Float) -> (Point2,Float) diff --git a/src/Dodge/LevelGen/Data.hs b/src/Dodge/LevelGen/Data.hs index 191ca879d..f5bf08fd5 100644 --- a/src/Dodge/LevelGen/Data.hs +++ b/src/Dodge/LevelGen/Data.hs @@ -32,6 +32,7 @@ data PlacementSpot = PS { _psPos :: Point2 , _psRot :: Float } | PSLnk { _psLinkTest :: (Point2,Float) -> Bool , _psLinkShift :: (Point2,Float) -> (Point2,Float) + , _psFallback :: Maybe Placement } | PSRoomRand { _psRoomRandPointNum :: Int } diff --git a/src/Dodge/Placements/Button.hs b/src/Dodge/Placements/Button.hs index 25e45547f..6b0aa386c 100644 --- a/src/Dodge/Placements/Button.hs +++ b/src/Dodge/Placements/Button.hs @@ -30,4 +30,4 @@ putLitButtonID' col f subpl where changeLight lsid = lightSources . ix lsid . lsIntensity .~ V3 0 0.5 0 ls = defaultLS { _lsRad = 75 , _lsIntensity = V3 0.5 0 0 } - thePS = PSLnk f (\(p,a)->(p,a)) + thePS = PSLnk f id Nothing diff --git a/src/Dodge/Placements/LightSource.hs b/src/Dodge/Placements/LightSource.hs index e6a7cb46a..8381bbb37 100644 --- a/src/Dodge/Placements/LightSource.hs +++ b/src/Dodge/Placements/LightSource.hs @@ -95,12 +95,12 @@ mountLightA = redMID mountLightAID mountLightACond :: ((Point2,Float) -> Bool) -> Placement mountLightACond f = updatePSToLevel 2 (const thePS) $ mountLightA 0 (V3 0 (-40) 40) where - thePS = PSLnk f (\(p,a)->(p,a)) + thePS = PSLnk f id Nothing mountLightVCond :: ((Point2,Float) -> Bool) -> Placement mountLightVCond f = updatePSToLevel 2 (const thePS) $ mountLightV 0 (V3 0 (-20) 40) where - thePS = PSLnk f id + thePS = PSLnk f id Nothing mntLight :: Point2 -> Point2 -> Placement mntLight a b = RandomPlacement $ takeOne diff --git a/src/Dodge/Room.hs b/src/Dodge/Room.hs index 910f452e2..130a7d34e 100644 --- a/src/Dodge/Room.hs +++ b/src/Dodge/Room.hs @@ -78,24 +78,6 @@ roomPillars = over rmLinks init $ set rmPS plmnts $ roomRect 240 240 2 2 branchWith :: Room -> [Tree Room] -> Tree (Either Room Room) branchWith r ts = Node (Left r) $ return (Right door) : fmap (fmap Left) ts -glassSwitchBack :: RandomGen g => State g Room -glassSwitchBack = do - wth <- state $ randomR (200,400) - hgt <- state $ randomR (400,600) - wllen <- state $ randomR (60,wth/2-40) - let hf = hgt/5 - let plmnts = - [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)) - ,blockLine (V2 0 (1*hf)) (V2 wllen (1*hf)) - ,blockLine (V2 (wth-wllen) (2*hf)) (V2 wth (2*hf)) - ,blockLine (V2 0 (3*hf)) (V2 wllen (3*hf)) - ,blockLine (V2 (wth-wllen) (4*hf)) (V2 wth (4*hf)) - , sPS (V2 (wth/2) (hgt/2)) 0 putLamp - ] - return $ set rmPS plmnts $ roomRect wth hgt 2 6 manyDoors :: Int -> Tree (Either Room Room) manyDoors i = treeFromPost (replicate i (Left door)) $ Right door @@ -128,33 +110,45 @@ glassLesson = do ] ] -glassSwitchback1 :: RandomGen g => State g Room -glassSwitchback1 = do +glassSwitchBack :: RandomGen g => State g Room +glassSwitchBack = do wth <- state $ randomR (200,400) hgt <- state $ randomR (400,600) wllen <- state $ randomR (60,wth/2-40) let hf = hgt/5 - cry <- randomRanges [--50+2*hf,30+3*hf - 50+3*hf,30+4*hf - ,50+4*hf,30+5*hf - ] - crx <- state $ randomR (wllen,wth-(wllen+40)) - let plmnts = [windowLine (V2 (wth-60) ( 40+hf)) (V2 wllen (40+hf)) - ,windowLine (V2 (wth-wllen) (40+2*hf)) (V2 60 (40+2*hf)) - ,windowLine (V2 (wth-60) ( 40+3*hf)) (V2 wllen (40+3*hf)) - ,windowLine (V2 (wth-wllen) (40+4*hf)) (V2 60 (40+4*hf)) - ,sPS (V2 crx cry) 0 $ PutCrit miniGunCrit - ,sPS (V2 (wth-20) (hgt/2+40)) 0 randC1 - ,sPS (V2 (wth/2) (hgt/2)) 0 putLamp - ,blockLine (V2 0 ( 40+1*hf)) (V2 wllen (40+1*hf)) - ,blockLine (V2 (wth-wllen) ( 40+2*hf)) (V2 wth (40+2*hf)) - ,blockLine (V2 0 ( 40+3*hf)) (V2 wllen (40+3*hf)) - ,blockLine (V2 (wth-wllen) ( 40+4*hf)) (V2 wth (40+4*hf)) - ] - return $ set rmPS plmnts $ shiftRoomBy (V2 0 40,0) $ roomRect wth hgt 2 4 + con1 (V2 _ y,_) = y < 0.5*hgt + plmnts = + [ mntLightLnkCond con1 + , mntLightLnkCond (not . con1) + ,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)) + ,blockLine (V2 0 (1*hf)) (V2 wllen (1*hf)) + ,blockLine (V2 (wth-wllen) (2*hf)) (V2 wth (2*hf)) + ,blockLine (V2 0 (3*hf)) (V2 wllen (3*hf)) + ,blockLine (V2 (wth-wllen) (4*hf)) (V2 wth (4*hf)) + , sPS (V2 (wth/2) (hgt/2)) 0 putLamp + ] + let northPSs = do + cry <- randomRanges [3*hf+10,4*hf-10 + ,4*hf+10,5*hf-10 + ] + crx <- state $ randomR (wllen,wth-(wllen+40)) + return (V2 crx cry,1.5*pi) + midPS = return (V2 (wth-20) (hgt/2+40), pi) + return $ roomRect wth hgt 2 4 + & rmPS .~ plmnts + & rmRandPSs .~ [northPSs,midPS] + +glassSwitchBackCrits :: RandomGen g => State g Room +glassSwitchBackCrits = glassSwitchBack + <&> rmPS %~ ([Placement (PSRoomRand 0) (PutCrit miniGunCrit) (const Nothing) + , Placement (PSRoomRand 1) randC1 (const Nothing) + ] ++) miniTree2 :: RandomGen g => State g (Tree (Either Room Room)) -miniTree2 = glassSwitchback1 +miniTree2 = glassSwitchBackCrits >>= randomiseOutLinks >>= changeLinkTo (\p -> (sndV2 . fst) p < 70) <&> flip branchWith (replicate 3 $ treeFromPost [door,corridor] critInDeadEnd)