From 2ccb26b289158dc8e2855b152ce767f4ba69cbf7 Mon Sep 17 00:00:00 2001 From: justin Date: Sun, 12 Jun 2022 13:38:23 +0100 Subject: [PATCH] Rework annotations --- src/Dodge/Annotation.hs | 113 ++++++++++++++++++--------------- src/Dodge/Annotation/Data.hs | 18 +++--- src/Dodge/Floor.hs | 115 +++++++++++++++++----------------- src/Dodge/LevelGen.hs | 2 +- src/Dodge/LockAndKey.hs | 10 +-- src/Dodge/Room/BlinkAcross.hs | 2 +- src/Dodge/Room/Containing.hs | 2 +- src/Dodge/Room/GlassLesson.hs | 4 +- src/Dodge/Room/LasTurret.hs | 12 ++-- src/Dodge/Room/LongDoor.hs | 2 +- src/Dodge/Room/LongRoom.hs | 2 +- src/Dodge/Room/Room.hs | 8 +-- src/Dodge/Room/SensorDoor.hs | 2 +- src/Dodge/Room/Start.hs | 13 ++-- src/Dodge/Room/Warning.hs | 2 +- src/Dodge/UseAll.hs | 8 ++- 16 files changed, 161 insertions(+), 154 deletions(-) diff --git a/src/Dodge/Annotation.hs b/src/Dodge/Annotation.hs index ba66a6b8c..65067a9e0 100644 --- a/src/Dodge/Annotation.hs +++ b/src/Dodge/Annotation.hs @@ -10,70 +10,79 @@ import Dodge.Tree import Dodge.Room import Dodge.Data import Dodge.Annotation.Data ---import LensHelp +import LensHelp --import Control.Lens -import Data.Maybe +--import Data.Maybe -addLock :: Int -> Tree [Annotation] -> State StdGen (Tree [Annotation]) -addLock i t = do - (beforeLock, afterLock) <- splitTrunk t - newBefore <- applyToRandomNode (Key i :) beforeLock - return $ addToTrunk newBefore [Node [Lock i] afterLock] {- | Add one corridor between each parent-child link of a tree of annotations. -} -padWithCorridors :: Tree [Annotation] -> Tree [Annotation] -padWithCorridors = padWithAno [Corridor] +--padWithCorridors :: Annotation -> Annotation +--padWithCorridors = padWithAno [Corridor] +-- +--padWithAno :: [Annotation] -> Tree [Annotation] -> Tree [Annotation] +--padWithAno ano (Node x xs) = Node ano [Node x (map (padWithAno ano) xs)] +-- +--padSucWithCorridors :: Tree [Annotation] -> Tree [Annotation] +--padSucWithCorridors (Node x xs) = Node x (map padWithCorridors xs) +-- +--padSucWithDoors :: Tree [Annotation] -> Tree [Annotation] +--padSucWithDoors (Node x xs) = Node x (map (padWithAno [SpecificRoom thetree]) xs) +-- where +-- thetree = do +-- thecor <- shuffleLinks corridor +-- takeOne +-- [ (toOnward "door", return (cleatOnward door)) +-- , (toOnward "twoDoors" ,treePost [ door, thecor, cleatOnward door]) +-- ] +-- +--{- Add one to three corridors between each parent-child link of a tree of annotations. -} +--randomPadCorridors :: Tree [Annotation] -> State StdGen (Tree [Annotation]) +--randomPadCorridors (Node x xs) = do +-- n <- state $ randomR (1, 3) +-- xs' <- mapM randomPadCorridors xs +-- return $ treeFromTrunk (replicate n [Corridor]) (Node x xs') -padWithAno :: [Annotation] -> Tree [Annotation] -> Tree [Annotation] -padWithAno ano (Node x xs) = Node ano [Node x (map (padWithAno ano) xs)] +annoToRoomTree :: Annotation -> State StdGen (MetaTree Room) +annoToRoomTree an = case an of + OnwardList ans -> do + mts <- mapM annoToRoomTree ans + return $ foldr1 attachOnward mts + SpecificRoom r -> r + PadWith r an -> annoToRoomTree an + IntAnno i f -> annoToRoomTree $ f i -padSucWithCorridors :: Tree [Annotation] -> Tree [Annotation] -padSucWithCorridors (Node x xs) = Node x (map padWithCorridors xs) - -padSucWithDoors :: Tree [Annotation] -> Tree [Annotation] -padSucWithDoors (Node x xs) = Node x (map (padWithAno [SpecificRoom thetree]) xs) - where - thetree = do - thecor <- shuffleLinks corridor - takeOne - [ (toOnward "door", return (cleatOnward door)) - , (toOnward "twoDoors" ,treePost [ door, thecor, cleatOnward door]) - ] - -{- Add one to three corridors between each parent-child link of a tree of annotations. -} -randomPadCorridors :: Tree [Annotation] -> State StdGen (Tree [Annotation]) -randomPadCorridors (Node x xs) = do - n <- state $ randomR (1, 3) - xs' <- mapM randomPadCorridors xs - return $ treeFromTrunk (replicate n [Corridor]) (Node x xs') +attachOnward :: MetaTree Room -> MetaTree Room -> MetaTree Room +attachOnward t1 t2 = case t1 of + MTree {} -> t1 & mtBranches .:~ MBranch "Onward" toOnward' t2 + BTree {} -> t2 & btBranches .:~ t2 {- | Create a random room tree structure from a list of annotations. -} -anoToRoomTree :: [Annotation] -> State StdGen (Room -> Maybe ([String],Room), Tree Room) -anoToRoomTree anos = case anos of - [AnoApplyInt i f] -> f i --- [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 = snd lr' - keyroom' <- fromJust $ lookup ii ks - let keyroom = snd keyroom' - rToOnward ("PassthroughLockKeyLists-"++show ii) $ overwriteLabel i lr [keyroom] - _ -> rToOnward "no label" =<< anoToRoomTree' anos +--anoToRoomTree :: [Annotation] -> State StdGen (Room -> Maybe ([String],Room), Tree Room) +--anoToRoomTree anos = case anos of +-- [AnoApplyInt i f] -> f i +---- [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 = snd lr' +-- keyroom' <- fromJust $ lookup ii ks +-- let keyroom = snd keyroom' +-- rToOnward ("PassthroughLockKeyLists-"++show ii) $ overwriteLabel i lr [keyroom] +-- _ -> rToOnward "no label" =<< anoToRoomTree' anos {- | Create a random room tree structure from a list of annotations. -} anoToRoomTree' :: [Annotation] -> State StdGen (Tree Room) anoToRoomTree' anos = case anos of - [OrAno as] -> do - a <- takeOne as - anoToRoomTree' a - [Corridor] -> pure . cleatOnward <$> shuffleLinks corridor - (BossAno cr : _) -> do - br <- bossRoom cr - branchRectWith . pure $ treeFromPost [corridor,corridor] br - (TreasureAno crs loot : _) -> branchRectWith . fmap pure $ lootRoom crs loot +-- [OrAno as] -> do +-- a <- takeOne as +-- anoToRoomTree' a +-- [Corridor] -> pure . cleatOnward <$> shuffleLinks corridor +-- (BossAno cr : _) -> do +-- br <- bossRoom cr +-- branchRectWith . pure $ treeFromPost [corridor,corridor] br +-- (TreasureAno crs loot : _) -> branchRectWith . fmap pure $ lootRoom crs loot _ -> do w <- state $ randomR (100,400) h <- state $ randomR (200,400) diff --git a/src/Dodge/Annotation/Data.hs b/src/Dodge/Annotation/Data.hs index 6006e69e3..6eaeb770c 100644 --- a/src/Dodge/Annotation/Data.hs +++ b/src/Dodge/Annotation/Data.hs @@ -10,20 +10,16 @@ import Control.Monad.State import Control.Lens import System.Random data Annotation - = Lock Int - | Key Int - | Corridor - | AirlockAno - | OrAno [[Annotation]] - | SpecificRoom (State StdGen (LabTree Room)) - | BossAno Creature - | TreasureAno [Creature] [Item] + = -- Corridor +-- | AirlockAno + PadWith Room Annotation + | OnwardList [Annotation] + | IntAnno Int (Int -> Annotation) +-- | OrAno [[Annotation]] + | SpecificRoom (State StdGen (MetaTree Room)) | AnoApplyInt Int (Int -> State StdGen (LabTree Room)) - | AnoNewInt (Int -> State StdGen (Tree Room)) | PassthroughLockKeyLists Int [(Int -> State StdGen (LabTree Room), State StdGen ItemBaseType)] [(ItemBaseType, State StdGen (LabTree Room))] --- | SetLabel Int (State g Room) --- | useLabel Int (State g Room) makeLenses ''Annotation diff --git a/src/Dodge/Floor.hs b/src/Dodge/Floor.hs index dd6cb600e..aaaa447de 100644 --- a/src/Dodge/Floor.hs +++ b/src/Dodge/Floor.hs @@ -35,68 +35,67 @@ import RandomHelp --import Data.Maybe --import qualified Data.IntMap.Strict as IM -initialAnoTree :: Tree [Annotation] -initialAnoTree = padSucWithDoors $ treePost - [[AnoApplyInt 110 startRoom] - , [PassthroughLockKeyLists 2 keyCardRunPastRand itemRooms] - , [SpecificRoom $ warningRooms 777777] - , [SpecificRoom $ rToOnward "chaseCrit+armourChaseCrit rectRoom" +initialAnoTree :: Annotation +initialAnoTree = PadWith door $ OnwardList + [ IntAnno 0 $ SpecificRoom . startRoom +-- , PassthroughLockKeyLists 2 keyCardRunPastRand itemRooms + , SpecificRoom $ warningRooms 1 + , SpecificRoom $ rToOnward "chaseCrit+armourChaseCrit rectRoom" $ return . cleatOnward $ roomRectAutoLinks 400 400 & rmPmnts .++~ [ spNoID anyUnusedSpot (PutCrit invisibleChaseCrit) , spNoID anyUnusedSpot (PutCrit armourChaseCrit) ] - ] --- , [AnoApplyInt 100 healthTest] - , [PassthroughLockKeyLists 23 - [(sensorRoomRunPast ELECTRICAL, takeOne [STATICMODULE,SPARKGUN] )] itemRooms] - , [SpecificRoom (tanksRoom [] [] >>= rToOnward "empty tanksRoom" . pure . cleatOnward)] - , [PassthroughLockKeyLists 222 lockRoomKeyItems itemRooms] - , [SpecificRoom randomChallenges] - , [AnoApplyInt 1 lasSensorTurretTest] --- ,[SpecificRoom $ fmap pure roomCCrits] --- ,[AirlockAno] --- ,[Corridor] ------- ,[SpecificRoom roomCCrits] ------- ,[Corridor] ------- ,[SpecificRoom . pure . pure . useAll $ roomGlassOctogon 400 ------- & rmPS %~ ([sPS (V2 0 50) 0 $ PutCrit armourChaseCrit ------- ,sPS (V2 50 25) 0 $ PutCrit armourChaseCrit ------- ,sPS (V2 50 0) 0 $ PutCrit armourChaseCrit ------- ]++) ------- ] ------- --,[SpecificRoom . pure . pure . useAll $ roomGlassOctogon 400 ------- -- & rmPS %~ ([swarmPS 0 (x,y) 0 swarmCrit | x <- [-20,-19.5.. 20] , y <- [200,202] ]++) ------- -- ] ------- ,[SpecificRoom . pure . pure . useAll $ roomGlassOctogon 400 ------- & rmPS %~ ([sPS (V2 0 50) 0 $ PutCrit pistolCrit ]++) ------- ] ------- ,[Corridor] ----- --,[SpecificRoom $ pure . useAll <$> twinSlowDoorChasers] ------ ,[SpecificRoom $ pure $ (pure . useAll) (twinSlowDoorRoom 80 200 40)] ------ ,[DoorAno] ------ ,[SpecificRoom $ pure . useAll <$> centerVaultExplosiveExit] ------ ,[SpecificRoom blockedCorridor] ------ ,[OrAno [[DoorAno] ------ ,[Corridor] ------ ,[DoorNumAno 0,AirlockAno]] ------ ] ------ ,[FirstWeapon] ------ ,[CorridorDebug] ------ ,[SpecificRoom $ fmap (pure . useAll) randomFourCornerRoom] --- ,[OrAno --- [[SpecificRoom $ branchRectWith $ fmap (fmap ) armouredChasers] --- ,[BossAno $ addArmour launcherCrit & crHP +~ 800 --- & crState . crDropsOnDeath .~ DropSpecific [0] ] --- ] --- ] ----- ,[SpecificRoom $ fmap (pure . useAll) armouredCorridor] --- ,[Corridor] --- ,[TreasureAno [addArmour autoCrit,addArmour autoCrit] [launcher]] --- ,[Corridor] - ,[SpecificRoom $ randomFourCornerRoom [] >>= rToOnward "randomFourCornerRoom" . pure . cleatOnward ] - ,[SpecificRoom $ telRoomLev 1 >>= rToOnward "telRoomLev" . pure . cleatOnward] +--"-- , [AnoApplyInt 100 healthTest] +--" , PassthroughLockKeyLists 23 +--" [(sensorRoomRunPast ELECTRICAL, takeOne [STATICMODULE,SPARKGUN] )] itemRooms +--" , SpecificRoom (tanksRoom [] [] >>= rToOnward "empty tanksRoom" . pure . cleatOnward) +--" , PassthroughLockKeyLists 222 lockRoomKeyItems itemRooms +--" , SpecificRoom randomChallenges +--" , AnoApplyInt 1 lasSensorTurretTest +--"-- ,[SpecificRoom $ fmap pure roomCCrits] +--"-- ,[AirlockAno] +--"-- ,[Corridor] +--"------ ,[SpecificRoom roomCCrits] +--"------ ,[Corridor] +--"------ ,[SpecificRoom . pure . pure . useAll $ roomGlassOctogon 400 +--"------ & rmPS %~ ([sPS (V2 0 50) 0 $ PutCrit armourChaseCrit +--"------ ,sPS (V2 50 25) 0 $ PutCrit armourChaseCrit +--"------ ,sPS (V2 50 0) 0 $ PutCrit armourChaseCrit +--"------ ]++) +--"------ ] +--"------ --,[SpecificRoom . pure . pure . useAll $ roomGlassOctogon 400 +--"------ -- & rmPS %~ ([swarmPS 0 (x,y) 0 swarmCrit | x <- [-20,-19.5.. 20] , y <- [200,202] ]++) +--"------ -- ] +--"------ ,[SpecificRoom . pure . pure . useAll $ roomGlassOctogon 400 +--"------ & rmPS %~ ([sPS (V2 0 50) 0 $ PutCrit pistolCrit ]++) +--"------ ] +--"------ ,[Corridor] +--"---- --,[SpecificRoom $ pure . useAll <$> twinSlowDoorChasers] +--"----- ,[SpecificRoom $ pure $ (pure . useAll) (twinSlowDoorRoom 80 200 40)] +--"----- ,[DoorAno] +--"----- ,[SpecificRoom $ pure . useAll <$> centerVaultExplosiveExit] +--"----- ,[SpecificRoom blockedCorridor] +--"----- ,[OrAno [[DoorAno] +--"----- ,[Corridor] +--"----- ,[DoorNumAno 0,AirlockAno]] +--"----- ] +--"----- ,[FirstWeapon] +--"----- ,[CorridorDebug] +--"----- ,[SpecificRoom $ fmap (pure . useAll) randomFourCornerRoom] +--"-- ,[OrAno +--"-- [[SpecificRoom $ branchRectWith $ fmap (fmap ) armouredChasers] +--"-- ,[BossAno $ addArmour launcherCrit & crHP +~ 800 +--"-- & crState . crDropsOnDeath .~ DropSpecific [0] ] +--"-- ] +--"-- ] +--"---- ,[SpecificRoom $ fmap (pure . useAll) armouredCorridor] +--"-- ,[Corridor] +--"-- ,[TreasureAno [addArmour autoCrit,addArmour autoCrit] [launcher]] +--"-- ,[Corridor] +--" ,SpecificRoom $ randomFourCornerRoom [] >>= rToOnward "randomFourCornerRoom" . pure . cleatOnward +--" ,SpecificRoom $ telRoomLev 1 >>= rToOnward "telRoomLev" . pure . cleatOnward ] {- | A test level tree. -} -initialRoomTree :: State StdGen (Tree (Room -> Maybe ([String],Room), Tree Room)) -initialRoomTree = mapM anoToRoomTree initialAnoTree +initialRoomTree :: State StdGen (MetaTree Room) +initialRoomTree = annoToRoomTree initialAnoTree diff --git a/src/Dodge/LevelGen.hs b/src/Dodge/LevelGen.hs index 145284f6c..5423da275 100644 --- a/src/Dodge/LevelGen.hs +++ b/src/Dodge/LevelGen.hs @@ -36,7 +36,7 @@ layoutLevelFromSeed i seed = do appendFile "log/attemptedSeeds" $ show seed ++ "\n" let g = mkStdGen seed let treecluster = evalState initialRoomTree g - tc <- composeAndLog $ cmpToMT treecluster + tc <- composeAndLog $ treecluster ---- (strs,tc) = composeTree' treecluster ----appendFile "log/TreeCluster" ("Seed: "++ show seed) ----mapM_ (appendFile "log/treeCluster" . ('\n':)) strs diff --git a/src/Dodge/LockAndKey.hs b/src/Dodge/LockAndKey.hs index 16a9078e1..9f3318727 100644 --- a/src/Dodge/LockAndKey.hs +++ b/src/Dodge/LockAndKey.hs @@ -17,7 +17,7 @@ import Dodge.Item bossKeyItems :: RandomGen g => [ (State g (Tree Room), State g ItemBaseType) ] bossKeyItems = [(return . cleatOnward <$> bossRoom autoCrit, takeOne [PISTOL]) ] -lockRoomMultiItems :: RandomGen g => [ ( State g (LabTree Room) , State g [ItemBaseType] ) ] +lockRoomMultiItems :: RandomGen g => [ ( State g (MetaTree Room) , State g [ItemBaseType] ) ] lockRoomMultiItems = [ (blinkAcrossChallenge, takeOne [[BLINKERUNSAFE,AUTODETECTOR WALLDETECTOR] ,[BLINKERUNSAFE,CLICKDETECTOR WALLDETECTOR] @@ -25,7 +25,7 @@ lockRoomMultiItems = ) ] -lockRoomKeyItems :: RandomGen g => [ (Int -> State g (LabTree Room) , State g ItemBaseType ) ] +lockRoomKeyItems :: RandomGen g => [ (Int -> State g (MetaTree Room) , State g ItemBaseType ) ] lockRoomKeyItems = [(lasCenSensEdge, takeOne [LAUNCHER,LASGUN,SPARKGUN,FLATSHIELD,FORCEFIELDGUN] ) ,(sensorRoomRunPast ELECTRICAL, takeOne [STATICMODULE,SPARKGUN] ) @@ -37,10 +37,10 @@ lockRoomKeyItems = ,(const $ lasTunnelRunPast 400, takeOne [FLATSHIELD,FORCEFIELDGUN]) ,(keyCardRoomRunPast 0, return (KEYCARD 0)) ] -keyCardRunPastRand :: RandomGen g => [ (Int -> State g (LabTree Room) , State g ItemBaseType ) ] +keyCardRunPastRand :: RandomGen g => [ (Int -> State g (MetaTree Room) , State g ItemBaseType ) ] keyCardRunPastRand = [(keyCardRoomRunPast 0, return (KEYCARD 0)) ] -itemRooms :: RandomGen g => [(ItemBaseType, State g (LabTree Room))] +itemRooms :: RandomGen g => [(ItemBaseType, State g (MetaTree Room))] itemRooms = [ (LAUNCHER , join $ takeOne [corridorBoss launcherCrit @@ -108,7 +108,7 @@ someCrits = do -- return $ roomsContaining crits its -corridorBoss :: RandomGen g => Creature -> State g (LabTree Room) +corridorBoss :: RandomGen g => Creature -> State g (MetaTree Room) corridorBoss cr = do endroom <- bossRoom cr rToOnward ("corridorBoss-"++_crName cr) diff --git a/src/Dodge/Room/BlinkAcross.hs b/src/Dodge/Room/BlinkAcross.hs index 68f071128..f2cc6a7a6 100644 --- a/src/Dodge/Room/BlinkAcross.hs +++ b/src/Dodge/Room/BlinkAcross.hs @@ -34,7 +34,7 @@ import LensHelp import Control.Monad.State import System.Random -blinkAcrossChallenge :: RandomGen g => State g (LabTree Room) +blinkAcrossChallenge :: RandomGen g => State g (MetaTree Room) blinkAcrossChallenge = do teleFromRoom <- shuffleLinks $ roomRectAutoLinks 200 200 teleToRoom <- shuffleLinks $ roomRectAutoLinks 200 200 diff --git a/src/Dodge/Room/Containing.hs b/src/Dodge/Room/Containing.hs index 4caf4c0cc..8948175d5 100644 --- a/src/Dodge/Room/Containing.hs +++ b/src/Dodge/Room/Containing.hs @@ -15,7 +15,7 @@ import Geometry import Data.List -roomsContaining :: RandomGen g => [Creature] -> [Item] -> State g (LabTree Room) +roomsContaining :: RandomGen g => [Creature] -> [Item] -> State g (MetaTree Room) roomsContaining crs its = do endroom <- join $ takeOne [ randomFourCornerRoomCrsIts crs its diff --git a/src/Dodge/Room/GlassLesson.hs b/src/Dodge/Room/GlassLesson.hs index d4d4ef94d..bac3d85cb 100644 --- a/src/Dodge/Room/GlassLesson.hs +++ b/src/Dodge/Room/GlassLesson.hs @@ -53,7 +53,7 @@ glassLesson = do , mntLS vShape (V2 180 200) (V3 160 180 50) ] ] -glassLessonRunPast :: RandomGen g => State g (LabTree Room) -glassLessonRunPast = (f <$> glassLesson) <&> (toOnward "glassLessonRunPast",) +glassLessonRunPast :: RandomGen g => State g (MetaTree Room) +glassLessonRunPast = (f <$> glassLesson) >>= rToOnward "glassLessonRunPast" where f (Node r rs) = Node r $ return (cleatLabel 0 $ door & rmConnectsTo .~ S.member (OnEdge West)) : rs diff --git a/src/Dodge/Room/LasTurret.hs b/src/Dodge/Room/LasTurret.hs index c5dc1fa2f..c2de8b9a7 100644 --- a/src/Dodge/Room/LasTurret.hs +++ b/src/Dodge/Room/LasTurret.hs @@ -71,15 +71,15 @@ 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 (LabTree Room) +keyCardRoomRunPast :: RandomGen g => Int -> Int -> State g (MetaTree Room) keyCardRoomRunPast keyid rmid = do cenroom <- shuffleLinks $ keyCardAnalyserByDoor keyid rmid $ roomNgon 6 200 let doorroom = triggerDoorRoom rmid - return (toOnward "keyCardRoomRunPast", + rToOnward "keyCardRoomRunPast" $ treeFromTrunk [door] $ Node cenroom [ treeFromPost [doorroom] (cleatOnward door) , treeFromPost [door] (cleatLabel rmid corridor) - ]) + ] keyCardAnalyserByDoor :: Int -> Int -> Room -> Room keyCardAnalyserByDoor keyid = analyserByDoor (RequireEquipment (KEYCARD keyid)) @@ -114,13 +114,13 @@ healthTest n = do , cleatOnward door ] -lasSensorTurretTest :: RandomGen g => Int -> State g (LabTree Room) +lasSensorTurretTest :: RandomGen g => Int -> State g (MetaTree Room) lasSensorTurretTest n = do cenroom <- shuffleLinks $ lightSensInsideDoor n cenLasTur rToOnward "lasSensorTurretTest" $ treePost [ door, cenroom, triggerDoorRoom n, cleatOnward door] -lasCenSensEdge :: RandomGen g => Int -> State g (LabTree Room) +lasCenSensEdge :: RandomGen g => Int -> State g (MetaTree Room) lasCenSensEdge n = do cenroom <- shuffleLinks $ lightSensByDoor n cenLasTur let doorroom = triggerDoorRoom n @@ -165,7 +165,7 @@ lasTunnel y = do ] -- a y value of 400 is probably "unrunnable" -lasTunnelRunPast :: RandomGen g => Float -> State g (LabTree Room) +lasTunnelRunPast :: RandomGen g => Float -> State g (MetaTree Room) lasTunnelRunPast y = do r <- lasTunnel y r1 <- takeOne [door,corridor] diff --git a/src/Dodge/Room/LongDoor.hs b/src/Dodge/Room/LongDoor.hs index 126316046..cc6912ffc 100644 --- a/src/Dodge/Room/LongDoor.hs +++ b/src/Dodge/Room/LongDoor.hs @@ -140,7 +140,7 @@ slowDoorRoom = do proom <- southPillarsRoom x y h addButtonSlowDoor x h (proom & rmPmnts %~ (++ (crits ++ barrels))) -slowDoorRoomRunPast :: RandomGen g => State g (LabTree Room) +slowDoorRoomRunPast :: RandomGen g => State g (MetaTree Room) slowDoorRoomRunPast = do r <- slowDoorRoom rToOnward "slowDoorRoomRunPast" $ treeFromTrunk [ door] $ Node r diff --git a/src/Dodge/Room/LongRoom.hs b/src/Dodge/Room/LongRoom.hs index acde22ba1..3945b41ad 100644 --- a/src/Dodge/Room/LongRoom.hs +++ b/src/Dodge/Room/LongRoom.hs @@ -47,7 +47,7 @@ longRoom = do | crx <- [12.5,37.5,62.5] ] ++ [sPS (V2 25 lampy ) 0 putLamp | lampy <- [20,h-10] ] -longRoomRunPast :: RandomGen g => State g (LabTree Room) +longRoomRunPast :: RandomGen g => State g (MetaTree Room) longRoomRunPast = do r <- longRoom rToOnward "longRoomRunPast" diff --git a/src/Dodge/Room/Room.hs b/src/Dodge/Room/Room.hs index e19af2b80..992444719 100644 --- a/src/Dodge/Room/Room.hs +++ b/src/Dodge/Room/Room.hs @@ -123,11 +123,11 @@ rot90Around cen p = cen +.+ vNormal (p -.- cen) -- So, the idea is to attach outer children to the bottommost right nodes -- inside an inner tree -- no idea what was going on here... -roomMiniIntro :: RandomGen g => State g (LabTree Room) +roomMiniIntro :: RandomGen g => State g (MetaTree Room) roomMiniIntro = do midroom <- join $ takeOne [miniTree2] --,glassLesson] - return ( toOnward "roomMiniIntro" - , midroom ) + rToOnward "roomMiniIntro" + midroom roomCenterPillar :: RandomGen g => State g Room roomCenterPillar = shuffleLinks . restrictInLinks ((\p -> dist p (V2 120 0) < 10) . fst) @@ -396,7 +396,7 @@ pistolerRoom = pillarGrid ] ++) -shootingRange :: RandomGen g => State g (LabTree Room) +shootingRange :: RandomGen g => State g (MetaTree Room) shootingRange = do rm1 <- shootersRoom1 >>= shuffleLinks . restrictInLinks (\(V2 _ y,_) -> y < 40) . restrictOutLinks (\(V2 _ y,r) -> y > 200 && r /= 0) diff --git a/src/Dodge/Room/SensorDoor.hs b/src/Dodge/Room/SensorDoor.hs index 71967796c..dc911e1e9 100644 --- a/src/Dodge/Room/SensorDoor.hs +++ b/src/Dodge/Room/SensorDoor.hs @@ -56,7 +56,7 @@ sensorRoom senseType n = do p' = p +.+ rotateV d (V2 0 (negate 100)) isclose = dist (_rlPos rl) p' < 30 -sensorRoomRunPast :: RandomGen g => DamageType -> Int -> State g (LabTree Room) +sensorRoomRunPast :: RandomGen g => DamageType -> Int -> State g (MetaTree Room) sensorRoomRunPast dt n = do t <- sensorRoom dt n rToOnward "sensorRoomRunPast" $ t & applyToSubforest [0] diff --git a/src/Dodge/Room/Start.hs b/src/Dodge/Room/Start.hs index b814b8838..87c15d467 100644 --- a/src/Dodge/Room/Start.hs +++ b/src/Dodge/Room/Start.hs @@ -48,7 +48,7 @@ powerFakeout = do , keyholeCorridor, corridor]) `treeFromPost` cleatOnward door -startRoom :: RandomGen g => Int -> State g (LabTree Room) +startRoom :: RandomGen g => Int -> State g (MetaTree Room) startRoom i = join (takeOne [-- (,) (0.5::Float) ((chainUses <$> sequence [powerFakeout,fmap fst $weaponRoom i]) -- <&> (,TreeSubLabelling "chainUses <$> sequence [powerFakeout,weaponRoom i]" Nothing)) @@ -56,11 +56,11 @@ startRoom i = join (takeOne -- rezBoxesWp >>= rToOnward "rezBoxesWp" -- , rezBoxThenWeaponRoom i -- , rezBoxesWpCrit >>= rToOnward "rezBoxesWpCrit" - runPastStart i >>= rToOnward ("runPastStart " ++ show i) + runPastStart i >>= rToOnward ("runPastStart " ++ show i) -- , startCrafts >>= roomsContaining' [] >>= rezBoxThenRooms -- >>= rToOnward "startCrafts >>= roomsContaining [] >>= rezBoxThenRooms" ]) -randomChallenges :: RandomGen g => State g (LabTree Room) +randomChallenges :: RandomGen g => State g (MetaTree Room) randomChallenges = shootingRange -- join (takeOne -- [fmap (return . useAll) doubleCorridorBarrels <&> (,TreeSubLabelling "doubleCorridorBarrels" Nothing) @@ -88,13 +88,12 @@ rezBoxesThenWeaponRoom i = do wroom <- snd <$> weaponRoom i return (rboxes `passUntiluseAll` [wroom] , "rezBoxesThenWeaponRoom " ++ show i) -rezBoxThenWeaponRoom :: RandomGen g => Int -> State g (LabTree Room) +rezBoxThenWeaponRoom :: RandomGen g => Int -> State g (MetaTree Room) rezBoxThenWeaponRoom i = do rcol <- rezColor (_,wroom) <- weaponRoom i - return (toOnward ("rezBoxThenWeaponRoom "++ show i) - , treeFromTrunk [ rezBox rcol, door] wroom - ) + rToOnward ("rezBoxThenWeaponRoom "++ show i) + $ treeFromTrunk [ rezBox rcol, door] wroom rezBoxThenRoom :: RandomGen g => Room -> State g (Tree Room) rezBoxThenRoom r = do diff --git a/src/Dodge/Room/Warning.hs b/src/Dodge/Room/Warning.hs index c77bfc75f..e2baabf46 100644 --- a/src/Dodge/Room/Warning.hs +++ b/src/Dodge/Room/Warning.hs @@ -37,7 +37,7 @@ import qualified Data.Map.Strict as M --import qualified Data.Text as T -warningRooms :: RandomGen g => Int -> State g (LabTree Room) +warningRooms :: RandomGen g => Int -> State g (MetaTree Room) warningRooms n = do rm <- takeOne [roomNgon 8 200, roomRectAutoLinks 200 200] cenroom <- shuffleLinks $ addWarningTerminal n rm diff --git a/src/Dodge/UseAll.hs b/src/Dodge/UseAll.hs index b1cebcd5a..9b55cb916 100644 --- a/src/Dodge/UseAll.hs +++ b/src/Dodge/UseAll.hs @@ -1,6 +1,7 @@ {-# LANGUAGE TupleSections #-} module Dodge.UseAll where import Dodge.Data +import Dodge.Tree.Compose.Data import Data.Tree import Control.Lens @@ -15,8 +16,11 @@ toOnward s rm toOnward' :: Room -> Maybe Room toOnward' = fmap snd . toOnward "" -rToOnward :: Monad m => String -> Tree Room -> m (Room -> Maybe ([String],Room), Tree Room) -rToOnward s = return . (toOnward s ,) +rToOnward :: Monad m => String -> Tree Room -> m (MetaTree Room) +rToOnward s t = return $ MTree s (tToBTree t) [] + +tToBTree :: Tree Room -> MetaTree Room +tToBTree (Node r ts) = BTree (_rmName r) r $ map tToBTree ts toClusterLabel :: Int -> String -> Room -> Maybe ([String],Room) toClusterLabel i s rm