diff --git a/src/Dodge/Annotation.hs b/src/Dodge/Annotation.hs index 1c52bc1f6..9b3aa4564 100644 --- a/src/Dodge/Annotation.hs +++ b/src/Dodge/Annotation.hs @@ -7,8 +7,6 @@ module Dodge.Annotation import Dodge.UseAll import RandomHelp import Dodge.Tree -import Dodge.Tree.Compose ---import Dodge.Room import Dodge.Data import Dodge.Annotation.Data import LensHelp @@ -33,6 +31,6 @@ annoToRoomTree an = case an of ii <- randomitemidentity keyroom <- fromJust $ lookup ii ks return $ MTree ("PassthroughLockKeyLists-"++show ii) - (MTree "" lr [MBranch "" (toLabel' i) keyroom]) + (MTree "RassThroughLockKeyLists" lr [MBranch "" (toLabel i) keyroom]) [] diff --git a/src/Dodge/LevelGen.hs b/src/Dodge/LevelGen.hs index 1f987ba70..279f69605 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 (\str -> putStrLn str >> appendFile "log/treeCluster" str) treecluster + tc <- composeAndLog [0] (\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/Room/Start.hs b/src/Dodge/Room/Start.hs index 36c8dd1e6..f1e0458df 100644 --- a/src/Dodge/Room/Start.hs +++ b/src/Dodge/Room/Start.hs @@ -72,7 +72,7 @@ runPastStart :: RandomGen g => Int -> State g (Tree Room) runPastStart i = do s <- rezBoxStart rp <- lookedStart i - return . shiftChildren $ attachTree toOnward' rp $ fmap ([],) s + return . shiftChildren $ attachTree toOnward rp $ fmap ([],) s rezBoxStart :: RandomGen g => State g (Tree Room) @@ -84,13 +84,13 @@ rezBoxesThenWeaponRoom :: RandomGen g => Int -> State g (MetaTree Room) rezBoxesThenWeaponRoom i = do rboxes <- rezBoxes wroom <- weaponRoom i - return $ MTree "rezBoxesThenWeaponRoom" (tToBTree rboxes) [MBranch "" toOnward' wroom] + return $ tToBTree rboxes `attachOnward` wroom rezBoxThenWeaponRoom :: RandomGen g => Int -> State g (MetaTree Room) rezBoxThenWeaponRoom i = do rcol <- rezColor wroom <- weaponRoom i - return $ tToBTree (treePost [ rezBox rcol, cleatOnward door]) `attachOnward` wroom + return $ tToBTree (treePost [rezBox rcol, cleatOnward door]) `attachOnward` wroom rezBoxThenRoom :: RandomGen g => Room -> State g (Tree Room) rezBoxThenRoom r = do diff --git a/src/Dodge/Tree/Compose.hs b/src/Dodge/Tree/Compose.hs index 3cad59215..5d85fba87 100644 --- a/src/Dodge/Tree/Compose.hs +++ b/src/Dodge/Tree/Compose.hs @@ -1,15 +1,7 @@ {-# LANGUAGE TupleSections #-} {-| Combining and composing trees of trees. -} module Dodge.Tree.Compose - ( --expandTree - --, pure - --, pure - --, chainUses - --, useAllAtEnd - --, changeTo - --, applyToCompRoot - passUntiluseAll -- this should be moved, and the dependency on Dodge.Data removed - , tToBTree + ( tToBTree , overwriteLabel , composeTree , composeTree' @@ -17,7 +9,7 @@ module Dodge.Tree.Compose , attachTree , composeTreeRand , composeAndLog - , toOnward' + , toOnward , attachOnward -- , cmpToMT -- , compTree @@ -63,12 +55,6 @@ overwriteLabel i t ts = safeUpdateSingleNode -- islabel _ = False -- update (Node x _) = Node (f $ _unCompose x) ts -passUntiluseAll :: Tree Room -> [Tree Room] -> Tree Room -passUntiluseAll t ts = updateAllNodes - ((OnwardCluster `elem`) . (^?! rmClusterStatus . csLinks)) - ((branches .~ ts) . (root . rmClusterStatus . csLinks . at OnwardCluster .~ Nothing)) - t - --passUntiluseAll (Node (useAll x) _) ts' = Node ( x) ts' --passUntiluseAll (Node cn ts) ts' = Node ( (_unCompose cn)) $ map (`passUntiluseAll` ts') ts @@ -171,23 +157,33 @@ logMT mt = case mt of MTree str _ brs -> Node ("M:"++str) $ map logMB brs BTree str _ brs -> Node str $ map logMT brs -composeAndSubLog :: Monad m => (String -> m ()) -> MetaTree a -> m (Tree a) -composeAndSubLog dolog mt = case mt of - MTree{} -> composeAndLog dolog mt +composeAndSubLog :: Monad m => [Int] -> (String -> m ()) -> MetaTree a -> m (Tree a) +composeAndSubLog is dolog mt = case mt of + MTree{} -> do + dolog ("SUBTREE"++show is++mRootLabel mt++"\n") + rt <- composeAndLog (0:is) dolog $ _mtTree mt + brs <- mapM (\(i,mb) -> (_mbAttach mb,) <$> composeAndSubLog (is & ix 0 +~ 1) dolog (_mbTree mb)) + $ zip [0..] $ _mtBranches mt + return $ attachList rt $ map pure brs bt -> do - brs <- mapM (composeAndSubLog dolog) (_btBranches bt) + dolog ("SUBTREE:"++show is++mRootLabel mt++"\n") + dolog $ drawTree $ logMT mt + brs <- mapM (composeAndSubLog is dolog) (_btBranches bt) return $ Node (_btValue bt) brs -composeAndLog :: Monad m => (String -> m ()) -> MetaTree a -> m (Tree a) -composeAndLog dolog mt = case mt of +composeAndLog :: Monad m => [Int] -> (String -> m ()) -> MetaTree a -> m (Tree a) +composeAndLog is dolog mt = case mt of MTree{} -> do dolog $ drawTree $ logMT mt - rt <- composeAndLog dolog $ _mtTree mt - brs <- mapM (\mb -> (_mbAttach mb,) <$> composeAndSubLog dolog (_mbTree mb)) $ _mtBranches mt + dolog ("SUBTREE"++show is++mRootLabel mt++"\n") + rt <- composeAndLog (0:is) dolog $ _mtTree mt + brs <- mapM (\(i,mb) -> (_mbAttach mb,) <$> composeAndSubLog (is & ix 0 +~ 1) dolog (_mbTree mb)) + $ zip [0..] $ _mtBranches mt return $ attachList rt $ map pure brs BTree{} -> do + dolog ("SUBTREE:"++show is++mRootLabel mt++"\n") dolog $ drawTree $ logMT mt - brs <- mapM (composeAndSubLog dolog) $ _btBranches mt + brs <- mapM (composeAndSubLog is dolog) $ _btBranches mt return $ Node (_btValue mt) brs tToBTree :: Tree Room -> MetaTree Room @@ -195,11 +191,11 @@ tToBTree (Node r ts) = BTree (_rmName r) r $ map tToBTree ts attachOnward :: MetaTree Room -> MetaTree Room -> MetaTree Room attachOnward t1 t2 = case t1 of - MTree {} -> t1 & mtBranches .:~ MBranch "Onward" toOnward' t2 - BTree {} -> MTree "ConstructedOnward" t1 [MBranch "Onward" toOnward' t2] + MTree {} -> t1 & mtBranches .:~ MBranch "Onward" toOnward t2 + BTree {} -> MTree (mRootLabel t1 ++ "-" ++ mRootLabel t2) t1 [MBranch "Onward" toOnward t2] -toOnward' :: Room -> Maybe Room -toOnward' rm +toOnward :: Room -> Maybe Room +toOnward rm | OnwardCluster `elem` rm ^?! rmClusterStatus . csLinks = Just (rm & rmClusterStatus . csLinks . at OnwardCluster .~ Nothing) | otherwise = Nothing diff --git a/src/Dodge/Tree/Compose/Data.hs b/src/Dodge/Tree/Compose/Data.hs index 7d7573812..314e6b1f5 100644 --- a/src/Dodge/Tree/Compose/Data.hs +++ b/src/Dodge/Tree/Compose/Data.hs @@ -11,6 +11,11 @@ data MetaTree a = MTree {_mtLabel :: String , _mtTree :: MetaTree a , _mtBranches :: [MetaBranch a] } | BTree {_btLabel :: String , _btValue :: a , _btBranches :: [MetaTree a] } +mRootLabel :: MetaTree a -> String +mRootLabel mt = case mt of + MTree {} -> _mtLabel mt + BTree {} -> _btLabel mt + --type CompTree a = Tree (Tree a) type LabTree a = (a -> Maybe ([String],a),Tree a) type LabCompTree a = Tree (LabTree a) diff --git a/src/Dodge/UseAll.hs b/src/Dodge/UseAll.hs index cebacc601..e18187bd9 100644 --- a/src/Dodge/UseAll.hs +++ b/src/Dodge/UseAll.hs @@ -1,7 +1,6 @@ --{-# LANGUAGE TupleSections #-} module Dodge.UseAll - ( toOnward' - , toLabel' + ( toLabel , cleatOnward , cleatSide , rToOnward @@ -9,33 +8,19 @@ module Dodge.UseAll ) where import Dodge.Data import Dodge.Tree.Compose -import Dodge.Tree.Compose.Data import Data.Tree import Control.Lens import qualified Data.Set as S -toOnward :: String -> Room -> Maybe ([String],Room) -toOnward s rm - | OnwardCluster `elem` rm ^?! rmClusterStatus . csLinks - = Just ([s],rm & rmClusterStatus . csLinks . at OnwardCluster .~ Nothing) - | otherwise = Nothing - - -toLabel' :: Int -> Room -> Maybe Room -toLabel' i rm +toLabel :: Int -> Room -> Maybe Room +toLabel i rm | LabelCluster i `elem` rm ^?! rmClusterStatus . csLinks = Just rm | otherwise = Nothing rToOnward :: Monad m => String -> Tree Room -> m (MetaTree Room) rToOnward s t = return $ MTree s (tToBTree t) [] - -toClusterLabel :: Int -> String -> Room -> Maybe ([String],Room) -toClusterLabel i s rm - | LabelCluster i `elem` rm ^?! rmClusterStatus . csLinks = Just ([s],rm) - | otherwise = Nothing - cleatOnward :: Room -> Room cleatOnward = rmClusterStatus . csLinks .~ S.singleton OnwardCluster