Commit before further changes to MetaTrees

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])
             []
 

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

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

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

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)

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