Fix bug in annotations

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
+    BTree {} -> MTree "ConstructedOnward" t1 [MBranch "Onward" toOnward' 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

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 
+initialAnoTree = OnwardList 
-        $ intersperse 
+        $ intersperse (SpecificRoom $ (tToBTree . pure) <$> shuffleLinks (cleatOnward corridor))
-        (SpecificRoom . return . tToBTree $ treePost [corridor,corridor,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]
+--    , [AnoApplyInt 100 healthTest]
---a    , SpecificRoom (tanksRoom [] [] >>= rToOnward "empty tanksRoom" . pure . cleatOnward)
+    , SpecificRoom (tanksRoom [] [] >>= rToOnward "empty tanksRoom" . pure . cleatOnward)
---"    , IntAnno $ PassthroughLockKeyLists lockRoomKeyItems itemRooms
+    , IntAnno $ PassthroughLockKeyLists lockRoomKeyItems itemRooms
---"    , SpecificRoom randomChallenges
+    , SpecificRoom randomChallenges
---"    , IntAnno $ SpecificRoom . lasSensorTurretTest
+    , IntAnno $ SpecificRoom . lasSensorTurretTest
---"--    ,[SpecificRoom $ fmap pure roomCCrits]
+--    ,[SpecificRoom $ fmap pure roomCCrits]
---"--    ,[AirlockAno]
+--    ,[AirlockAno]
---"--    ,[Corridor]
+--    ,[Corridor]
---"------    ,[SpecificRoom roomCCrits]
+------    ,[SpecificRoom roomCCrits]
---"------    ,[Corridor]
+------    ,[Corridor]
---"------    ,[SpecificRoom . pure . pure . useAll $ roomGlassOctogon 400 
+------    ,[SpecificRoom . pure . pure . useAll $ roomGlassOctogon 400 
---"------        & rmPS %~ ([sPS (V2 0 50) 0 $ PutCrit armourChaseCrit 
+------        & rmPS %~ ([sPS (V2 0 50) 0 $ PutCrit armourChaseCrit 
---"------                    ,sPS (V2 50 25) 0 $ PutCrit armourChaseCrit 
+------                    ,sPS (V2 50 25) 0 $ PutCrit armourChaseCrit 
---"------                    ,sPS (V2 50 0) 0 $ PutCrit armourChaseCrit 
+------                    ,sPS (V2 50 0) 0 $ PutCrit armourChaseCrit 
---"------                    ]++)
+------                    ]++)
---"------     ]
+------     ]
---"------    --,[SpecificRoom . pure . pure . useAll $ roomGlassOctogon 400 
+------    --,[SpecificRoom . pure . pure . useAll $ roomGlassOctogon 400 
---"------    --    & rmPS %~ ([swarmPS 0 (x,y) 0 swarmCrit | x <- [-20,-19.5.. 20] , y <- [200,202] ]++)
+------    --    & rmPS %~ ([swarmPS 0 (x,y) 0 swarmCrit | x <- [-20,-19.5.. 20] , y <- [200,202] ]++)
---"------    -- ]
+------    -- ]
---"------    ,[SpecificRoom . pure . pure . useAll $ roomGlassOctogon 400 
+------    ,[SpecificRoom . pure . pure . useAll $ roomGlassOctogon 400 
---"------        & rmPS %~ ([sPS (V2 0 50) 0 $ PutCrit pistolCrit ]++)
+------        & rmPS %~ ([sPS (V2 0 50) 0 $ PutCrit pistolCrit ]++)
---"------     ]
+------     ]
---"------    ,[Corridor]
+------    ,[Corridor]
---"----    --,[SpecificRoom $ pure . useAll <$> twinSlowDoorChasers]
+----    --,[SpecificRoom $ pure . useAll <$> twinSlowDoorChasers]
---"-----    ,[SpecificRoom $ pure $ (pure . useAll) (twinSlowDoorRoom 80 200 40)]
+-----    ,[SpecificRoom $ pure $ (pure . useAll) (twinSlowDoorRoom 80 200 40)]
---"-----    ,[DoorAno]
+-----    ,[DoorAno]
---"-----    ,[SpecificRoom $ pure . useAll <$> centerVaultExplosiveExit]
+-----    ,[SpecificRoom $ pure . useAll <$> centerVaultExplosiveExit]
---"-----    ,[SpecificRoom blockedCorridor]
+-----    ,[SpecificRoom blockedCorridor]
---"-----    ,[OrAno [[DoorAno]
+-----    ,[OrAno [[DoorAno]
---"-----            ,[Corridor]
+-----            ,[Corridor]
---"-----            ,[DoorNumAno 0,AirlockAno]] 
+-----            ,[DoorNumAno 0,AirlockAno]] 
---"-----            ]
+-----            ]
---"-----    ,[FirstWeapon]
+-----    ,[FirstWeapon]
---"-----    ,[CorridorDebug]
+-----    ,[CorridorDebug]
---"-----    ,[SpecificRoom $ fmap (pure . useAll) randomFourCornerRoom]
+-----    ,[SpecificRoom $ fmap (pure . useAll) randomFourCornerRoom]
---"--    ,[OrAno 
+--    ,[OrAno 
---"--        [[SpecificRoom $ branchRectWith $ fmap (fmap ) armouredChasers]
+--        [[SpecificRoom $ branchRectWith $ fmap (fmap ) armouredChasers]
---"--        ,[BossAno $ addArmour launcherCrit & crHP +~ 800
+--        ,[BossAno $ addArmour launcherCrit & crHP +~ 800
---"--            & crState . crDropsOnDeath .~ DropSpecific [0] ]
+--            & crState . crDropsOnDeath .~ DropSpecific [0] ]
---"--        ]
+--        ]
---"--     ]
+--     ]
---"----    ,[SpecificRoom $ fmap (pure . useAll) armouredCorridor]
+----    ,[SpecificRoom $ fmap (pure . useAll) armouredCorridor]
---"--    ,[Corridor]
+--    ,[Corridor]
---"--    ,[TreasureAno [addArmour autoCrit,addArmour autoCrit] [launcher]]
+--    ,[TreasureAno [addArmour autoCrit,addArmour autoCrit] [launcher]]
---"--    ,[Corridor]
+--    ,[Corridor]
---"    ,SpecificRoom $ randomFourCornerRoom [] >>= rToOnward "randomFourCornerRoom" . pure . cleatOnward 
+    ,SpecificRoom $ randomFourCornerRoom [] >>= rToOnward "randomFourCornerRoom" . pure . cleatOnward 
---"    ,SpecificRoom $ telRoomLev 1 >>= rToOnward "telRoomLev" . pure . cleatOnward
+    ,SpecificRoom $ telRoomLev 1 >>= rToOnward "telRoomLev" . pure . cleatOnward
     ]
 
 {- | A test level tree. -}

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

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 :: Monad m => (String -> m ()) -> MetaTree a -> m (Tree a)
-composeAndSubLog mt = case mt of
+composeAndSubLog dolog mt = case mt of
-    MTree{} -> composeAndLog mt
+    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 :: Monad m => (String -> m ()) -> MetaTree a -> m (Tree a)
-composeAndLog mt = case mt of
+composeAndLog dolog mt = case mt of
     MTree{} -> do
-        putStrLn $ drawTree $ logMT mt
+        dolog $ drawTree $ logMT mt
-        rt <- composeAndLog $ _mtTree mt
+        rt <- composeAndLog dolog $ _mtTree mt
-        brs <- mapM (\mb -> (_mbAttach mb,) <$> composeAndSubLog (_mbTree mb)) $ _mtBranches mt
+        brs <- mapM (\mb -> (_mbAttach mb,) <$> (composeAndSubLog dolog) (_mbTree mb)) $ _mtBranches mt
         return $ attachList rt $ map pure brs
     BTree{} -> do
-        putStrLn $ drawTree $ logMT mt
+        dolog $ drawTree $ logMT mt
-        brs <- mapM composeAndSubLog $ _btBranches mt
+        brs <- mapM (composeAndSubLog dolog) $ _btBranches mt
         return $ Node (_btValue mt) brs
 
 cmpToMT :: Tree (a-> Maybe (b,a), Tree a) -> MetaTree a