From d0e3500cadcfee594acad3405bac433d9f2feacb Mon Sep 17 00:00:00 2001 From: justin Date: Tue, 14 Jun 2022 16:13:06 +0100 Subject: [PATCH] Cleanup --- src/Dodge/Annotation.hs | 2 +- src/Dodge/PlacementSpot.hs | 5 +++++ src/Dodge/Room/Modify/Girder.hs | 24 +++++++++++++++++++++++ src/Dodge/Room/Pillar.hs | 2 ++ src/Dodge/Room/RezBox.hs | 22 ++++++++++++++++++--- src/Dodge/Room/RoadBlock.hs | 7 ++++--- src/Dodge/Room/Room.hs | 34 +++++++++++++++++++-------------- src/Dodge/Room/Start.hs | 33 +++++++++++++++++++------------- src/Dodge/Room/Warning.hs | 5 ++++- src/Dodge/Tree/Compose.hs | 8 ++++++-- src/Dodge/UseAll.hs | 2 +- 11 files changed, 106 insertions(+), 38 deletions(-) diff --git a/src/Dodge/Annotation.hs b/src/Dodge/Annotation.hs index 267b6e0ed..b2dd91884 100644 --- a/src/Dodge/Annotation.hs +++ b/src/Dodge/Annotation.hs @@ -20,7 +20,7 @@ annoToRoomTree an = case an of AnRoom r -> MTree "SingleRoom" . NodeTree . pure . (rmClusterStatus . csLinks . at OnwardCluster ?~ ()) <$> zoom _1 r <*> return [] OnwardList ans -> do mts <- mapM annoToRoomTree ans - return $ foldr1 attachOnward mts + return $ foldr1 attachOnward' mts IntAnno f -> do (g,i) <- get put (g,i+1) diff --git a/src/Dodge/PlacementSpot.hs b/src/Dodge/PlacementSpot.hs index 00af90099..0f78a889c 100644 --- a/src/Dodge/PlacementSpot.hs +++ b/src/Dodge/PlacementSpot.hs @@ -9,6 +9,7 @@ module Dodge.PlacementSpot , unusedSpotAwayFromLink , isUnusedLnk , isInLnk + , isOutLnk , unusedSpotNearInLink , randDirPS , unusedSpotAwayFromInLink @@ -135,6 +136,10 @@ isInLnk :: RoomPos -> Bool isInLnk rp = case _rpLinkStatus rp of UsedInLink {} -> _rpPlacementUse rp == 0 _ -> False +isOutLnk :: RoomPos -> Bool +isOutLnk rp = case _rpLinkStatus rp of + UsedOutLink {} -> _rpPlacementUse rp == 0 + _ -> False useUnusedLnk :: PlacementSpot useUnusedLnk = rprBool isUnusedLnk diff --git a/src/Dodge/Room/Modify/Girder.hs b/src/Dodge/Room/Modify/Girder.hs index 2c2d7aebf..2eae8194b 100644 --- a/src/Dodge/Room/Modify/Girder.hs +++ b/src/Dodge/Room/Modify/Girder.hs @@ -2,6 +2,7 @@ module Dodge.Room.Modify.Girder ( addGirderLights , addGirderFrom , addHighGirder + , addHighGirder' , addGirderEW , addGirderNS , addGirderNS' @@ -88,6 +89,22 @@ addGirder shapef col room = do $ \ps1 ps2 -> sps0 $ PutShape $ colorSH col $ shapef (_psPos ps1) (_psPos ps2) | i <- [1 .. numlnks - 2] ] +addGirder' :: RandomGen g => (Point2 -> Point2 -> Shape) -> Color -> Room -> State g Room +addGirder' shapef col room = do + let nslnks = length $ filter ((OnEdge North `S.member`) . _rlType) $ _rmLinks room + ewlnks = length $ filter ((OnEdge East `S.member`) . _rlType) $ _rmLinks room + nsgirds = girdson (FromEdge East) nslnks + ewgirds = girdson (FromEdge North) ewlnks + girders <- shuffle $ nsgirds ++ ewgirds + return $ room & rmPmnts .:~ foldr1 setFallback + (sps0 PutNothing : girders) + where + girdson f numlnks = [ twoRoomPoss + (isUnusedLnkType (f i)) + (isUnusedLnkType (f i)) + $ \ps1 ps2 -> sps0 $ PutShape $ colorSH col $ shapef (_psPos ps1) (_psPos ps2) + | i <- [0 .. numlnks - 1] ] + addHighGirder :: RandomGen g => Room -> State g Room addHighGirder r = do gsize <- takeOne [(20,10),(30,10),(40,10),(30,15)] @@ -95,6 +112,13 @@ addHighGirder r = do [girder, girderZ, girderV] addGirder hgshape black r +addHighGirder' :: RandomGen g => Room -> State g Room +addHighGirder' r = do + gsize <- takeOne [(20,10),(30,10),(40,10),(30,15)] + hgshape <- takeOne $ map (\f -> uncurry (f 96) gsize) + [girder, girderZ, girderV] + addGirder' hgshape black r + randomLightPositions :: RandomGen g => Room -> State g [(Int,Int)] randomLightPositions rm = do let rmtype = _rmType rm diff --git a/src/Dodge/Room/Pillar.hs b/src/Dodge/Room/Pillar.hs index e7285cc6f..fb85d4b41 100644 --- a/src/Dodge/Room/Pillar.hs +++ b/src/Dodge/Room/Pillar.hs @@ -1,5 +1,6 @@ module Dodge.Room.Pillar where import Dodge.Data +import Dodge.UseAll import Dodge.PlacementSpot import Dodge.Room.Modify.Girder import Dodge.LevelGen.Data @@ -45,6 +46,7 @@ roomPillars pillarsize w h wn hn = do && _rpLinkStatus rp == NotLink ) ) addGirderLights $ rm + & cleatSide & rmPmnts .~ plmnts & rmName .~ "rectPillars" where diff --git a/src/Dodge/Room/RezBox.hs b/src/Dodge/Room/RezBox.hs index b89029ae2..74ab6d847 100644 --- a/src/Dodge/Room/RezBox.hs +++ b/src/Dodge/Room/RezBox.hs @@ -40,6 +40,18 @@ rezBox ls = roomRect 40 60 1 1 & restrictOutLinks (\(V2 _ h,_)-> h > 59) & rmName .~ "rezBox" +rezBox' :: RandomGen g => State g (MetaTree Room String) +rezBox' = do + col <- rezColor + return $ tToBTree "rezBox'" $ treePost + [roomRect 40 60 1 1 + & rmPmnts .~ [ sPS (V2 20 1) 0 $ PutLS col] + & restrictInLinks (\(V2 _ h,_)-> h < 1) + & restrictOutLinks (\(V2 _ h,_)-> h > 59) + & rmName .~ "rezBox" + , cleatOnward door + ] + rezBoxesWp :: RandomGen g => State g (Tree Room) rezBoxesWp = do w <- state $ randomR (100,400) @@ -50,7 +62,7 @@ rezBoxesWp = do let isnorth = S.member (OnEdge North) . _rlType centralRoom <- shuffleLinks $(roomRectAutoLinks w h) {_rmPmnts = []} & rmLinks %~ setLinkType InLink isnorth - onwardpassage <- maybeBlockedPassage + onwardpassage <- shootOutPassage let n = length $ getLinksOfType (OnEdge North) $ _rmLinks centralRoom let rezrooms = map adddoor $ wpAdd theweapon aroom : replicate (n-2) aroom @@ -62,6 +74,10 @@ rezBoxesWp = do maybeBlockedPassage :: RandomGen g => State g (Tree Room) maybeBlockedPassage = fmap (pure . cleatOnward) $ join $ takeOne [return corridor, blockedCorridorCloseBlocks] + +shootOutPassage :: RandomGen g => State g (Tree Room) +shootOutPassage = fmap (pure . cleatOnward) + $ join $ takeOne [ blockedCorridorCloseBlocks] rezBoxesWpCrit :: RandomGen g => State g (Tree Room) rezBoxesWpCrit = do w <- state $ randomR (200,400) @@ -88,7 +104,7 @@ rezBoxesWpCrit = do crAdd :: Room -> Room crAdd = rmPmnts .:~ sPS (V2 20 10) (0.5*pi) randC1 -rezBoxes :: RandomGen g => State g (Tree Room) +rezBoxes :: RandomGen g => State g (MetaTree Room String) rezBoxes = do w <- state $ randomR (100,400) h <- state $ randomR (40,40) @@ -99,7 +115,7 @@ rezBoxes = do centralRoom <- shuffleLinks $ (roomRectAutoLinks w h) {_rmPmnts = []} & rmLinks %~ setInLinks bottomEdgeTest let n = length $ filter bottomEdgeTest $_rmLinks centralRoom - return $ treeFromTrunk [rezBox thecol, door] + return $ tToBTree "rezBoxes" $ treeFromTrunk [rezBox thecol, door] $ Node centralRoom (replicate (n-1) dbox ++ [Node (cleatOnward door) []]) rezColor :: RandomGen g => State g LightSource diff --git a/src/Dodge/Room/RoadBlock.hs b/src/Dodge/Room/RoadBlock.hs index 6fb117ec0..bb20e6bb5 100644 --- a/src/Dodge/Room/RoadBlock.hs +++ b/src/Dodge/Room/RoadBlock.hs @@ -72,16 +72,17 @@ dirtPoly = PutBlock DirtBlock 1 [] dirtWall . reverse blockedCorridorCloseBlocks :: RandomGen g => State g Room blockedCorridorCloseBlocks = do r <- state $ randomR (0,pi) + r' <- state $ randomR (0,pi) theblocks <- takeOne - [ -- [sPS (V2 20 40) r $ dirtPoly $ square 10] + [ [sPS (V2 20 40) r $ dirtPoly $ square 8] --, [ sPS (V2 5 40) r $ dirtPoly $ square 10 -- , sPS (V2 35 40) (r+0.5) $ dirtPoly $ square 10 -- ] --, --[ sPS (V2 5 50) r $ dirtPoly $ square 10 --, sPS (V2 35 35) (r+0.5) $ dirtPoly $ square 10 - [ sPS (V2 6 25) r $ dirtPoly $ square 10 - , sPS (V2 35 20) (r+0.5) $ dirtPoly $ square 10 + , [ sPS (V2 6 25) r $ dirtPoly $ square 8 + , sPS (V2 35 20) r' $ dirtPoly $ square 8 ] ] return $ corridor & rmPmnts .~ theblocks diff --git a/src/Dodge/Room/Room.hs b/src/Dodge/Room/Room.hs index a25bb92fb..4b5ec6d15 100644 --- a/src/Dodge/Room/Room.hs +++ b/src/Dodge/Room/Room.hs @@ -13,7 +13,7 @@ import Dodge.Data import Dodge.PlacementSpot import Dodge.RoomLink import Dodge.Default.Room -import Dodge.Item.Weapon.BulletGuns +import Dodge.Item.Weapon import Dodge.Creature import Dodge.Room.Pillar import Dodge.Room.Girder @@ -118,17 +118,20 @@ roomMiniIntro = do rToOnward "roomMiniIntro" midroom roomCenterPillar :: RandomGen g => State g Room -roomCenterPillar = shuffleLinks . restrictInLinks ((\p -> dist p (V2 120 0) < 10) . fst) - $ set rmPmnts plmnts - $ set rmName "roomCenterPillar" - $ roomRect 240 240 2 2 +roomCenterPillar = do + addHighGirder' =<< (shuffleLinks . restrictInLinks ((\p -> dist p (V2 120 0) < 10) . fst) + $ cleatSide + $ set rmPmnts plmnts + $ set rmName "roomCenterPillar" + $ roomRect 240 240 2 2 + ) where plmnts = [ blockLine (V2 115 115) (V2 115 125) , blockLine (V2 125 115) (V2 125 125) - , mntLightLnkCond useUnusedLnk - , mntLightLnkCond useUnusedLnk +-- , mntLightLnkCond useUnusedLnk , mntLightLnkCond (resetPLUse $ rprBool $ \rp _ -> isInLnk rp) + , mntLightLnkCond (resetPLUse $ rprBool $ \rp _ -> isOutLnk rp) ] {- Probabilites of the type of the first floor weapon. -} @@ -137,6 +140,8 @@ randFirstWeapon = takeOne $ map PutFlIt $ replicate 10 pistol ++ replicate 5 (bangStick 4) ++ replicate 5 (bangCaneX 3) + ++ replicate 5 bangCone + ++ [lasGun] weaponEmptyRoom :: RandomGen g => State g (Tree Room) weaponEmptyRoom = do @@ -151,7 +156,7 @@ weaponEmptyRoom = do f (V2 x y,a) = (a == pi && x > 25 && x < w - 25) || (a /= 0 && y > w - 30) rm <- addHighGirder >=> shuffleLinks $ restrictRMInLinksPD f (roomRect w h 2 2 & rmPmnts .~ plmnts) - return $ treeFromTrunk [ corridor] (pure $ cleatOnward rm ) + return $ treePost [ corridor, cleatSide $ cleatOnward rm ] weaponUnderCrits :: RandomGen g => Int -> State g (MetaTree Room String) weaponUnderCrits i = do @@ -166,7 +171,7 @@ weaponUnderCrits i = do ] rcp <- roomCenterPillar rmpils <- roomPillars 30 240 240 2 2 - deadEndRoom' <- takeOne [ addwpat (V2 120 20) rmpils , addwpat (V2 120 20) rcp] + deadEndRoom' <- takeOne [ addwpat (V2 120 20) rmpils , addwpat (V2 120 20) $ cleatSide rcp] junctionRoom <- takeOne [ tEast, tWest] rToOnward "weaponUnderCrits" $ treeFromTrunk [ corridorN , corridorN] $ Node junctionRoom [continuationRoom ,pure deadEndRoom' ] @@ -177,14 +182,14 @@ weaponBehindPillar = do wpos <- takeOne [V2 120 160,V2 80 40,V2 160 40,V2 220 200,V2 40 200,V2 120 35] cpos <- takeOne $ [V2 x y | x <- [20,220], y <- [20,40]] ++ [V2 120 160,V2 120 200] rcp <- roomCenterPillar - return $ treeFromTrunk + return $ treePost [ corridor , rcp & rmPmnts ++.~ [sPS wpos wpa $ RandPS randFirstWeapon ,sPS cpos (argV $ V2 120 80 -.- cpos) randC1 ] + , cleatOnward $ set rmPmnts [sPS (V2 20 60) (negate $ pi/2) randC1] corridorN ] - (pure . cleatOnward $ set rmPmnts [sPS (V2 20 60) (negate $ pi/2) randC1] corridorN) weaponBetweenPillars :: RandomGen g => State g (Tree Room) weaponBetweenPillars = do @@ -211,12 +216,13 @@ weaponLongCorridor = do connectingRoom <- takeOne [tEast & rmPmnts .~ [spanLightI (V2 (-30) 40) (V2 (-30) 80)] ] i1 <- state $ randomR (2,5) i2 <- state $ randomR (2,5) - let branch1 = treeFromTrunk (replicate i1 corridorN) (pure . cleatOnward $ putCrs connectingRoom) + let branch1 = treeFromTrunk (replicate i1 corridorN) + (pure . cleatSide . cleatOnward $ putCrs connectingRoom) let branch2 = treeFromTrunk (replicate i2 corridorN) (pure . cleatSide $ putWp corridor) return $ Node rt [branch1,branch2] where - putCrs = over rmPmnts (++ [sPS (V2 10 40) (-pi/2) randC1 ,sPS (V2 (-10) 40) (-pi/2) randC1 ]) - putWp = set rmPmnts [sPS (V2 20 60) 0 $ RandPS randFirstWeapon ,spanLightI (V2 0 40) (V2 40 40)] + putCrs = rmPmnts .++~ [sPS (V2 10 40) (-pi/2) randC1 ,sPS (V2 (-10) 40) (-pi/2) randC1 ] + putWp = rmPmnts .~ [sPS (V2 20 60) 0 $ RandPS randFirstWeapon ,spanLightI (V2 0 40) (V2 40 40)] critInDeadEnd :: Room critInDeadEnd = deadEndRoom & rmPmnts .~ [sPS (V2 0 0) 0 randC1] diff --git a/src/Dodge/Room/Start.hs b/src/Dodge/Room/Start.hs index f7ce6557f..f507bfcd2 100644 --- a/src/Dodge/Room/Start.hs +++ b/src/Dodge/Room/Start.hs @@ -1,5 +1,8 @@ {-# LANGUAGE TupleSections #-} -module Dodge.Room.Start where +module Dodge.Room.Start + ( startRoom + , randomChallenges + ) where import Dodge.UseAll import Dodge.Data import Dodge.LevelGen.Data @@ -53,12 +56,13 @@ startRoom i = join (takeOne [-- (,) (0.5::Float) ((chainUses <$> sequence [powerFakeout,fmap fst $weaponRoom i]) -- <&> (,TreeSubLabelling "chainUses <$> sequence [powerFakeout,weaponRoom i]" Nothing)) -- wat --- rezBoxesWp >>= rToOnward "rezBoxesWp" --- , rezBoxThenWeaponRoom i --- , rezBoxesWpCrit >>= rToOnward "rezBoxesWpCrit" - runPastStart i >>= rToOnward ("runPastStart " ++ show i) --- , startCrafts >>= roomsContaining' [] >>= rezBoxThenRooms --- >>= rToOnward "startCrafts >>= roomsContaining [] >>= rezBoxThenRooms" + -- rezBoxesWp >>= rToOnward "rezBoxesWp" + attachOnward "rezBoxThenWeaponRoom" <$> preCritStart <*> weaponRoom i +-- startThenWeaponRoom i +-- rezBoxesWpCrit >>= rToOnward "rezBoxesWpCrit" +-- runPastStart i >>= rToOnward ("runPastStart " ++ show i) +-- startCrafts >>= roomsContaining' [] >>= preCritStart +-- >>= rToOnward "startCrafts >>= roomsContaining [] >>= preCritStart" ]) randomChallenges :: RandomGen g => State g (MetaTree Room String) randomChallenges = shootingRange @@ -84,18 +88,21 @@ rezBoxesThenWeaponRoom :: RandomGen g => Int -> State g (MetaTree Room String) rezBoxesThenWeaponRoom i = do rboxes <- rezBoxes wroom <- weaponRoom i - return $ tToBTree "rboxes" rboxes `attachOnward` wroom + return $ attachOnward "rezBoxesThenWeaponRoom" rboxes wroom -rezBoxThenWeaponRoom :: RandomGen g => Int -> State g (MetaTree Room String) -rezBoxThenWeaponRoom i = do - rcol <- rezColor +preCritStart :: RandomGen g => State g (MetaTree Room String) +preCritStart = join $ takeOne [rezBoxes,rezBox'] + +startThenWeaponRoom :: RandomGen g => Int -> State g (MetaTree Room String) +startThenWeaponRoom i = do + startrm <- preCritStart wroom <- weaponRoom i - return $ tToBTree "rezbox" (treePost [rezBox rcol, cleatOnward door]) `attachOnward` wroom + return $ attachOnward "rezBoxThenWeaponRoom" startrm wroom rezBoxThenRoom :: RandomGen g => Room -> State g (Tree Room) rezBoxThenRoom r = do rcol <- rezColor - return $ treeFromTrunk [ rezBox rcol, door] $ pure r + return $ treeFromTrunk [ rezBox rcol, cleatOnward door] $ pure r rezBoxThenRooms :: RandomGen g => Tree Room -> State g (Tree Room) rezBoxThenRooms r = do diff --git a/src/Dodge/Room/Warning.hs b/src/Dodge/Room/Warning.hs index deb87e54f..965f146db 100644 --- a/src/Dodge/Room/Warning.hs +++ b/src/Dodge/Room/Warning.hs @@ -11,6 +11,7 @@ import Dodge.Tree import Dodge.Room.Door import Dodge.Room.Ngon import Dodge.Room.Procedural +import Dodge.Room.Tanks --import Dodge.Room.Corridor import Dodge.Room.Link --import Dodge.Room.Procedural @@ -39,7 +40,9 @@ import qualified Data.Map.Strict as M warningRooms :: RandomGen g => Int -> State g (MetaTree Room String) warningRooms n = do - rm <- takeOne [roomNgon 8 200, roomRectAutoLinks 200 200] + rm <- do + tr <- tanksRoom [] [] + takeOne [roomNgon 8 200, roomRectAutoLinks 200 200,tr] cenroom <- shuffleLinks $ addWarningTerminal n rm rToOnward "warningRooms" $ treePost [ door, cenroom, triggerDoorRoom n, cleatOnward door] diff --git a/src/Dodge/Tree/Compose.hs b/src/Dodge/Tree/Compose.hs index 477ee5302..5833baa5e 100644 --- a/src/Dodge/Tree/Compose.hs +++ b/src/Dodge/Tree/Compose.hs @@ -13,6 +13,7 @@ module Dodge.Tree.Compose , attachTree , toOnward , attachOnward + , attachOnward' , showIntsString , module Dodge.Tree.Compose.Data ) where @@ -90,8 +91,11 @@ attachBranch mb = safeUpdateSingleNode (isJust . upf . snd) tToBTree :: String -> Tree Room -> MetaTree Room String tToBTree str t = MTree str (NodeTree t) [] -attachOnward :: MetaTree Room b -> MetaTree Room b -> MetaTree Room b -attachOnward t1 t2 = t1 & mtBranches .:~ MBranch toOnward t2 +attachOnward :: b -> MetaTree Room b -> MetaTree Room b -> MetaTree Room b +attachOnward s t1 t2 = MTree s (NodeMTree t1) [MBranch toOnward t2] + +attachOnward' :: MetaTree Room b -> MetaTree Room b -> MetaTree Room b +attachOnward' t1 t2 = MTree (_mtLabel t1) (NodeMTree t1) [MBranch toOnward t2] toOnward :: Room -> Maybe Room toOnward rm diff --git a/src/Dodge/UseAll.hs b/src/Dodge/UseAll.hs index aaf6ad868..7cd789e2e 100644 --- a/src/Dodge/UseAll.hs +++ b/src/Dodge/UseAll.hs @@ -25,7 +25,7 @@ cleatOnward :: Room -> Room cleatOnward = rmClusterStatus . csLinks .~ S.singleton OnwardCluster cleatSide :: Room -> Room -cleatSide = rmClusterStatus . csLinks .~ S.singleton SideCluster +cleatSide = rmClusterStatus . csLinks . at SideCluster ?~ () cleatLabel :: Int -> Room -> Room cleatLabel i = rmClusterStatus . csLinks .~ S.singleton (LabelCluster i)