justin/loop
1
0
Fork 0
Code Issues Pull Requests 1 Packages Projects Releases Wiki Activity

Fix bug in annotations

Browse Source
This commit is contained in:
justin
2022-06-12 18:23:57 +01:00
parent fa1e3ef2f5
commit deb02d5c1a
4 changed files with 63 additions and 105 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Annotation.hs
+1 -42
View File
@@ -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]
src/Dodge/Floor.hs
+50 -51
View File
@@ -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. -}
src/Dodge/LevelGen.hs
+1 -1
View File
@@ -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
src/Dodge/Tree/Compose.hs
+11 -11
View File
@@ -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