From da302aad0c23c63a90b478849c5f39bfcaadf543 Mon Sep 17 00:00:00 2001 From: justin Date: Fri, 20 May 2022 21:15:44 +0100 Subject: [PATCH] Add log when generating layout --- src/Dodge/Annotation.hs | 31 +++++++++------- src/Dodge/Annotation/Data.hs | 9 +++-- src/Dodge/Floor.hs | 17 +++++---- src/Dodge/LevelGen.hs | 10 +++++- src/Dodge/LockAndKey.hs | 11 +++--- src/Dodge/Room/Containing.hs | 5 +-- src/Dodge/Room/Corridor.hs | 3 ++ src/Dodge/Room/GlassLesson.hs | 5 +-- src/Dodge/Room/LasTurret.hs | 25 +++++++------ src/Dodge/Room/LongDoor.hs | 8 ++--- src/Dodge/Room/LongRoom.hs | 6 ++-- src/Dodge/Room/Room.hs | 65 ++++++++++++++++++++++------------ src/Dodge/Room/SensorDoor.hs | 7 ++-- src/Dodge/Room/Start.hs | 38 ++++++++++---------- src/Dodge/Tree/Compose.hs | 2 +- src/Dodge/Tree/Compose/Data.hs | 7 ++++ 16 files changed, 155 insertions(+), 94 deletions(-) diff --git a/src/Dodge/Annotation.hs b/src/Dodge/Annotation.hs index e55cdb7e6..3d0838944 100644 --- a/src/Dodge/Annotation.hs +++ b/src/Dodge/Annotation.hs @@ -37,8 +37,9 @@ padSucWithDoors (Node x xs) = Node x (map (padWithAno [SpecificRoom thetree]) xs thetree = do thecor <- shuffleLinks corridor takeOne - [ return (UseAll door) - , treeFromPost [PassDown door, PassDown thecor] (UseAll door) + [ (return (UseAll door),TreeSubLabelling "door" Nothing) + , (treeFromPost [PassDown door, PassDown thecor] (UseAll door) + ,TreeSubLabelling "twoDoors" Nothing) ] {- Add one to three corridors between each parent-child link of a tree of annotations. -} @@ -54,30 +55,34 @@ roomThenCorridor theRoom = fmap (shuffleLinks corridor) {- | Create a random room tree structure from a list of annotations. -} -anoToRoomTree :: [Annotation] -> State StdGen (SubCompTree Room,String) +anoToRoomTree :: [Annotation] -> State StdGen (LabSubCompTree Room) anoToRoomTree anos = case anos of [AnoApplyInt i f] -> f i - [AnoApplyInt' i f str] -> f i <&> (,str) - _ -> fmap (,"") $ anoToRoomTree' anos +-- [AnoApplyInt' i f str] -> f i <&> (,TreeSubLabelling str Nothing) + (SpecificRoom rt:_) -> rt + [PassthroughLockKeyLists i ls ks] -> do + (functionlockroom,randomitemidentity) <- takeOne ls + lr' <- functionlockroom i + ii <- randomitemidentity + let lr = fst lr' + keyroom' <- fromJust $ lookup ii ks + let keyroom = fst keyroom' + (return $ overwriteLabel 0 UseNone lr [keyroom] + ) <&> (,TreeSubLabelling ("PassthroughLockKeyLists-"++show ii) + (Just $ treeFromPost [snd lr'] (snd keyroom')) + ) + _ -> (,TreeSubLabelling "" Nothing) <$> anoToRoomTree' anos {- | Create a random room tree structure from a list of annotations. -} anoToRoomTree' :: [Annotation] -> State StdGen (SubCompTree Room) anoToRoomTree' anos = case anos of --- [AnoApplyInt i f] -> f i [ChainAnos ass] -> do rms <- mapM anoToRoomTree' ass return $ chainUses rms - [PassthroughLockKeyLists i ls ks] -> do - (functionlockroom,randomitemidentity) <- takeOne ls - lr <- functionlockroom i - ii <- randomitemidentity - keyroom <- fromJust $ lookup ii ks - return $ overwriteLabel 0 UseNone lr [keyroom] [OrAno as] -> do a <- takeOne as anoToRoomTree' a [Corridor] -> pure . UseAll <$> shuffleLinks corridor - (SpecificRoom rt:_) -> rt (BossAno cr : _) -> do br <- bossRoom cr branchRectWith . pure . fmap PassDown $ treeFromPost [corridor,corridor] br diff --git a/src/Dodge/Annotation/Data.hs b/src/Dodge/Annotation/Data.hs index 24aecfcf4..17ca73aeb 100644 --- a/src/Dodge/Annotation/Data.hs +++ b/src/Dodge/Annotation/Data.hs @@ -14,15 +14,14 @@ data Annotation | Corridor | AirlockAno | OrAno [[Annotation]] - | SpecificRoom (State StdGen (SubCompTree Room)) + | SpecificRoom (State StdGen (LabSubCompTree Room)) | BossAno Creature | TreasureAno [Creature] [Item] - | AnoApplyInt Int (Int -> State StdGen (SubCompTree Room,String)) - | AnoApplyInt' Int (Int -> State StdGen (SubCompTree Room)) String + | AnoApplyInt Int (Int -> State StdGen (LabSubCompTree Room)) | AnoNewInt (Int -> State StdGen (SubCompTree Room)) | PassthroughLockKeyLists Int - [(Int -> State StdGen (SubCompTree Room), State StdGen CombineType)] - [(CombineType, State StdGen (SubCompTree Room))] + [(Int -> State StdGen (LabSubCompTree Room), State StdGen CombineType)] + [(CombineType, State StdGen (LabSubCompTree Room))] -- | SetLabel Int (State g Room) -- | UseLabel Int (State g Room) | ChainAnos [[Annotation]] diff --git a/src/Dodge/Floor.hs b/src/Dodge/Floor.hs index 4a76e443d..9c618c0e6 100644 --- a/src/Dodge/Floor.hs +++ b/src/Dodge/Floor.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE TupleSections #-} --{-# OPTIONS_GHC -Wno-unused-imports #-} {- | The tree of rooms that make up a level. -} module Dodge.Floor @@ -38,16 +39,18 @@ import System.Random initialAnoTree :: Tree [Annotation] initialAnoTree = padSucWithDoors $ treeFromTrunk [[AnoApplyInt 0 startRoom] - , [SpecificRoom $ return . return . UseAll $ roomRectAutoLinks 400 400 + , [SpecificRoom $ return (return . UseAll $ roomRectAutoLinks 400 400 & rmPmnts .++~ [spNoID anyUnusedSpot (PutCrit chaseCrit) , spNoID anyUnusedSpot (PutCrit armourChaseCrit) ] + , TreeSubLabelling "chaseCrit+armourChaseCrit rectRoom" Nothing) ] -- , [AnoApplyInt 100 healthTest] - , [SpecificRoom $ return . UseAll <$> tanksRoom [] []] + , [SpecificRoom ((return . UseAll <$> tanksRoom [] []) + <&> (, TreeSubLabelling "empty tanksRoom" Nothing))] , [PassthroughLockKeyLists 2 lockRoomKeyItems itemRooms] , [SpecificRoom randomChallenges] - , [AnoApplyInt' 1 lasSensorTurretTest "lasSensorTurretTest"] + , [AnoApplyInt 1 lasSensorTurretTest] -- ,[SpecificRoom $ fmap singleUseAll roomCCrits] -- ,[AirlockAno] -- ,[Corridor] @@ -88,11 +91,13 @@ initialAnoTree = padSucWithDoors $ treeFromTrunk -- ,[Corridor] -- ,[TreasureAno [addArmour autoCrit,addArmour autoCrit] [launcher]] ] - $ treeFromPost [[Corridor,SpecificRoom $ pure . UseAll <$> randomFourCornerRoom []]] - [SpecificRoom $ fmap (pure . UseAll) (telRoomLev 1)] + $ treeFromPost [[Corridor,SpecificRoom $ (pure . UseAll <$> randomFourCornerRoom []) + <&>(,TreeSubLabelling "randomFourCornerRoom" Nothing )]] + [SpecificRoom $ (fmap (pure . UseAll) (telRoomLev 1)) + <&> (,TreeSubLabelling "telRoomLev" Nothing)] {- | A test level tree. -} -initialRoomTree :: State StdGen (Tree (SubCompTree Room,String)) +initialRoomTree :: State StdGen (Tree (LabSubCompTree Room)) initialRoomTree = mapM anoToRoomTree initialAnoTree --initialRoomTree :: State StdGen (Tree Room) --initialRoomTree = do diff --git a/src/Dodge/LevelGen.hs b/src/Dodge/LevelGen.hs index f1b998657..4868e4187 100644 --- a/src/Dodge/LevelGen.hs +++ b/src/Dodge/LevelGen.hs @@ -34,7 +34,7 @@ layoutLevelFromSeed i seed = do let g = mkStdGen seed let treecluster = evalState initialRoomTree g putStrLn "Room cluster layout:" - putStrLn $ drawTree $ fmap snd treecluster + putStrLn $ drawTreeSubLabelling $ fmap snd treecluster let rmtree = inorderNumberTree $ expandTree $ fmap fst treecluster putStrLn "Room layout (compact): " putStrLn $ compactDrawTree $ fmap (show . snd) rmtree @@ -55,6 +55,14 @@ layoutLevelFromSeed i seed = do let (seed',_) = random g layoutLevelFromSeed i' seed' +drawTreeSubLabelling :: Tree TreeSubLabelling -> String +drawTreeSubLabelling t = drawTree (fmap _topLabel t) + ++ concat + (map f $ flatten t) + where + f (TreeSubLabelling _ Nothing) = "" + f (TreeSubLabelling l (Just t')) = l ++ ":\n" ++ drawTreeSubLabelling t' + reversePair :: (a,b) -> (b,a) reversePair (a,b) = (b,a) diff --git a/src/Dodge/LockAndKey.hs b/src/Dodge/LockAndKey.hs index 56732c547..7c42558f2 100644 --- a/src/Dodge/LockAndKey.hs +++ b/src/Dodge/LockAndKey.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE TupleSections #-} module Dodge.LockAndKey where import Dodge.Data import Dodge.Tree @@ -8,6 +9,7 @@ import Dodge.Creature import Dodge.Item.Craftable import Dodge.Item.Weapon.BulletGun.Rod import Dodge.Item +import LensHelp --import Dodge.Item.Equipment import System.Random @@ -18,7 +20,7 @@ bossKeyItems = [(return . UseAll <$> bossRoom autoCrit, takeOne [PISTOL]) ] -lockRoomKeyItems :: RandomGen g => [ (Int -> State g (SubCompTree Room) , State g CombineType ) ] +lockRoomKeyItems :: RandomGen g => [ (Int -> State g (LabSubCompTree Room) , State g CombineType ) ] lockRoomKeyItems = [(lasCenSensEdge, takeOne [LAUNCHER,LASGUN,SPARKGUN,FLATSHIELD] ) ,(sensorRoomRunPast Electrical, takeOne [STATICMODULE,SPARKGUN] ) @@ -31,7 +33,7 @@ lockRoomKeyItems = ,(keyCardRoomRunPast 0, return (KEYCARD 0)) ] -itemRooms :: RandomGen g => [(CombineType, State g (SubCompTree Room))] +itemRooms :: RandomGen g => [(CombineType, State g (LabSubCompTree Room))] itemRooms = [ (LAUNCHER , join $ takeOne [corridorBoss launcherCrit @@ -95,9 +97,10 @@ someCrits = do -- return $ roomsContaining crits its -corridorBoss :: RandomGen g => Creature -> State g (SubCompTree Room) +corridorBoss :: RandomGen g => Creature -> State g (LabSubCompTree Room) corridorBoss cr = do endroom <- bossRoom cr - return $ treeFromPost (replicate 5 $ PassDown corridor) + (return $ treeFromPost (replicate 5 $ PassDown corridor) (PassDown endroom) + ) <&> (,TreeSubLabelling "corridorBoss" Nothing) diff --git a/src/Dodge/Room/Containing.hs b/src/Dodge/Room/Containing.hs index e941d70d7..cbcb0c6ab 100644 --- a/src/Dodge/Room/Containing.hs +++ b/src/Dodge/Room/Containing.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE TupleSections #-} module Dodge.Room.Containing where import Dodge.Data import Dodge.Tree @@ -14,13 +15,13 @@ import Geometry import System.Random import Control.Monad.State -roomsContaining :: RandomGen g => [Creature] -> [Item] -> State g (SubCompTree Room) +roomsContaining :: RandomGen g => [Creature] -> [Item] -> State g (LabSubCompTree Room) roomsContaining crs its = do endroom <- join $ takeOne [ randomFourCornerRoomCrsIts crs its , tanksRoom crs its ] - return $ treeFromPost [] $ UseAll endroom + (return $ treeFromPost [] $ UseAll endroom) <&> (,TreeSubLabelling "roomsContaining" Nothing) pedestalRoom :: RandomGen g => Item -> State g Room pedestalRoom it = do diff --git a/src/Dodge/Room/Corridor.hs b/src/Dodge/Room/Corridor.hs index a37fc8a2e..9cc78e33a 100644 --- a/src/Dodge/Room/Corridor.hs +++ b/src/Dodge/Room/Corridor.hs @@ -59,6 +59,7 @@ corridorN = defaultRoom , _rmPath = pth , _rmPmnts = [] , _rmBound = [ rectNSWE 50 30 0 40 ] + , _rmName = "corridorN" } where lnks = [uncurry outLink (V2 20 70 ,0) ,uncurry inLink (V2 20 10 ,pi) @@ -88,6 +89,7 @@ tEast = defaultRoom , _rmPath = concatMap (doublePair . (,) (V2 0 60) . fst) lnks , _rmPmnts = [] , _rmBound = [ rectNSWE 70 10 0 40 ] + , _rmName = "tEast" } where lnks = @@ -109,6 +111,7 @@ tWest = defaultRoom , _rmPath = concatMap (doublePair . (V2 0 60 ,) . _rlPos) lnks , _rmPmnts = [] , _rmBound = [ rectNSWE 70 10 0 40 ] + , _rmName = "tWest" } where lnks = diff --git a/src/Dodge/Room/GlassLesson.hs b/src/Dodge/Room/GlassLesson.hs index 9aaa94b24..e0eec964b 100644 --- a/src/Dodge/Room/GlassLesson.hs +++ b/src/Dodge/Room/GlassLesson.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE TupleSections #-} module Dodge.Room.GlassLesson where import Dodge.RoomLink import Dodge.Creature @@ -54,7 +55,7 @@ glassLesson = do , mntLS vShape (V2 180 200) (V3 160 180 50) ] ] -glassLessonRunPast :: RandomGen g => State g (SubCompTree Room) -glassLessonRunPast = f <$> glassLesson +glassLessonRunPast :: RandomGen g => State g (LabSubCompTree Room) +glassLessonRunPast = (f <$> glassLesson) <&> (,TreeSubLabelling "glassLessonRunPast" Nothing) where f (Node r rs) = Node r $ return (UseLabel 0 $ door & rmConnectsTo .~ S.member (OnEdge West)) : rs diff --git a/src/Dodge/Room/LasTurret.hs b/src/Dodge/Room/LasTurret.hs index afd67ab34..41e8bd1a1 100644 --- a/src/Dodge/Room/LasTurret.hs +++ b/src/Dodge/Room/LasTurret.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE TupleSections #-} module Dodge.Room.LasTurret where import Dodge.LevelGen.Data import Dodge.PlacementSpot @@ -72,14 +73,14 @@ lightSensByDoor outplid rm = rm covershape = rectNSEW 10 (-10) 20 (-20) sensorshift (p,a) = (p +.+ rotateV a (V2 60 (-20)), a) -keyCardRoomRunPast :: RandomGen g => Int -> Int -> State g (SubCompTree Room) +keyCardRoomRunPast :: RandomGen g => Int -> Int -> State g (LabSubCompTree Room) keyCardRoomRunPast keyid rmid = do cenroom <- shuffleLinks $ keyCardAnalyserByDoor keyid rmid $ roomNgon 6 200 let doorroom = triggerDoorRoom rmid - return $ treeFromTrunk [PassDown door] $ Node (PassDown cenroom) + (return $ treeFromTrunk [PassDown door] $ Node (PassDown cenroom) [ treeFromPost [PassDown doorroom] (UseAll door) , treeFromPost [PassDown door] (UseLabel 0 corridor) - ] + ]) <&> (,TreeSubLabelling "keyCardRoomRunPast" Nothing) keyCardAnalyserByDoor :: Int -> Int -> Room -> Room keyCardAnalyserByDoor keyid = analyserByDoor @@ -133,20 +134,22 @@ healthTest n = do ,PassDown $ corridor & rmPmnts .:~ spNoID (PS 20 0) (PutFlIt (medkit 100)) ,PassDown cenroom,PassDown doorroom] (UseAll door) -lasSensorTurretTest :: RandomGen g => Int -> State g (SubCompTree Room) +lasSensorTurretTest :: RandomGen g => Int -> State g (LabSubCompTree Room) lasSensorTurretTest n = do cenroom <- shuffleLinks $ lightSensInsideDoor n cenLasTur let doorroom = triggerDoorRoom n - return $ treeFromPost [PassDown door,PassDown cenroom,PassDown doorroom] (UseAll door) + return ( treeFromPost [PassDown door,PassDown cenroom,PassDown doorroom] (UseAll door) + , TreeSubLabelling "lasSensorTurretTest" Nothing + ) -lasCenSensEdge :: RandomGen g => Int -> State g (SubCompTree Room) +lasCenSensEdge :: RandomGen g => Int -> State g (LabSubCompTree Room) lasCenSensEdge n = do cenroom <- shuffleLinks $ lightSensByDoor n cenLasTur let doorroom = triggerDoorRoom n - return $ treeFromTrunk [PassDown door] $ Node (PassDown cenroom) + (return $ treeFromTrunk [PassDown door] $ Node (PassDown cenroom) [ treeFromPost [PassDown doorroom] (UseAll door) , treeFromPost [PassDown door] (UseLabel 0 corridor) - ] + ]) <&> (,TreeSubLabelling "lasCenSensEdge" Nothing) lasTunnel :: RandomGen g => Float -> State g Room lasTunnel y = do @@ -183,12 +186,12 @@ lasTunnel y = do ] -- a y value of 400 is probably "unrunnable" -lasTunnelRunPast :: RandomGen g => Float -> State g (SubCompTree Room) +lasTunnelRunPast :: RandomGen g => Float -> State g (LabSubCompTree Room) lasTunnelRunPast y = do r <- lasTunnel y r1 <- takeOne [door,corridor] r2 <- takeOne [door,corridor] - return $ Node (PassDown r) + (return $ Node (PassDown r) [ singleUseAll r1 , return (UseLabel 0 $ r2 & rmConnectsTo .~ S.member InLink) - ] + ]) <&> (,TreeSubLabelling "lasTunnelRunPast" Nothing) diff --git a/src/Dodge/Room/LongDoor.hs b/src/Dodge/Room/LongDoor.hs index 37156cb9f..7689bf90f 100644 --- a/src/Dodge/Room/LongDoor.hs +++ b/src/Dodge/Room/LongDoor.hs @@ -1,4 +1,4 @@ ---{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TupleSections #-} {- | Rooms containing long doors, probably with a big reveal behind them. -} module Dodge.Room.LongDoor where @@ -142,10 +142,10 @@ slowDoorRoom = do proom <- southPillarsRoom x y h addButtonSlowDoor x h (proom & rmPmnts %~ (++ (crits ++ barrels))) -slowDoorRoomRunPast :: RandomGen g => State g (SubCompTree Room) +slowDoorRoomRunPast :: RandomGen g => State g (LabSubCompTree Room) slowDoorRoomRunPast = do r <- slowDoorRoom - return $ treeFromTrunk [PassDown door] $ Node (PassDown r) + (return $ treeFromTrunk [PassDown door] $ Node (PassDown r) [ singleUseAll door , return (UseLabel 0 $ door & rmConnectsTo .~ S.member InLink) - ] + ] ) <&> (,TreeSubLabelling "slowDoorRoomRunPast" Nothing) diff --git a/src/Dodge/Room/LongRoom.hs b/src/Dodge/Room/LongRoom.hs index f6e6286e2..8072f6cb0 100644 --- a/src/Dodge/Room/LongRoom.hs +++ b/src/Dodge/Room/LongRoom.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE TupleSections #-} module Dodge.Room.LongRoom where import Dodge.RoomLink import Dodge.Tree @@ -48,10 +49,10 @@ longRoom = do | crx <- [12.5,37.5,62.5] ] ++ [sPS (V2 25 lampy ) 0 putLamp | lampy <- [20,h-10] ] -longRoomRunPast :: RandomGen g => State g (SubCompTree Room) +longRoomRunPast :: RandomGen g => State g (LabSubCompTree Room) longRoomRunPast = do r <- longRoom - return $ treeFromTrunk [PassDown door] + (return $ treeFromTrunk [PassDown door] (Node (PassDown r) [ singleUseAll door --, return (UseLabel 0 $ door & rmConnectsTo .~ S.singleton InLink) @@ -60,3 +61,4 @@ longRoomRunPast = do (UseLabel 0 door) ] ) + ) <&> (,TreeSubLabelling "longRoomRunPast" Nothing) diff --git a/src/Dodge/Room/Room.hs b/src/Dodge/Room/Room.hs index 0041c2673..ac15314ba 100644 --- a/src/Dodge/Room/Room.hs +++ b/src/Dodge/Room/Room.hs @@ -130,14 +130,18 @@ rot90Around cen p = cen +.+ vNormal (p -.- cen) -- So, the idea is to attach outer children to the bottommost right nodes -- inside an inner tree -roomMiniIntro :: RandomGen g => State g (SubCompTree Room) +roomMiniIntro :: RandomGen g => State g (LabSubCompTree Room) roomMiniIntro = do midroom <- join $ takeOne [miniTree2] --,glassLesson] - return $ chainUses [return $ UseAll corridor,return $ UseAll corridor,return $ UseAll corridor,return $ UseAll door, midroom,return $ UseAll corridor] + (return $ chainUses + [return $ UseAll corridor,return $ UseAll corridor,return $ UseAll corridor,return $ UseAll door, midroom,return $ UseAll corridor] + ) <&> (,TreeSubLabelling "roomMiniIntro" Nothing) roomCenterPillar :: RandomGen g => State g Room roomCenterPillar = shuffleLinks . restrictInLinks ((\p -> dist p (V2 120 0) < 10) . fst) - $ set rmPmnts plmnts $ roomRect 240 240 2 2 + $ set rmPmnts plmnts + $ set rmName "roomCenterPillar" + $ roomRect 240 240 2 2 where plmnts = [ blockLine (V2 115 115) (V2 115 125) @@ -196,7 +200,7 @@ weaponEmptyRoom = do $ restrictRMInLinksPD f (roomRect w h 2 2 & rmPmnts .~ plmnts) return $ treeFromTrunk [PassDown corridor] (singleUseAll rm ) -weaponUnderCrits :: RandomGen g => Int -> State g (SubCompTree Room) +weaponUnderCrits :: RandomGen g => Int -> State g (LabSubCompTree Room) weaponUnderCrits i = do let plmnts = [--sPS (V2 20 0) 0 $ RandPS randFirstWeapon @@ -204,23 +208,36 @@ weaponUnderCrits i = do ,sPS (V2 20 20) ( pi/2) randC1 ] addwpat p = rmPmnts .:~ PickOnePlacement i (sPS p 0 $ RandPS randFirstWeapon) - let continuationRoom = treeFromTrunk + let continuationRoom = treeFromTrunk [PassDown $ addwpat (V2 20 0) corridorN,PassDown $ addwpat (V2 20 0) corridorN] (singleUseAll (set rmPmnts plmnts corridorN)) - rcp <- roomCenterPillar + rcp <- roomCenterPillar rmpils <- roomPillars 30 240 240 2 2 deadEndRoom' <- takeOne [ addwpat (V2 120 20) rmpils , addwpat (V2 120 20) rcp] junctionRoom <- takeOne [PassDown tEast,PassDown tWest] - return $ treeFromTrunk - --[PassDown $ corridorN & rmPmnts .:~ mntLightLnkCond (resetPLUse $ rprBool $ \rp _ -> isInLnk rp) - [PassDown corridorN - ,PassDown corridorN] - $ Node junctionRoom - [continuationRoom - ,singleUseNone deadEndRoom' - ] + let thetree = treeFromTrunk + --[PassDown $ corridorN & rmPmnts .:~ mntLightLnkCond (resetPLUse $ rprBool $ \rp _ -> isInLnk rp) + [PassDown corridorN + ,PassDown corridorN] + $ Node junctionRoom + [continuationRoom + ,singleUseNone deadEndRoom' + ] + return thetree + <&> (, TreeSubLabelling ("weaponUnderCrits "++show i) (Just $ fmap composingNodeName thetree)) + +composingNodeName :: ComposingNode Room -> TreeSubLabelling +composingNodeName cn = case cn of + PassDown rm -> f $ _rmName rm ++ "-PassDown" + SplitDown rm -> f $ _rmName rm ++ "-SplitDown" + UseAll rm -> f $ _rmName rm ++ "-UseAll" + UseSome is rm -> f $ _rmName rm ++ "-" ++ show is ++ "-UseSome" + UseNone rm -> f $ _rmName rm ++ "-UseNone" + UseLabel i rm -> f $ _rmName rm ++ "-" ++ show i ++ "-UseLabel" + where + f str = TreeSubLabelling str Nothing weaponBehindPillar :: RandomGen g => State g (SubCompTree Room) weaponBehindPillar = do @@ -285,18 +302,21 @@ deadEndRoom = defaultRoom , _rmPath = [] , _rmPmnts = [sPS (V2 0 (-10)) 0 putLamp] , _rmBound = [rectNSWE 20 (-20) (-30) 30] + , _rmName = "deadEndRoom" } where lnks = [(V2 0 30 ,0) ] {- A random Either tree with a weapon and melee monster challenge. -} -weaponRoom :: RandomGen g => Int -> State g (SubCompTree Room, String) +weaponRoom :: RandomGen g => Int -> State g (LabSubCompTree Room) weaponRoom i = join $ takeOne - [ weaponEmptyRoom <&> (, "weaponEmptyRoom") - , weaponUnderCrits i<&> (, "weaponUnderCrits") - , weaponBehindPillar<&> (, "weaponBehindPillar") - , weaponBetweenPillars<&> (, "weaponBetweenPillars") - , weaponLongCorridor<&> (, "weaponLongCorridor") + [ weaponEmptyRoom <&> (,f "weaponEmptyRoom") + , weaponUnderCrits i + , weaponBehindPillar<&> (,f "weaponBehindPillar") + , weaponBetweenPillars<&> (,f "weaponBetweenPillars") + , weaponLongCorridor<&> (,f "weaponLongCorridor") ] + where + f str = TreeSubLabelling str Nothing roomCCrits :: RandomGen g => State g Room roomCCrits = roomC 200 200 @@ -392,7 +412,7 @@ pistolerRoom = pillarGrid ] ++) -shootingRange :: RandomGen g => State g (SubCompTree Room) +shootingRange :: RandomGen g => State g (LabSubCompTree Room) shootingRange = do rm1 <- shootersRoom1 >>= randomiseAllLinks . restrictInLinks (\(V2 _ y,_) -> y < 40) . restrictOutLinks (\(V2 _ y,r) -> y > 200 && r /= 0) @@ -402,7 +422,7 @@ shootingRange = do rm3 <- shootersRoom >>= randomiseAllLinks . restrictInLinks (\(V2 x y,_) -> y < 10 && x > 20 && x < 180) . restrictOutLinks (\(_,r) -> r == 0) - return $ treeFromPost + (return $ treeFromPost [PassDown rm1 ,PassDown $ roomPadCut (rectNSWE 40 (-40) (-80) 80) (V2 0 20) & rmPmnts %~ (spanLightI (V2 (-80) 10) (V2 80 10) :) @@ -411,6 +431,7 @@ shootingRange = do & rmPmnts %~ (spanLightI (V2 (-80) 10) (V2 80 10) :) ] (UseAll rm3) + ) <&> (,TreeSubLabelling "shootingRange" Nothing) spawnerRoom :: RandomGen g => State g (SubCompTree Room) spawnerRoom = do diff --git a/src/Dodge/Room/SensorDoor.hs b/src/Dodge/Room/SensorDoor.hs index 8f562a578..9a029b817 100644 --- a/src/Dodge/Room/SensorDoor.hs +++ b/src/Dodge/Room/SensorDoor.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE TupleSections #-} module Dodge.Room.SensorDoor where import Dodge.LevelGen.Data import Dodge.PlacementSpot @@ -41,14 +42,14 @@ sensorRoom senseType n = do let doorroom = triggerDoorRoom n return $ treeFromPost [PassDown door,PassDown cenroom,PassDown doorroom] (UseAll door) -sensorRoomRunPast :: RandomGen g => DamageType -> Int -> State g (SubCompTree Room) +sensorRoomRunPast :: RandomGen g => DamageType -> Int -> State g (LabSubCompTree Room) sensorRoomRunPast dt n = do t <- sensorRoom dt n - return $ applyToSubforest [0] (++ + (return $ applyToSubforest [0] (++ [treeFromPost [PassDown $ door & rmConnectsTo .~ S.member InLink & rmName .~ "test" ] (UseLabel 0 corridor)] - ) t + ) t ) <&> (,TreeSubLabelling "sensorRoomRunPast" Nothing) --[return $ UseLabel 0 $ door & rmConnectsTo .~ S.member InLink] sensAboveDoor :: DamageType -> Float -> PlacementSpot -> Placement diff --git a/src/Dodge/Room/Start.hs b/src/Dodge/Room/Start.hs index 8ccb46d9b..36c854d36 100644 --- a/src/Dodge/Room/Start.hs +++ b/src/Dodge/Room/Start.hs @@ -49,25 +49,27 @@ powerFakeout = do ,PassDown keyholeCorridor,PassDown corridor]) `treeFromPost` UseAll door -startRoom :: RandomGen g => Int -> State g (SubCompTree Room,String) -startRoom i = join $ uncurry takeOneWeighted $ unzip +startRoom :: RandomGen g => Int -> State g (LabSubCompTree Room) +startRoom i = (join $ uncurry takeOneWeighted $ unzip [ (,) (0.5::Float) ((chainUses <$> sequence [powerFakeout,fmap fst $weaponRoom i]) - <&> (,"chainUses <$> sequence [powerFakeout,weaponRoom i]")) - , (,) one (rezBoxesWp <&> (, "rezBoxesWp")) + <&> (,TreeSubLabelling "chainUses <$> sequence [powerFakeout,weaponRoom i]" Nothing)) + , (,) one (rezBoxesWp <&> (,TreeSubLabelling "rezBoxesWp" Nothing)) , (,) one (rezBoxThenWeaponRoom i) - , (,) one (rezBoxesWpCrit <&> (,"rezBoxesWpCrit")) - , (,) one (runPastStart i <&> (,"runPastStart " ++ show i)) - , (,) one (startCrafts >>= roomsContaining [] >>= rezBoxThenRooms <&> - (,"startCrafts >>= roomsContaining [] >>= rezBoxThenRooms")) - ] + , (,) one (rezBoxesWpCrit <&> (,TreeSubLabelling "rezBoxesWpCrit" Nothing)) + , (,) one (runPastStart i <&> (,TreeSubLabelling ("runPastStart " ++ show i) Nothing)) + , (,) one (startCrafts >>= roomsContaining' [] >>= rezBoxThenRooms <&> + (,TreeSubLabelling "startCrafts >>= roomsContaining [] >>= rezBoxThenRooms" Nothing)) + ]) + <&> over (_2 . topLabel) ("startRoom:"++) where + roomsContaining' a b = fst <$> roomsContaining a b one = 1::Float -randomChallenges :: RandomGen g => State g (SubCompTree Room) -randomChallenges = join $ takeOne - [fmap (return . UseAll) doubleCorridorBarrels +randomChallenges :: RandomGen g => State g (LabSubCompTree Room) +randomChallenges = join (takeOne + [fmap (return . UseAll) doubleCorridorBarrels <&> (,TreeSubLabelling "doubleCorridorBarrels" Nothing) ,shootingRange - ,fmap (return . UseAll) twinSlowDoorChasers - ] + ,fmap (return . UseAll) twinSlowDoorChasers <&> (,TreeSubLabelling "twinSlowDoorChasers" Nothing) + ]) <&> (over (_2 . topLabel) ("randomChallenges:"++)) runPastStart :: RandomGen g => Int -> State g (SubCompTree Room) runPastStart i = do @@ -83,15 +85,15 @@ rezBoxStart = do rezBoxesThenWeaponRoom :: RandomGen g => Int -> State g (SubCompTree Room,String) rezBoxesThenWeaponRoom i = do rboxes <- rezBoxes - wroom <- fmap fst $ weaponRoom i + wroom <- fst <$> weaponRoom i return (rboxes `passUntilUseAll` [wroom] , "rezBoxesThenWeaponRoom " ++ show i) -rezBoxThenWeaponRoom :: RandomGen g => Int -> State g (SubCompTree Room,String) +rezBoxThenWeaponRoom :: RandomGen g => Int -> State g (LabSubCompTree Room) rezBoxThenWeaponRoom i = do rcol <- rezColor (wroom,wroomname) <- weaponRoom i - return $ (treeFromTrunk [PassDown $ rezBox rcol,PassDown door] wroom - , "rezBoxThenWeaponRoom "++ show i ++ ":" ++ wroomname) + return (treeFromTrunk [PassDown $ rezBox rcol,PassDown door] wroom + , TreeSubLabelling ("rezBoxThenWeaponRoom "++ show i) (Just $ return wroomname)) rezBoxThenRoom :: RandomGen g => Room -> State g (SubCompTree Room) rezBoxThenRoom r = do diff --git a/src/Dodge/Tree/Compose.hs b/src/Dodge/Tree/Compose.hs index 7699c4b19..86ea9c233 100644 --- a/src/Dodge/Tree/Compose.hs +++ b/src/Dodge/Tree/Compose.hs @@ -35,7 +35,7 @@ overwriteLabel i f t ts = errorHead ("tried to overwriteLabel " ++ show i) where islabel (UseLabel j _) | i == j = True islabel _ = False - update (Node cr _) = Node (f $ _unCompose cr) ts + update (Node x _) = Node (f $ _unCompose x) ts passUntilUseAll :: SubCompTree a -> [SubCompTree a] -> SubCompTree a passUntilUseAll (Node (UseAll x) _) ts' = Node (PassDown x) ts' diff --git a/src/Dodge/Tree/Compose/Data.hs b/src/Dodge/Tree/Compose/Data.hs index aa54645b0..adbeecf9b 100644 --- a/src/Dodge/Tree/Compose/Data.hs +++ b/src/Dodge/Tree/Compose/Data.hs @@ -12,4 +12,11 @@ data ComposingNode a | UseLabel {_composeIndex :: Int, _unCompose :: a} -- defaults to using no children type SubCompTree a = Tree (ComposingNode a) type CompTree a = Tree (SubCompTree a) +type LabSubCompTree a = (Tree (ComposingNode a),TreeSubLabelling) +type LabCompTree a = Tree (LabSubCompTree a) +data TreeSubLabelling = TreeSubLabelling + { _topLabel :: String + , _subLabels :: Maybe (Tree TreeSubLabelling) + } makeLenses ''ComposingNode +makeLenses ''TreeSubLabelling