From deb02d5c1a4486072fb8fb48b95d203d8bfd4ca4 Mon Sep 17 00:00:00 2001 From: justin Date: Sun, 12 Jun 2022 18:23:57 +0100 Subject: [PATCH] Fix bug in annotations --- src/Dodge/Annotation.hs | 43 +--------------- src/Dodge/Floor.hs | 101 +++++++++++++++++++------------------- src/Dodge/LevelGen.hs | 2 +- src/Dodge/Tree/Compose.hs | 22 ++++----- 4 files changed, 63 insertions(+), 105 deletions(-) diff --git a/src/Dodge/Annotation.hs b/src/Dodge/Annotation.hs index 1a5ef4eb3..57d207acb 100644 --- a/src/Dodge/Annotation.hs +++ b/src/Dodge/Annotation.hs @@ -62,48 +62,7 @@ annoToRoomTree' an = case an of (MTree "" lr [MBranch "" (toLabel' i) keyroom]) [] ---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 - 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 - -{- | 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 - _ -> do - w <- state $ randomR (100,400) - h <- state $ randomR (200,400) - fmap (pure . cleatOnward) . shuffleLinks $ roomRectAutoLinks w h + BTree {} -> MTree "ConstructedOnward" t1 [MBranch "Onward" toOnward' t2] diff --git a/src/Dodge/Floor.hs b/src/Dodge/Floor.hs index 1b4613ff5..ac0a01800 100644 --- a/src/Dodge/Floor.hs +++ b/src/Dodge/Floor.hs @@ -37,11 +37,10 @@ import Data.List (intersperse) --import qualified Data.IntMap.Strict as IM initialAnoTree :: Annotation -initialAnoTree = PadWith door $ OnwardList - $ intersperse - (SpecificRoom . return . tToBTree $ treePost [corridor,corridor,cleatOnward corridor]) +initialAnoTree = OnwardList + $ intersperse (SpecificRoom $ (tToBTree . pure) <$> shuffleLinks (cleatOnward corridor)) [ IntAnno $ SpecificRoom . startRoom - , (SpecificRoom . return . tToBTree $ treePost [corridor,corridor,cleatOnward corridor]) +-- , (SpecificRoom . return . tToBTree $ treePost [corridor,corridor,cleatOnward corridor]) , IntAnno $ PassthroughLockKeyLists [(sensorRoomRunPast ELECTRICAL, takeOne [STATICMODULE,SPARKGUN] )] itemRooms , IntAnno $ PassthroughLockKeyLists keyCardRunPastRand itemRooms @@ -51,53 +50,53 @@ initialAnoTree = PadWith door $ OnwardList [ spNoID anyUnusedSpot (PutCrit invisibleChaseCrit) , spNoID anyUnusedSpot (PutCrit armourChaseCrit) ] ---a-- , [AnoApplyInt 100 healthTest] ---a , SpecificRoom (tanksRoom [] [] >>= rToOnward "empty tanksRoom" . pure . cleatOnward) ---" , IntAnno $ PassthroughLockKeyLists lockRoomKeyItems itemRooms ---" , SpecificRoom randomChallenges ---" , IntAnno $ SpecificRoom . 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] + , SpecificRoom (tanksRoom [] [] >>= rToOnward "empty tanksRoom" . pure . cleatOnward) + , IntAnno $ PassthroughLockKeyLists lockRoomKeyItems itemRooms + , SpecificRoom randomChallenges + , IntAnno $ SpecificRoom . 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. -} diff --git a/src/Dodge/LevelGen.hs b/src/Dodge/LevelGen.hs index dc29b42cc..1f987ba70 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,0) - tc <- composeAndLog $ treecluster + tc <- composeAndLog (\str -> putStrLn str >> appendFile "log/treeCluster" str) treecluster ---- (strs,tc) = composeTree' treecluster ----appendFile "log/TreeCluster" ("Seed: "++ show seed) ----mapM_ (appendFile "log/treeCluster" . ('\n':)) strs diff --git a/src/Dodge/Tree/Compose.hs b/src/Dodge/Tree/Compose.hs index 50443efa8..867e74bf8 100644 --- a/src/Dodge/Tree/Compose.hs +++ b/src/Dodge/Tree/Compose.hs @@ -167,23 +167,23 @@ logMT mt = case mt of MTree str _ brs -> Node ("M:"++str) $ map logMB brs BTree str _ brs -> Node str $ map logMT brs -composeAndSubLog :: MetaTree a -> IO (Tree a) -composeAndSubLog mt = case mt of - MTree{} -> composeAndLog mt +composeAndSubLog :: Monad m => (String -> m ()) -> MetaTree a -> m (Tree a) +composeAndSubLog dolog mt = case mt of + MTree{} -> composeAndLog dolog mt bt -> do - brs <- mapM composeAndSubLog $ _btBranches bt + brs <- mapM (composeAndSubLog dolog) (_btBranches bt) return $ Node (_btValue bt) brs -composeAndLog :: MetaTree a -> IO (Tree a) -composeAndLog mt = case mt of +composeAndLog :: Monad m => (String -> m ()) -> MetaTree a -> m (Tree a) +composeAndLog dolog mt = case mt of MTree{} -> do - putStrLn $ drawTree $ logMT mt - rt <- composeAndLog $ _mtTree mt - brs <- mapM (\mb -> (_mbAttach mb,) <$> composeAndSubLog (_mbTree mb)) $ _mtBranches mt + dolog $ drawTree $ logMT mt + rt <- composeAndLog dolog $ _mtTree mt + brs <- mapM (\mb -> (_mbAttach mb,) <$> (composeAndSubLog dolog) (_mbTree mb)) $ _mtBranches mt return $ attachList rt $ map pure brs BTree{} -> do - putStrLn $ drawTree $ logMT mt - brs <- mapM composeAndSubLog $ _btBranches mt + dolog $ drawTree $ logMT mt + brs <- mapM (composeAndSubLog dolog) $ _btBranches mt return $ Node (_btValue mt) brs cmpToMT :: Tree (a-> Maybe (b,a), Tree a) -> MetaTree a